0 | module Derive.FromJSON

  2 | import JSON.Option

  3 | import JSON.FromJSON

  4 | import public Derive.Show

  5 | import Language.Reflection.Util

  7 | %default total

 19 | generalFromJsonType : (implicits : List Arg) -> (arg : TTImp) -> TTImp

 20 | generalFromJsonType is arg =

 21 |   piAll `({0 v : _} -> {0 obj : _} -> Value v obj => Parser v ~(arg)) is

 26 | fromJsonClaim : (fun : Name) -> (p : ParamTypeInfo) -> Decl

 27 | fromJsonClaim fun p =

 28 |   let tpe := generalFromJsonType (allImplicits p "FromJSON") p.applied

 29 |    in public' fun tpe

 33 | fromJsonImplClaim : (impl : Name) -> (p : ParamTypeInfo) -> Decl

 34 | fromJsonImplClaim impl p = implClaim impl (implType "FromJSON" p)

 40 | val : Name

 41 | val = "val"

 43 | bval : TTImp

 44 | bval = bindVar val

 46 | vval : TTImp

 47 | vval = var val

 49 | obj : Name

 50 | obj = "obj"

 52 | bobj : TTImp

 53 | bobj = bindVar obj

 55 | vobj : TTImp

 56 | vobj = var obj

 58 | matchArray : SnocList (BoundArg 2 p) -> TTImp -> TTImp

 59 | matchArray [<]                  s = s

 60 | matchArray (sx :< BA _ [_,y] _) s =

 61 |   matchArray sx `(~(bindVar y) :: ~(s))

 63 | constClause : DCon -> Clause

 64 | constClause c = patClause c.tag c.applied

 66 | matchEither : (pat,res : TTImp) -> Name -> TTImp

 67 | matchEither pat res x =

 68 |   `(case ~(pat) of

 69 |      Right ~(bindVar x) => ~(res)

 70 |      Left e             => Left e)

 74 | fromJsonImplDef : (fun,impl : Name) -> Decl

 75 | fromJsonImplDef f i = def i [patClause (var i) (var "MkFromJSON" `app` var f)]

 77 | parameters (nms : List Name) (o : Options) (tpeName : TTImp) (err : TTImp)

 79 |   dec : Name -> TTImp

 80 |   dec n =

 81 |     let fnm := fieldNamePrim o n

 82 |      in case o.replaceMissingKeysWithNull of

 83 |           True  => `(optField ~(vobj) ~(fnm))

 84 |           False => `(field ~(vobj) ~(fnm))

 86 |   decFields : SnocList (BoundArg 2 RegularNamed) -> (res : TTImp) -> TTImp

 87 |   decFields [<] res = `(withObject ~(tpeName) $ \ ~(bobj) => ~(res))

 88 |   decFields (sx :< (BA a [x,y] _)) res =

 89 |     let pat := assertIfRec nms a.type (dec $ argName a)

 90 |      in decFields sx (matchEither pat res x)

 92 |   decValues : SnocList (BoundArg 2 Regular) -> (res : TTImp) -> TTImp

 93 |   decValues sx res =

 94 |     let nargs := `(Prelude.fromInteger ~(primVal $ BI $ cast (length sx)))

 95 |         mtch  := matchArray sx `(Nil)

 96 |      in `(withArrayN ~(nargs) ~(tpeName) $ \ ~(mtch) => ~(go sx res))

 97 |     where go : SnocList (BoundArg 2 Regular) -> TTImp -> TTImp

 98 |           go [<]                    res = res

 99 |           go (sx :< (BA a [x,y] _)) res =

100 |             let pat := assertIfRec nms a.type `(fromJSON ~(var y))

101 |              in go sx (matchEither pat res x)

103 |   consts : List DCon -> TTImp

104 |   consts ds =

105 |     let catch := patClause `(s) `(fail $ ~(err) ++ show s)

106 |         cse   :=  lam (lambdaArg {a = Name} "x") $

107 |                   iCase `(x) implicitFalse (map constClause ds ++ [catch])

108 |      in `(withString ~(tpeName) ~(cse))

110 |   withArgs : DCon -> List DCon -> TTImp

111 |   withArgs d ds = case o.sum of

112 |     UntaggedValue         => untagged

113 |     ObjectWithSingleField => `(fromSingleField ~(tpeName) ~(pairCases))

114 |     TwoElemArray          => `(fromTwoElemArray ~(tpeName) ~(pairCases))

115 |     (TaggedObject tg cs)  =>

116 |       let tf := primVal $ Str tg

117 |           cf := primVal $ Str cs

118 |        in `(fromTaggedObject ~(tpeName) ~(tf) ~(cf) ~(pairCases))

120 |     where

121 |       rhs : DCon -> TTImp

122 |       rhs c = case c.args of

123 |         Const       => decFields [<] c.applied

124 |         Fields [<x] => case o.unwrapUnary of

125 |           True  => assertIfRec nms x.arg.type `(map ~(var c.name) . fromJSON)

126 |           False => decFields [<x]  c.applied

127 |         Values [<x] => case o.unwrapUnary of

128 |           True  => assertIfRec nms x.arg.type `(map ~(var c.name) . fromJSON)

129 |           False => decValues [<x]  c.applied

130 |         Fields sx   => decFields sx  c.applied

131 |         Values sx   => decValues sx  c.applied

133 |       clause : DCon -> Clause

134 |       clause c =

135 |         let rightHand := `(prependPath (~(rhs c) ~(vval)) $ Key ~(c.tag))

136 |          in patClause `(MkPair ~(c.tag) ~(bval)) rightHand

138 |       pairCases : TTImp

139 |       pairCases =

140 |         let clauses := map clause (d :: ds)

141 |             catch   := patClause `(MkPair s _) `(fail $ ~(err) ++ show s)

142 |          in lam (lambdaArg {a = Name} "x") $

143 |             iCase `(x) implicitFalse (clauses ++ [catch])

145 |       untagged : TTImp

146 |       untagged = foldl (\t,c => `(JSON.FromJSON.(<|>) ~(t) ~(rhs c))) (rhs d) ds

149 |   decSum : (constants, withArgs : List DCon) -> TTImp

150 |   decSum [] []        = `(fail $ "Uninhabited type: " ++ ~(tpeName))

151 |   decSum [] (w :: ws) = withArgs w ws

152 |   decSum cs []        = consts cs

153 |   decSum cs (w :: ws) = `(JSON.FromJSON.(<|>) ~(consts cs) ~(withArgs w ws))

155 |   decRecord : DCon -> TTImp

156 |   decRecord c = case c.args of

157 |     Const       => consts [c]

158 |     Fields [<x] => assertIfRec nms x.arg.type `(map ~(var c.name) . fromJSON)

159 |     Values [<x] => assertIfRec nms x.arg.type `(map ~(var c.name) . fromJSON)

160 |     Fields sx   => decFields sx c.applied

161 |     Values sx   => decValues sx c.applied

163 |   export

164 |   fromJsonClause : (fun : Name) -> TypeInfo -> Clause

165 |   fromJsonClause fun x = case map (dcon o) x.cons of

166 |     [c] =>

167 |       if o.unwrapRecords then patClause (var fun) (decRecord c)

168 |       else if isConst c then patClause (var fun) (decSum [c] [])

169 |       else patClause (var fun) (decSum [] [c])

170 |     cs  =>

171 |       let (consts,withArgs) := partition isConst cs

172 |        in  patClause (var fun) (decSum consts withArgs)

174 |   export

175 |   fromJsonDef : Name -> TypeInfo -> Decl

176 |   fromJsonDef fun ti = def fun [fromJsonClause fun ti]

182 | err : Named a => a -> TTImp

183 | err v = primVal $ Str $ "Unexpected constructor tag for \{v.nameStr}: "

186 | customFromJSON : Options -> List Name -> ParamTypeInfo -> Res (List TopLevel)

187 | customFromJSON o nms p =

188 |   let fun  := funName p "fromJson"

189 |       impl := implName p "FromJSON"

190 |    in Right

191 |         [ TL (fromJsonClaim fun p)

192 |              (fromJsonDef nms o p.namePrim (err p) fun p.info)

193 |         , TL (fromJsonImplClaim impl p) (fromJsonImplDef fun impl)

194 |         ]

199 | export %inline

200 | FromJSON : List Name -> ParamTypeInfo -> Res (List TopLevel)

201 | FromJSON = customFromJSON defaultOptions