8234724 · gogol · git.iko.soy

gen/src/Gen/AST/Flatten.hs+3−2

compare with develop

unifiedsplit

@@ -89,8 +89,9 @@ schema g ml (Fix f) = go (maybe g (reference g) ml) f >>= uncurry insert

89 array p (Arr e) =

90 Arr <$> schema p (Just "item") (setRequired e)

91

92− object p (Obj aps ps) =

92+ object p (Obj aps ps) = Obj

93+ <$> traverse (localSchema p "properties") aps

93− Obj Nothing <$> Map.traverseWithKey (localSchema p) ps

94+ <*> Map.traverseWithKey (localSchema p) ps

94

95

95 name i p xs

96 name i p xs

96 | Just x <- i ^. iId = pure x

97 | Just x <- i ^. iId = pure x

gen/src/Gen/AST/Render.hs+6−1

@@ -70,7 +70,12 @@ renderSchema s = go (_schema s)

70 enum i (Enm vs) = Sum (dname k) (i ^. iDescription) $

71 map (\(v, h) -> Branch (bname p v) v h) vs

72

73+ object i (Obj aps ps) = do

73− object i (Obj aps ps) = traverse getSolved ps >>= prod

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

74 where

79 where

75 prod ts = Prod (dname k) (i ^. iDescription)

80 prod ts = Prod (dname k) (i ^. iDescription)

76 <$> pp Indent (objDecl k p ds ts)

81 <$> pp Indent (objDecl k p ds ts)

gen/src/Gen/AST/Solve.hs+5−4

@@ -72,10 +72,11 @@ method = traverse getSolved

72

73getSolved :: Global -> AST Solved

74getSolved g = loc "getSolved" g $

75+ Solved False g

75− Solved g <$> getPrefix g

76+ <$> getPrefix g

76− <*> getSchema g

77+ <*> getSchema g

77− <*> getType g

78+ <*> getType g

78− <*> getDerive g

79+ <*> getDerive g

79

80

80getSchema :: Global -> AST (Schema Global)

81getSchema :: Global -> AST (Schema Global)

81getSchema g = do

82getSchema g = do

gen/src/Gen/Syntax.hs+24−7

@@ -263,14 +263,23 @@ jsonDecls g p (Map.toList -> rs) = [from, to]

263 ]

264

265 decode (l, s)

266+ | _additional s = app (var "parseJSON") (app (var "Object") (var "o"))

266 | Just x <- def s = defJS l x

267 | Just x <- def s = defJS l x

267 | required s = reqJS l

268 | required s = reqJS l

268 | monoid s = defJS l (var "mempty")

269 | monoid s = defJS l (var "mempty")

269 | otherwise = optJS l

270 | otherwise = optJS l

270

271

272+ to = case rs of

273+ [(k, v)] | _additional v ->

271− to = InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]

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]

272− [ wildcardD "toJSON" g omit none (map encode rs)

281+ [ wildcardD "toJSON" g omit none (map encode rs)

273− ]

282+ ]

274

283

275 omit = app (var "object")

284 omit = app (var "object")

276 . app (var "catMaybes")

285 . app (var "catMaybes")

@@ -420,13 +429,17 @@ externalType = \case

420 TMaybe t -> TyApp (TyCon "Maybe") (externalType t)

429 TMaybe t -> TyApp (TyCon "Maybe") (externalType t)

421 TList t -> TyList (externalType t)

430 TList t -> TyList (externalType t)

422 TLit l -> externalLit l

431 TLit l -> externalLit l

432+ TMap k v ->

433+ TyApp (TyApp (TyCon "HashMap") (externalType k)) (externalType (require v))

423

434

424internalType :: TType -> Type

435internalType :: TType -> Type

425internalType = \case

436internalType = \case

426− TType r -> tycon r

437+ TType r -> tycon r

427− TMaybe t -> TyApp (TyCon "Maybe") (internalType t)

438+ TMaybe t -> TyApp (TyCon "Maybe") (internalType t)

428− TList t -> TyList (internalType t)

439+ TList t -> TyList (internalType t)

429− TLit l -> internalLit l

440+ TLit l -> internalLit l

441+ TMap k v ->

442+ TyApp (TyApp (TyCon "HashMap") (internalType k)) (internalType (require v))

430

443

431externalLit :: Lit -> Type

444externalLit :: Lit -> Type

432externalLit = \case

445externalLit = \case

@@ -490,6 +503,10 @@ iso = \case

490 TLit DateTime -> Just (var "_DateTime")

503 TLit DateTime -> Just (var "_DateTime")

491 _ -> Nothing

504 _ -> Nothing

492

505

506+require :: TType -> TType

507+require (TMaybe t) = t

508+require t = t

509+

493strict :: Type -> Type

510strict :: Type -> Type

494strict = TyBang BangedTy . \case

511strict = TyBang BangedTy . \case

495 t@TyApp{} -> TyParen t

512 t@TyApp{} -> TyParen t

gen/src/Gen/Types.hs+13−5

@@ -269,6 +269,7 @@ data TType

269 | TLit Lit

270 | TMaybe TType

271 | TList TType

272+ | TMap TType TType

272 deriving (Eq, Show)

273 deriving (Eq, Show)

273

274

274data Derive

275data Derive

@@ -288,11 +289,12 @@ data Derive

288 deriving (Eq, Show)

289 deriving (Eq, Show)

289

290

290data Solved = Solved

291data Solved = Solved

292+ { _additional :: Bool

291− { _unique :: Global

293+ , _unique :: Global

292− , _prefix :: Prefix

294+ , _prefix :: Prefix

293− , _schema :: Schema Global

295+ , _schema :: Schema Global

294− , _type :: TType

296+ , _type :: TType

295− , _deriving :: [Derive]

297+ , _deriving :: [Derive]

296 } deriving (Show)

298 } deriving (Show)

297

299

298instance HasInfo Solved where

300instance HasInfo Solved where

@@ -303,6 +305,12 @@ instance HasInfo Solved where

303monoid :: Solved -> Bool

305monoid :: Solved -> Bool

304monoid = elem DMonoid . _deriving

306monoid = elem DMonoid . _deriving

305

307

308+setAdditional :: Solved -> Solved

309+setAdditional s = setRequired $ s

310+ { _additional = True

311+ , _type = TMap (TLit Text) (_type s)

312+ }

313+

306type Seen = Map (CI Text) {- Prefix -} (Set (CI Text)) {- Inhabitants -}

314type Seen = Map (CI Text) {- Prefix -} (Set (CI Text)) {- Inhabitants -}

307

315

308data Memo = Memo

316data Memo = Memo