@@ -44,11 +44,7 @@ apiAlias n ls = TypeDecl noLoc n [] alias
4444verbDecl :: Service s r -> Local -> Local -> Method -> Decl
4545verbDecl s p l m = TypeDecl noLoc (vname p l) [] alias
4646 where
47− alias = case path ++ qry of
48− [] -> unit_tycon
49− x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":>")) r) x xs
50−
51−-- Need to deal with interpolation?
47+ alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r) verb (path ++ qry)
5248
5349 path :: [Type]
5450 path = map match
@@ -87,6 +83,99 @@ verbDecl s p l m = TypeDecl noLoc (vname p l) [] alias
8783 typ = tycon "'[JSON]"
8884 res = maybe (tycon "()") (tycon . Free) (_mResponse m)
8985
86+jsonDecls :: Id -> Pre -> Map Local Solved -> [Decl]
87+jsonDecls n p rs = [from, to]
88+ where
89+ from = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon n]
90+ [ funD "parseJSON" $
91+ app (app (var "withObject") (str (idToText n))) $
92+ lamE noLoc [pvar "o"] $
93+ ctorE n (map decode (Map.toList rs))
94+ ]
95+
96+ decode (l, s)
97+ | Just x <- def s = defJS l x
98+ | s ^. required = reqJS l
99+ | monoid s = defJS l (var "mempty")
100+ | otherwise = optJS l
101+
102+ to = InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon n]
103+ [ wildcardD "toJSON" n omit none (map encode (Map.toList rs))
104+ ]
105+
106+ omit = app (var "object")
107+ . app (var "catMaybes")
108+ . listE
109+
110+ none = paren $ app (var "Object") (var "mempty")
111+
112+ encode (l, s)
113+ | TMaybe {} <- _type s = infixApp (paren (app n o)) "<$>" a
114+ | otherwise = app (var "Just") (infixApp n ".=" a)
115+ where
116+ n = str (local l)
117+ a = var (fname p l)
118+ o = var ".="
119+
120+wildcardD :: String
121+ -> Id
122+ -> ([Exp] -> Exp)
123+ -> Exp
124+ -> [Exp]
125+ -> InstDecl
126+wildcardD f n enc x = \case
127+ [] -> constD f x
128+ xs -> InsDecl (FunBind [match prec xs])
129+ where
130+ match p es =
131+ Match noLoc (name f) [p] Nothing (UnGuardedRhs (enc es)) noBinds
132+
133+ prec = PRec (UnQual (dname n)) [PFieldWildcard]
134+
135+defJS :: Local -> Exp -> Exp
136+defJS n x = infixApp (infixApp (var "o") ".:?" (str (local n))) ".!=" x
137+
138+reqJS :: Local -> Exp
139+reqJS = infixApp (var "o") ".:" . str . local
140+
141+optJS :: Local -> Exp
142+optJS = infixApp (var "o") ".:?" . str . local
143+
144+funD :: String -> Exp -> InstDecl
145+funD f = InsDecl . patBind noLoc (pvar (name f))
146+
147+constD :: String -> Exp -> InstDecl
148+constD f x = InsDecl $
149+ sfun noLoc (name f) [] (UnGuardedRhs (app (var "const") x)) noBinds
150+
151+ctorE :: Id -> [Exp] -> Exp
152+ctorE n = seqE (var (dname n)) . map paren
153+
154+seqE :: Exp -> [Exp] -> Exp
155+seqE l [] = app (var "pure") l
156+seqE l (r:rs) = infixApp l "<$>" (infixE r "<*>" rs)
157+
158+-- toJSOND :: Protocol -> Id -> [Field] -> Decl
159+-- toJSOND p n = instD1 "ToJSON" n
160+-- . wildcardD n "toJSON" enc (paren $ app (var "Object") memptyE)
161+-- . map (Right . toJSONE p)
162+-- where
163+-- enc = app (var "object")
164+-- . app (var "catMaybes")
165+-- . listE
166+-- . map (either id id)
167+
168+-- instD1 :: Text -> Id -> InstDecl -> Decl
169+-- instD1 c n = instD c n . (:[])
170+
171+-- instD :: Text -> Id -> [InstDecl] -> Decl
172+-- instD c n = InstDecl noLoc Nothing [] [] (unqual c) [tycon (typeId n)]
173+
174+-- memptyE :: Exp
175+-- memptyE = var "mempty"
176+
177+
178+
90179objDecl :: Id -> Pre -> Map Local Solved -> AST Decl
91180objDecl n p rs = DataDecl noLoc arity [] d [] [conDecl d p rs] <$> derivings n
92181 where
@@ -126,23 +215,13 @@ ctorDecl n p rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds
126215fieldUpdate :: Pre -> Local -> Solved -> FieldUpdate
127216fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
128217 where
129− rhs | s ^. required = v
130− | Just x <- s ^. defaulted = def x (_schema s)
131− | Just x <- iso (_type s) = infixApp x "#" v
132− | otherwise = var (name "Nothing")
218+ rhs | s ^. required = v
219+ | Just x <- def s = x
220+ | Just x <- iso (_type s) = infixApp x "#" v
221+ | otherwise = var (name "Nothing")
133222
134223 v = var (pname p l)
135224
136− def x = \case
137− Enum {} -> var (bname (_prefix s) x)
138− Lit _ Bool -> lit (upperHead x)
139− Lit _ Text -> str x
140− Lit _ _ -> lit x
141− --- FIXME: lift to AST
142− s -> error $ "Unmatched fieldUpdate:\n" ++ show s
143−
144− lit = var . name . Text.unpack
145−
146225lensSig :: Id -> Pre -> Local -> Solved -> Decl
147226lensSig n p l s = TypeSig noLoc [lname p l] $
148227 TyApp (TyApp (tycon "Lens'") (tycon n))
@@ -165,6 +244,19 @@ derivings k = map ((,[]) . unqual . drop 1 . show) <$> derive k
165244parameters :: [Solved] -> [Type]
166245parameters = map (external . _type) . filter (view required)
167246
247+def :: Solved -> Maybe Exp
248+def s
249+ | Just x <- s ^. defaulted = Just (go x (_prefix s) (_schema s))
250+ | otherwise = Nothing
251+ where
252+ go x p = \case
253+ Enum {} -> var (bname p x)
254+ Lit _ Bool -> lit (upperHead x)
255+ Lit _ Text -> str x
256+ Lit {} -> lit x
257+
258+ lit = var . name . Text.unpack
259+
168260external, internal :: TType -> Type
169261external = internal . \case
170262 TMaybe t@TList {} -> t