git.iko.soy/gogol
on develop help sign in
Generating From/ToJSON instances for product and sum types
ce441a1Brendan Hay
gen/src/Gen/AST.hs+1
compare with develop
unifiedsplit
@@ -74,6 +74,7 @@ render svc = do
74 <$> (objDecl k p ts >>= pp Indent)
74 <$> (objDecl k p ts >>= pp Indent)
75 <*> ctor p ts
75 <*> ctor p ts
76 <*> traverse (lens p) (Map.toList ts)
76 <*> traverse (lens p) (Map.toList ts)
77+ <*> traverse (pp Indent) (jsonDecls k p ts)
77
78
78 ctor p ts = Fun' (cname k) (Just help)
79 ctor p ts = Fun' (cname k) (Just help)
79 <$> (pp None (ctorSig k ts) <&> comments ts)
80 <$> (pp None (ctorSig k ts) <&> comments ts)
gen/src/Gen/Solve.hs+3
@@ -77,6 +77,9 @@ instance HasInfo Solved where
77 where
77 where
78 f = lens _schema (\s a -> s { _schema = a })
78 f = lens _schema (\s a -> s { _schema = a })
79
79
80+monoid :: Solved -> Bool
81+monoid = elem DMonoid . _deriving
82+
80type Seen = Map (CI Text) (Set (CI Text))
83type Seen = Map (CI Text) (Set (CI Text))
81
84
82data Memo = Memo
85data Memo = Memo
gen/src/Gen/Syntax.hs+111−19
@@ -44,11 +44,7 @@ apiAlias n ls = TypeDecl noLoc n [] alias
44verbDecl :: Service s r -> Local -> Local -> Method -> Decl
44verbDecl :: Service s r -> Local -> Local -> Method -> Decl
45verbDecl s p l m = TypeDecl noLoc (vname p l) [] alias
45verbDecl s p l m = TypeDecl noLoc (vname p l) [] alias
46 where
46 where
47− alias = case path ++ qry of
48− [] -> unit_tycon
49− x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":>")) r) x xs
47+ alias = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r) verb (path ++ qry)
50−
51−-- Need to deal with interpolation?
52
48
53 path :: [Type]
49 path :: [Type]
54 path = map match
50 path = map match
@@ -87,6 +83,99 @@ verbDecl s p l m = TypeDecl noLoc (vname p l) [] alias
87 typ = tycon "'[JSON]"
83 typ = tycon "'[JSON]"
88 res = maybe (tycon "()") (tycon . Free) (_mResponse m)
84 res = maybe (tycon "()") (tycon . Free) (_mResponse m)
89
85
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+
90objDecl :: Id -> Pre -> Map Local Solved -> AST Decl
179objDecl :: Id -> Pre -> Map Local Solved -> AST Decl
91objDecl n p rs = DataDecl noLoc arity [] d [] [conDecl d p rs] <$> derivings n
180objDecl n p rs = DataDecl noLoc arity [] d [] [conDecl d p rs] <$> derivings n
92 where
181 where
@@ -126,23 +215,13 @@ ctorDecl n p rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds
126fieldUpdate :: Pre -> Local -> Solved -> FieldUpdate
215fieldUpdate :: Pre -> Local -> Solved -> FieldUpdate
127fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
216fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
128 where
217 where
129− rhs | s ^. required = v
218+ rhs | s ^. required = v
130− | Just x <- s ^. defaulted = def x (_schema s)
219+ | Just x <- def s = x
131− | Just x <- iso (_type s) = infixApp x "#" v
220+ | Just x <- iso (_type s) = infixApp x "#" v
132− | otherwise = var (name "Nothing")
221+ | otherwise = var (name "Nothing")
133
222
134 v = var (pname p l)
223 v = var (pname p l)
135
224
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−
146lensSig :: Id -> Pre -> Local -> Solved -> Decl
225lensSig :: Id -> Pre -> Local -> Solved -> Decl
147lensSig n p l s = TypeSig noLoc [lname p l] $
226lensSig n p l s = TypeSig noLoc [lname p l] $
148 TyApp (TyApp (tycon "Lens'") (tycon n))
227 TyApp (TyApp (tycon "Lens'") (tycon n))
@@ -165,6 +244,19 @@ derivings k = map ((,[]) . unqual . drop 1 . show) <$> derive k
165parameters :: [Solved] -> [Type]
244parameters :: [Solved] -> [Type]
166parameters = map (external . _type) . filter (view required)
245parameters = map (external . _type) . filter (view required)
167
246
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+
168external, internal :: TType -> Type
260external, internal :: TType -> Type
169external = internal . \case
261external = internal . \case
170 TMaybe t@TList {} -> t
262 TMaybe t@TList {} -> t
gen/src/Gen/Types.hs+9−8
@@ -306,7 +306,7 @@ instance ToJSON Branch where
306
306
307data Data
307data Data
308 = Sum Name (Maybe Help) [Branch]
308 = Sum Name (Maybe Help) [Branch]
309− | Prod Name (Maybe Help) Rendered Fun [Fun]
309+ | Prod Name (Maybe Help) Rendered Fun [Fun] [Rendered]
310
310
311instance ToJSON Data where
311instance ToJSON Data where
312 toJSON = \case
312 toJSON = \case
@@ -317,13 +317,14 @@ instance ToJSON Data where
317 , "branches" .= bs
317 , "branches" .= bs
318 ]
318 ]
319
319
320− Prod n h d c ls -> object
320+ Prod n h d c ls is -> object
321− [ "name" .= Syn n
321+ [ "name" .= Syn n
322− , "type" .= "prod"
322+ , "type" .= "prod"
323− , "decl" .= d
323+ , "decl" .= d
324− , "help" .= h
324+ , "help" .= h
325− , "ctor" .= c
325+ , "ctor" .= c
326− , "lenses" .= ls
326+ , "lenses" .= ls
327+ , "instances" .= is
327 ]
328 ]
328
329
329data Action = Action Name (Maybe Help) Rendered
330data Action = Action Name (Maybe Help) Rendered
gen/template/_include/prod.ede+4
@@ -26,3 +26,7 @@
26{{ lens.value.sig }}
26{{ lens.value.sig }}
27{{ lens.value.decl }}
27{{ lens.value.decl }}
28{% endfor %}
28{% endfor %}
29+{% for class in type.instances %}
30+
31+{{ class.value }}
32+{% endfor %}
gen/template/_include/sum.ede+6
@@ -26,3 +26,9 @@ instance ToText {{ type.name }} where
26 {% for branch in type.branches %}
26 {% for branch in type.branches %}
27 {{ branch.value.name }} -> "{{ branch.value.value }}"
27 {{ branch.value.name }} -> "{{ branch.value.value }}"
28 {% endfor %}
28 {% endfor %}
29+
30+instance FromJSON {{ type.name }} where
31+ parseJSON = parseJSONText "{{ type.name }}"
32+
33+instance ToJSON {{ type.name }} where
34+ toJSON = toJSONText
gen/template/prod.ede+1
@@ -1,6 +1,7 @@
1{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveGeneric #-}
2{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RecordWildCards #-}
4
5
5{-# OPTIONS_GHC -fno-warn-unused-imports #-}
6{-# OPTIONS_GHC -fno-warn-unused-imports #-}
6
7