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 fnstr := fieldName o n

 82 |         fnm := primVal (Str fnstr)

 83 |      in case o.replaceMissingKeysWithNull fnstr of

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

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

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

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

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

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

 91 |      in decFields sx (matchEither pat res x)

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

 94 |   decValues sx res =

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

 96 |         mtch  := matchArray sx `(Nil)

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

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

 99 |           go [<]                    res = res

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

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

102 |              in go sx (matchEither pat res x)

104 |   consts : List DCon -> TTImp

105 |   consts ds =

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

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

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

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

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

112 |   withArgs d ds = case o.sum of

113 |     UntaggedValue         => untagged

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

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

116 |     (TaggedObject tg cs)  =>

117 |       let tf := primVal $ Str tg

118 |           cf := primVal $ Str cs

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

121 |     where

122 |       rhs : DCon -> TTImp

123 |       rhs c = case c.args of

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

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

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

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

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

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

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

131 |         Fields sx   => decFields sx  c.applied

132 |         Values sx   => decValues sx  c.applied

134 |       clause : DCon -> Clause

135 |       clause c =

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

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

139 |       pairCases : TTImp

140 |       pairCases =

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

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

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

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

146 |       untagged : TTImp

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

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

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

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

153 |   decSum cs []        = consts cs

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

156 |   decRecord : DCon -> TTImp

157 |   decRecord c = case c.args of

158 |     Const       => consts [c]

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

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

161 |     Fields sx   => decFields sx c.applied

162 |     Values sx   => decValues sx c.applied

164 |   export

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

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

167 |     [c] =>

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

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

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

171 |     cs  =>

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

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

175 |   export

176 |   fromJsonDef : Name -> TypeInfo -> Decl

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

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

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

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

188 | customFromJSON o nms p =

189 |   let fun  := funName p "fromJson"

190 |       impl := implName p "FromJSON"

191 |    in Right

192 |         [ TL (fromJsonClaim fun p)

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

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

195 |         ]

200 | export %inline

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

202 | FromJSON = customFromJSON defaultOptions