0 | module Derive.FromJSON.Simple

  2 | import JSON.Simple.Option

  3 | import JSON.Simple.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 `(Parser JSON ~(arg)) is

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

 27 | fromJsonClaim vis fun p =

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

 29 |    in simpleClaim vis fun tpe

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

 34 | fromJsonImplClaim vis impl p = implClaimVis vis 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 `(Data.Vect.(::) ~(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 `(Data.Vect.Nil)

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

 98 |     where

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

100 |       go [<]                    res = res

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

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

103 |          in go sx (matchEither pat res x)

105 |   consts : List DCon -> TTImp

106 |   consts ds =

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

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

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

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

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

113 |   withArgs d ds = case o.sum of

114 |     UntaggedValue         => untagged

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

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

117 |     (TaggedObject tg cs)  =>

118 |       let tf := primVal $ Str tg

119 |           cf := primVal $ Str cs

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

122 |     where

123 |       rhs : DCon -> TTImp

124 |       rhs c = case c.args of

125 |         Const       => decFields [<] c.applied -- not possible

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

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

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

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

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

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

132 |         Fields sx   => decFields sx  c.applied

133 |         Values sx   => decValues sx  c.applied

135 |       clause : DCon -> Clause

136 |       clause c =

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

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

140 |       pairCases : TTImp

141 |       pairCases =

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

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

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

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

147 |       untagged : TTImp

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

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

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

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

154 |   decSum cs []        = consts cs

155 |   decSum cs (w :: ws) = `(~(consts cs) <|> ~(withArgs w ws))

157 |   decRecord : DCon -> TTImp

158 |   decRecord c = case c.args of

159 |     Const       => consts [c]

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

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

162 |     Fields sx   => decFields sx c.applied

163 |     Values sx   => decValues sx c.applied

165 |   export

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

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

168 |     [c] =>

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

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

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

172 |     cs  =>

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

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

176 |   export

177 |   fromJsonDef : Name -> TypeInfo -> Decl

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

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

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

188 | customFromJSON :

189 |      Visibility

190 |   -> Options

191 |   -> List Name

192 |   -> ParamTypeInfo

193 |   -> Res (List TopLevel)

194 | customFromJSON vis o nms p =

195 |   let fun  := funName p "fromJson"

196 |       impl := implName p "FromJSON"

197 |    in Right

198 |         [ TL (fromJsonClaim vis fun p)

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

200 |         , TL (fromJsonImplClaim vis impl p) (fromJsonImplDef fun impl)

201 |         ]

206 | export %inline

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

208 | FromJSON = customFromJSON Export defaultOptions