git.iko.soy/gogol
on develop help sign in
Hacking on additionalProperties support
commit8234724e2977c5710eaf4a519a853955d3a38cc9 authorBrendan Hay <brendan.g.hay@gmail.com> dateSun 11 Oct 2015, 13:00 (11 years ago) parentdf4f01e
5 files changed+51−19
compare with develop
unifiedsplit
gen/src/Gen/AST/Flatten.hs+3−2 gen/src/Gen/AST/Render.hs+6−1 gen/src/Gen/AST/Solve.hs+5−4 gen/src/Gen/Syntax.hs+24−7 gen/src/Gen/Types.hs+13−5
gen/src/Gen/AST/Flatten.hs+3−2
@@ -89,8 +89,9 @@ schema g ml (Fix f) = go (maybe g (reference g) ml) f >>= uncurry insert
8989 array p (Arr e) =
9090 Arr <$> schema p (Just "item") (setRequired e)
9191
92− object p (Obj aps ps) =
93− Obj Nothing <$> Map.traverseWithKey (localSchema p) ps
92+ object p (Obj aps ps) = Obj
93+ <$> traverse (localSchema p "properties") aps
94+ <*> Map.traverseWithKey (localSchema p) ps
9495
9596 name i p xs
9697 | Just x <- i ^. iId = pure x
gen/src/Gen/AST/Render.hs+6−1
@@ -70,7 +70,12 @@ renderSchema s = go (_schema s)
7070 enum i (Enm vs) = Sum (dname k) (i ^. iDescription) $
7171 map (\(v, h) -> Branch (bname p v) v h) vs
7272
73− object i (Obj aps ps) = traverse getSolved ps >>= prod
73+ object i (Obj aps ps) = do
74+ a <- traverse getSolved aps
75+ p <- traverse getSolved ps
76+ let ap = setAdditional <$> a
77+ ts = maybe p (flip (Map.insert "properties") p) ap
78+ prod ts
7479 where
7580 prod ts = Prod (dname k) (i ^. iDescription)
7681 <$> pp Indent (objDecl k p ds ts)
gen/src/Gen/AST/Solve.hs+5−4
@@ -72,10 +72,11 @@ method = traverse getSolved
7272
7373getSolved :: Global -> AST Solved
7474getSolved g = loc "getSolved" g $
75− Solved g <$> getPrefix g
76− <*> getSchema g
77− <*> getType g
78− <*> getDerive g
75+ Solved False g
76+ <$> getPrefix g
77+ <*> getSchema g
78+ <*> getType g
79+ <*> getDerive g
7980
8081getSchema :: Global -> AST (Schema Global)
8182getSchema g = do
gen/src/Gen/Syntax.hs+24−7
@@ -263,14 +263,23 @@ jsonDecls g p (Map.toList -> rs) = [from, to]
263263 ]
264264
265265 decode (l, s)
266+ | _additional s = app (var "parseJSON") (app (var "Object") (var "o"))
266267 | Just x <- def s = defJS l x
267268 | required s = reqJS l
268269 | monoid s = defJS l (var "mempty")
269270 | otherwise = optJS l
270271
271− to = InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
272− [ wildcardD "toJSON" g omit none (map encode rs)
273− ]
272+ to = case rs of
273+ [(k, v)] | _additional v ->
274+ InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
275+ [ funD "toJSON" $
276+ infixApp (var "toJSON") "." (var (fname p k))
277+ ]
278+
279+ _ ->
280+ InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
281+ [ wildcardD "toJSON" g omit none (map encode rs)
282+ ]
274283
275284 omit = app (var "object")
276285 . app (var "catMaybes")
@@ -420,13 +429,17 @@ externalType = \case
420429 TMaybe t -> TyApp (TyCon "Maybe") (externalType t)
421430 TList t -> TyList (externalType t)
422431 TLit l -> externalLit l
432+ TMap k v ->
433+ TyApp (TyApp (TyCon "HashMap") (externalType k)) (externalType (require v))
423434
424435internalType :: TType -> Type
425436internalType = \case
426− TType r -> tycon r
427− TMaybe t -> TyApp (TyCon "Maybe") (internalType t)
428− TList t -> TyList (internalType t)
429− TLit l -> internalLit l
437+ TType r -> tycon r
438+ TMaybe t -> TyApp (TyCon "Maybe") (internalType t)
439+ TList t -> TyList (internalType t)
440+ TLit l -> internalLit l
441+ TMap k v ->
442+ TyApp (TyApp (TyCon "HashMap") (internalType k)) (internalType (require v))
430443
431444externalLit :: Lit -> Type
432445externalLit = \case
@@ -490,6 +503,10 @@ iso = \case
490503 TLit DateTime -> Just (var "_DateTime")
491504 _ -> Nothing
492505
506+require :: TType -> TType
507+require (TMaybe t) = t
508+require t = t
509+
493510strict :: Type -> Type
494511strict = TyBang BangedTy . \case
495512 t@TyApp{} -> TyParen t
gen/src/Gen/Types.hs+13−5
@@ -269,6 +269,7 @@ data TType
269269 | TLit Lit
270270 | TMaybe TType
271271 | TList TType
272+ | TMap TType TType
272273 deriving (Eq, Show)
273274
274275data Derive
@@ -288,11 +289,12 @@ data Derive
288289 deriving (Eq, Show)
289290
290291data Solved = Solved
291− { _unique :: Global
292− , _prefix :: Prefix
293− , _schema :: Schema Global
294− , _type :: TType
295− , _deriving :: [Derive]
292+ { _additional :: Bool
293+ , _unique :: Global
294+ , _prefix :: Prefix
295+ , _schema :: Schema Global
296+ , _type :: TType
297+ , _deriving :: [Derive]
296298 } deriving (Show)
297299
298300instance HasInfo Solved where
@@ -303,6 +305,12 @@ instance HasInfo Solved where
303305monoid :: Solved -> Bool
304306monoid = elem DMonoid . _deriving
305307
308+setAdditional :: Solved -> Solved
309+setAdditional s = setRequired $ s
310+ { _additional = True
311+ , _type = TMap (TLit Text) (_type s)
312+ }
313+
306314type Seen = Map (CI Text) {- Prefix -} (Set (CI Text)) {- Inhabitants -}
307315
308316data Memo = Memo