git.iko.soy/gogol
on develop help sign in
Adding solve and flatten steps
commit1a68bfd0f2722bf175f7cf01827600df62106743 authorBrendan Hay <brendan.g.hay@gmail.com> dateTue 29 Sep 2015, 13:46 (11 years ago) parent3903e2e
6 files changed+317−282
compare with develop
unifiedsplit
gen/src/Gen/AST/Flatten.hs+35−63 gen/src/Gen/AST/Solve.hs+227 gen/src/Gen/Solve.hs−198 gen/src/Gen/Types.hs+10−6 gen/src/Gen/Types/Id.hs+2 gen/src/Gen/Types/Schema.hs+43−15
gen/src/Gen/AST/Flatten.hs+35−63
@@ -36,8 +36,6 @@ import qualified Data.Text.Lazy as LText
3636import qualified Data.Text.Lazy.Builder as Build
3737import Debug.Trace
3838import Gen.Formatting
39−-- import Gen.Solve
40−-- import Gen.Syntax
4139import Gen.Types
4240import HIndent
4341import Language.Haskell.Exts.Build (name)
@@ -46,36 +44,35 @@ import Prelude hiding (sum)
4644
4745flatten :: Service (Fix Schema) -> AST (Service Global)
4846flatten s = do
49− _ <- Map.traverseWithKey globalSchema (s ^. dSchemas)
50− ps <- Map.traverseWithKey globalParam (s ^. dParameters)
51− rs <- Map.traverseWithKey globalResource (s ^. dResources)
52− ms <- traverse method (s ^. dMethods)
53−
54− ss <- use schemas
47+ ss <- Map.traverseWithKey globalSchema (s ^. dSchemas)
48+ ps <- Map.traverseWithKey globalParam (s ^. dParameters)
49+ rs <- Map.traverseWithKey resource (s ^. dResources)
50+ ms <- traverse method (s ^. dMethods)
5551
5652 let d = (s ^. sDescription)
5753 { _dSchemas = ss
5854 , _dParameters = ps
59− , _dMethods = ms
6055 , _dResources = rs
56+ , _dMethods = ms
6157 }
6258
6359 pure $! s { _sDescription = d }
6460
65−globalSchema :: Global -> Schema (Fix Schema) -> AST Global
61+globalSchema :: Global -> Fix Schema -> AST Global
6662globalSchema g = schema g Nothing
6763
6864localSchema :: Global -> Local -> Fix Schema -> AST Global
69−localSchema g l (Fix s) = schema g (Just l) s
65+localSchema g l = schema g (Just l)
7066
71−schema :: Global -> Maybe Local -> Schema (Fix Schema) -> AST Global
72−schema g ml = go >=> insert this
67+schema :: Global -> Maybe Local -> Fix Schema -> AST Global
68+schema g ml (Fix f) = go f >>= insert this
7369 where
7470 this :: Global
7571 this = maybe g (reference g) ml
7672
7773 go :: Schema (Fix Schema) -> AST (Schema Global)
7874 go = \case
75+ SAny i a -> pure (SAny i a)
7976 SRef i r -> pure (SRef i r)
8077 SLit i l -> pure (SLit i l)
8178 SEnm i e -> pure (SEnm i e)
@@ -85,9 +82,33 @@ schema g ml = go >=> insert this
8582 array (Arr e) =
8683 Arr <$> localSchema this "item" (setRequired e)
8784
88− object (Obj ap ps) =
85+ object (Obj aps ps) =
8986 Obj Nothing <$> Map.traverseWithKey (localSchema this) ps
9087
88+globalParam :: Local -> Param (Fix Schema) -> AST (Param Global)
89+globalParam = localParam "param"
90+
91+localParam :: Global -> Local -> Param (Fix Schema) -> AST (Param Global)
92+localParam g l p = do
93+ x <- localSchema g l (_pParam p)
94+ pure $! p { _pParam = x }
95+
96+resource :: Global
97+ -> Resource (Fix Schema)
98+ -> AST (Resource Global)
99+resource g r = do
100+ rs <- Map.traverseWithKey (\l -> resource (reference g l)) (_rResources r)
101+ ms <- traverse method (_rMethods r)
102+ pure $! r
103+ { _rResources = rs
104+ , _rMethods = ms
105+ }
106+
107+method :: Method (Fix Schema) -> AST (Method Global)
108+method m = do
109+ ps <- Map.traverseWithKey (localParam (_mId m)) (_mParameters m)
110+ pure $! m { _mParameters = ps }
111+
91112setRequired :: Fix Schema -> Fix Schema
92113setRequired (Fix e) = Fix (e & iRequired .~ True)
93114
@@ -105,52 +126,3 @@ insert g s = do
105126 format ("Schema exists: " % stext % " - " % gid %
106127 "\nCurrent: " % shown % "\nTried: " % shown)
107128 n g x s
108−
109−globalParam :: Local -> Param (Fix Schema) -> AST (Param Global)
110−globalParam = localParam "param"
111−
112−localParam :: Global -> Local -> Param (Fix Schema) -> AST (Param Global)
113−localParam g l p = do
114− x <- localSchema g l (_pParam p)
115− pure $! p { _pParam = x }
116−
117−globalResource :: Global
118− -> Resource Global (Fix Schema)
119− -> AST (Resource Global Global)
120−globalResource = undefined
121−
122−localResource :: Global
123− -> Resource Local (Fix Schema)
124− -> AST (Resource Local Global)
125−localResource = undefined
126−
127−method :: Method (Fix Schema) -> AST (Method Global)
128−method = undefined
129−
130−-- api :: Map Local (Param Id) -> Resource (Fix Schema) -> AST (Resource Id)
131−-- api qs = \case
132−-- Top rs -> Top <$> Map.traverseWithKey sub rs
133−-- Sub ms -> Sub <$> Map.traverseWithKey (verb "") ms
134−-- where
135−-- sub l = \case
136−-- Top rs -> Top <$> Map.traverseWithKey sub rs
137−-- Sub ms -> Sub <$> Map.traverseWithKey (verb l) ms
138−
139−-- verb p l m = do
140−-- let (_, i, _) = vname (svcAbbrev svc) (_mId m)
141−-- rs <- Map.traverseWithKey (prm i) (_mParameters m)
142−-- _ <- ins i $
143−-- Obj (Info (_mDescription m) Nothing False Nothing) (Map.map _prmSchema (rs <> qs))
144−-- pure $! m { _mParameters = rs <> qs }
145−
146−-- ins :: Id -> Schema Id -> AST Id
147−-- ins n x = do
148−-- ms <- uses schemas (Map.lookup n)
149−-- case ms of
150−-- Just y | x /= y -> throwError $
151−-- format ("Schema exists: " % stext % " - " % fid %
152−-- "\nCurrent: " % shown % "\nTried: " % shown)
153−-- (_svcCanonicalName svc) n y x
154−-- _ -> schemas %= Map.insert n x
155−
156−-- return n
gen/src/Gen/AST/Solve.hsnew file+227
@@ -0,0 +1,227 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE KindSignatures #-}
7+{-# LANGUAGE LambdaCase #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE RecordWildCards #-}
11+{-# LANGUAGE TemplateHaskell #-}
12+{-# LANGUAGE ViewPatterns #-}
13+
14+-- Module : Gen.AST.Solve
15+-- Copyright : (c) 2015 Brendan Hay
16+-- License : Mozilla Public License, v. 2.0.
17+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
18+-- Stability : provisional
19+-- Portability : non-portable (GHC extensions)
20+
21+module Gen.AST.Solve
22+ ( solve
23+ ) where
24+
25+import Control.Applicative
26+import Control.Error
27+import Control.Lens hiding (enum)
28+import Control.Monad.Except
29+import Data.CaseInsensitive (CI)
30+import qualified Data.CaseInsensitive as CI
31+import Data.Hashable
32+import qualified Data.HashMap.Strict as Map
33+import qualified Data.HashSet as Set
34+import Data.List (intersect)
35+import Data.Maybe
36+import Data.Semigroup ((<>))
37+import Data.Text (Text)
38+import qualified Data.Text as Text
39+import Data.Text.Manipulate
40+import Debug.Trace
41+import Gen.Formatting
42+import Gen.Text
43+import Gen.Types
44+import Prelude hiding (sum)
45+
46+solve :: Service Global -> AST (Service Solved)
47+solve s = do
48+ ss <- Map.traverseWithKey (const . getSolved) (s ^. dSchemas)
49+ ps <- traverse param (s ^. dParameters)
50+ rs <- traverse resource (s ^. dResources)
51+ ms <- traverse method (s ^. dMethods)
52+
53+ let d = (s ^. sDescription)
54+ { _dSchemas = ss
55+ , _dParameters = ps
56+ , _dResources = rs
57+ , _dMethods = ms
58+ }
59+
60+ pure $! s { _sDescription = d }
61+
62+param :: Param Global -> AST (Param Solved)
63+param = traverse getSolved
64+
65+resource :: Resource Global -> AST (Resource Solved)
66+resource = traverse getSolved
67+
68+method :: Method Global -> AST (Method Solved)
69+method = traverse getSolved
70+
71+getSolved :: Global -> AST Solved
72+getSolved g = loc "getSolved" g $
73+ Solved g <$> getPrefix g
74+ <*> getSchema g
75+ <*> getType g
76+ <*> getDerive g
77+
78+getSchema :: Global -> AST (Schema Global)
79+getSchema g = do
80+ m <- uses schemas (Map.lookup g)
81+ case m of
82+ Nothing -> failure ("Missing Schema: " % gid) g
83+ Just x -> pure x
84+
85+getType :: Global -> AST TType
86+getType g = loc "getType" g $ memo typed g go
87+ where
88+ go s = fmap (may s) $
89+ case s of
90+ SAny {} -> pure (TType "JSON")
91+ SRef _ r -> getType (ref r)
92+ SLit _ l -> pure (TLit l)
93+ SEnm {} -> pure (TType g)
94+ SArr _ (Arr e) -> TList <$> getType e
95+ SObj {} -> pure (TType g)
96+
97+ may s | required s = id
98+ | defaulted s = id
99+ | otherwise = TMaybe
100+
101+getDerive :: Global -> AST [Derive]
102+getDerive g = loc "getDerive" g $ memo derived g go
103+ where
104+ go = \case
105+ SAny {} -> pure base
106+ SRef {} -> pure base
107+ SLit _ l -> pure (literal l)
108+ SEnm {} -> pure enum
109+ SArr _ (Arr e) -> mappend list . intersect base <$> getDerive e
110+ SObj _ (Obj _ ps) -> foldM props base (Map.elems ps)
111+
112+ literal = \case
113+ Text -> base <> [DOrd, DIsString]
114+ Bool -> enum
115+ Time -> base
116+ Date -> base
117+ _ -> [DNum, DIntegral, DReal] <> enum
118+
119+ props ds x = intersect ds <$> getDerive x
120+
121+ list = [DMonoid]
122+ enum = [DOrd, DEnum] <> base
123+ base = [DEq, DRead, DShow, DData, DTypeable, DGeneric]
124+
125+getPrefix :: Global -> AST Prefix
126+getPrefix g = loc "getPrefix" g $ memo prefixed g go
127+ where
128+ go = \case
129+ SObj _ (Obj _ ps) -> field ps
130+ SEnm _ (Enm vs) -> branch (map fst vs)
131+ _ -> pure mempty
132+
133+ field rs = do
134+ let ls = Map.keys rs
135+ ks = Set.fromList (map (CI.mk . local) ls)
136+ p <- uniq fields (acronymPrefixes g) ks
137+ pure (Prefix p)
138+
139+ branch vs = do
140+ p <- uniq branches ("" : acronymPrefixes g) $
141+ Set.fromList (map CI.mk vs)
142+ pure (Prefix p)
143+
144+ uniq :: Lens' Memo Seen
145+ -> [CI Text]
146+ -> Set (CI Text)
147+ -> AST Text
148+ uniq seen [] ks = do
149+ s <- use seen
150+ let hs = acronymPrefixes g
151+ f x = sformat ("\n" % stext % " => " % shown)
152+ (CI.foldedCase x) (Map.lookup x s)
153+ throwError $
154+ format ("Error prefixing: " % gid %
155+ "\n Fields: " % shown %
156+ "\n Matches: " % stext)
157+ g (Set.toList ks) (foldMap f hs)
158+
159+ uniq seen (x:xs) ks = do
160+ m <- uses seen (Map.lookup x)
161+ case m of
162+ Just ys | overlap ys ks
163+ -> uniq seen xs ks
164+ _ -> do
165+ seen %= Map.insertWith (<>) x ks
166+ return (CI.foldedCase x)
167+
168+overlap :: (Eq a, Hashable a) => Set a -> Set a -> Bool
169+overlap xs ys = not . Set.null $ Set.intersection xs ys
170+
171+acronymPrefixes :: Global -> [CI Text]
172+acronymPrefixes (global -> g) = map CI.mk (xs ++ map suffix ys ++ zs)
173+ where
174+ -- Take the next char
175+ suffix x = Text.snoc x c
176+ where
177+ c | Text.length x >= 2 = Text.head (Text.drop 1 x)
178+ | otherwise = Text.head x
179+
180+ zs = zipWith (\n x -> Text.snoc x (head (show n))) ([1..] :: [Int]) xs
181+
182+ xs = catMaybes [r1, r2, r3, r4, r5, r6]
183+ ys = catMaybes [r1, r2, r3, r4, r6]
184+
185+ a = camelAcronym g
186+ a' = upperAcronym g
187+
188+ limit = 3
189+
190+ -- Full name if leq limit
191+ r1 | Text.length g <= limit = Just g
192+ | otherwise = Nothing
193+
194+ -- VpcPeeringInfo -> VPI
195+ r2 = toAcronym a
196+
197+ -- VpcPeeringInfo -> VPCPI
198+ r3 | x /= r2 = x
199+ | otherwise = Nothing
200+ where
201+ x = toAcronym a'
202+
203+ -- SomeTestTType -> S
204+ r4 = Text.toUpper <$> safeHead g
205+
206+ -- SomeTypes -> STS (retain pural)
207+ r5 | Text.isSuffixOf "s" g = flip Text.snoc 's' <$> (r2 <|> r3)
208+ | otherwise = Nothing
209+
210+ -- SomeTestTType -> Som
211+ r6 = Text.take limit <$> listToMaybe (splitWords a)
212+
213+loc :: String -> Global -> a -> a
214+loc _ _ = id --trace (n ++ ": " ++ Text.unpack (idToText g))
215+
216+memo :: Lens' Memo (Map Global a)
217+ -> Global
218+ -> (Schema Global -> AST a)
219+ -> AST a
220+memo l g f = do
221+ m <- uses l (Map.lookup g)
222+ case m of
223+ Just x -> pure x
224+ Nothing -> do
225+ x <- f =<< getSchema g
226+ l %= Map.insert g x
227+ pure x
gen/src/Gen/Solve.hsdeleted−198
@@ -1,198 +0,0 @@
1−{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE DeriveGeneric #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE KindSignatures #-}
7−{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE OverloadedStrings #-}
9−{-# LANGUAGE RankNTypes #-}
10−{-# LANGUAGE RecordWildCards #-}
11−{-# LANGUAGE TemplateHaskell #-}
12−{-# LANGUAGE ViewPatterns #-}
13−
14−-- Module : Gen.Solve
15−-- Copyright : (c) 2015 Brendan Hay
16−-- License : Mozilla Public License, v. 2.0.
17−-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
18−-- Stability : provisional
19−-- Portability : non-portable (GHC extensions)
20−
21−module Gen.Solve where
22−
23−import Control.Applicative
24−import Control.Error
25−import Control.Lens hiding (enum)
26−import Control.Monad.Except
27−import Control.Monad.State.Strict
28−import Data.CaseInsensitive (CI)
29−import qualified Data.CaseInsensitive as CI
30−import Data.Hashable
31−import qualified Data.HashMap.Strict as Map
32−import qualified Data.HashSet as Set
33−import Data.List (intersect)
34−import Data.Maybe
35−import Data.Semigroup ((<>))
36−import Data.Text (Text)
37−import qualified Data.Text as Text
38−import Data.Text.Manipulate
39−import Debug.Trace
40−import Gen.Formatting
41−import Gen.Text
42−import Gen.Types
43−import Prelude hiding (sum)
44−
45−-- reserve :: Flattened -> AST ()
46−-- reserve svc = do
47−-- let bs = Set.fromList $ map (CI.mk . idToText) (_svcSchemas svc)
48−-- branches %= Map.insert mempty bs
49−
50−schema :: Id -> AST (Schema Id)
51−schema k = do
52− m <- uses schemas (Map.lookup k)
53− case m of
54− Nothing -> failure ("Missing Schema: " % fid) k
55− Just v -> pure v
56−
57−memo :: Lens' Memo (Map Id v) -> Id -> (Schema Id -> AST v) -> AST v
58−memo l k f = do
59− m <- uses l (Map.lookup k)
60− case m of
61− Just x -> return x
62− Nothing -> do
63− x <- f =<< schema k
64− l %= Map.insert k x
65− return x
66−
67−solve :: Id -> AST Solved
68−solve k = loc "solve" k $ Solved k <$> prefix k <*> schema k <*> typeOf k <*> derive k
69−
70−typeOf :: Id -> AST TType
71−typeOf k = loc "typeof" k $ memo typed k go
72− where
73− go s = fmap may $ case s of
74− Obj {} -> pure (TType k)
75− Arr _ r -> TList <$> typeOf r
76− Enum {} -> pure (TType k)
77− Ref _ r -> typeOf (Free r)
78− Any {} -> pure (TEither (TLit Text) (TLit Int64))
79− Lit _ l -> pure (TLit l)
80− where
81− may | s ^. required = id
82− | isJust (s ^. defaulted) = id
83− | otherwise = TMaybe
84−
85−derive :: Id -> AST [Derive]
86−derive k = loc "derive" k $ memo derived k go
87− where
88− go = \case
89− Obj _ rs -> foldM props dbase (Map.elems rs)
90− Arr _ r -> mappend dmonoid . intersect dbase <$> derive r
91− Enum {} -> pure denum
92− Ref _ r -> pure dbase
93− Any _ -> pure dbase
94− Lit _ l -> pure $
95− case l of
96− Text -> dbase <> [DOrd, DIsString]
97− Bool -> denum
98− Time -> dbase
99− Date -> dbase
100− Nat -> dbase
101− _ -> [DNum, DIntegral, DReal] <> denum
102−
103− props ds x = intersect ds <$> derive x
104−
105−dmonoid = [DMonoid]
106−denum = [DOrd, DEnum] <> dbase
107−dbase = [DEq, DRead, DShow, DData, DTypeable, DGeneric]
108−
109−prefix :: Id -> AST Pre
110−prefix n = loc "prefix" n $ memo prefixed n typ
111− where
112− typ = \case
113− Obj _ rs -> field rs
114− Enum _ vs _ -> branch vs
115− _ -> pure mempty
116−
117− branch vs = do
118− p <- uniq branches ("" : acronymPrefixes n) $
119− Set.fromList (map CI.mk vs)
120− pure (Pre p)
121−
122− field rs = do
123− let ls = Map.keys rs
124− ks = Set.fromList (map (CI.mk . local) ls)
125− p <- uniq fields (acronymPrefixes n) ks
126− pure (Pre p)
127−
128− uniq :: Lens' Memo Seen
129− -> [CI Text]
130− -> Set (CI Text)
131− -> AST Text
132− uniq seen [] ks = do
133− s <- use seen
134− let hs = acronymPrefixes n
135− f x = sformat ("\n" % stext % " => " % shown)
136− (CI.foldedCase x) (Map.lookup x s)
137− throwError $
138− format ("Error prefixing: " % fid %
139− "\n Fields: " % shown %
140− "\n Matches: " % stext)
141− n (Set.toList ks) (foldMap f hs)
142−
143− uniq seen (x:xs) ks = do
144− m <- uses seen (Map.lookup x)
145− case m of
146− Just ys | overlap ys ks
147− -> uniq seen xs ks
148− _ -> do
149− seen %= Map.insertWith (<>) x ks
150− return (CI.foldedCase x)
151−
152−overlap :: (Eq a, Hashable a) => Set a -> Set a -> Bool
153−overlap xs ys = not . Set.null $ Set.intersection xs ys
154−
155−acronymPrefixes :: Id -> [CI Text]
156−acronymPrefixes (idToText -> n) = map CI.mk (xs ++ map suffix ys ++ zs)
157− where
158− -- Take the next char
159− suffix x = Text.snoc x c
160− where
161− c | Text.length x >= 2 = Text.head (Text.drop 1 x)
162− | otherwise = Text.head x
163−
164− zs = zipWith (\n x -> Text.snoc x (head (show n))) ([1..] :: [Int]) xs
165−
166− xs = catMaybes [r1, r2, r3, r4, r5, r6]
167− ys = catMaybes [r1, r2, r3, r4, r6]
168−
169− a = camelAcronym n
170− a' = upperAcronym n
171−
172− limit = 3
173−
174− -- Full name if leq limit
175− r1 | Text.length n <= limit = Just n
176− | otherwise = Nothing
177−
178− -- VpcPeeringInfo -> VPI
179− r2 = toAcronym a
180−
181− -- VpcPeeringInfo -> VPCPI
182− r3 | x /= r2 = x
183− | otherwise = Nothing
184− where
185− x = toAcronym a'
186−
187− -- SomeTestTType -> S
188− r4 = Text.toUpper <$> safeHead n
189−
190− -- SomeTypes -> STS (retain pural)
191− r5 | Text.isSuffixOf "s" n = flip Text.snoc 's' <$> (r2 <|> r3)
192− | otherwise = Nothing
193−
194− -- SomeTestTType -> Som
195− r6 = Text.take limit <$> listToMaybe (splitWords a)
196−
197−loc :: String -> Id -> a -> a
198−loc n r = id --trace (n ++ ": " ++ Text.unpack (idToText r))
gen/src/Gen/Types.hs+10−6
@@ -210,11 +210,10 @@ instance ToJSON Library where
210210
211211
212212data TType
213− = TType Global
214− | TLit Lit
215− | TMaybe TType
216− | TEither TType TType
217− | TList TType
213+ = TType Global
214+ | TLit Lit
215+ | TMaybe TType
216+ | TList TType
218217
219218data Derive
220219 = DEq
@@ -233,7 +232,7 @@ data Derive
233232 deriving (Eq, Show)
234233
235234data Solved = Solved
236− { _ident :: Global
235+ { _unique :: Global
237236 , _prefix :: Prefix
238237 , _schema :: Schema Global
239238 , _type :: TType
@@ -263,6 +262,11 @@ data Memo = Memo
263262initial :: Service (Fix Schema) -> Memo
264263initial s = Memo s mempty mempty mempty mempty mempty mempty
265264
265+-- reserve :: Flattened -> AST ()
266+-- reserve svc = do
267+-- let bs = Set.fromList $ map (CI.mk . idToText) (_svcSchemas svc)
268+-- branches %= Map.insert mempty bs
269+
266270makeLenses ''Memo
267271
268272instance HasService Memo (Fix Schema) where
gen/src/Gen/Types/Id.hs+2
@@ -14,7 +14,9 @@
1414module Gen.Types.Id
1515 ( Prefix (..)
1616 , Global
17+ , global
1718 , Local
19+ , local
1820 , gid
1921 , lid
2022 , reference
gen/src/Gen/Types/Schema.hs+43−15
@@ -26,10 +26,12 @@ module Gen.Types.Schema where
2626
2727import Control.Applicative
2828import Control.Lens hiding ((.=))
29+import Control.Monad
2930import Data.Aeson hiding (Array, Bool, Object,
3031 String)
3132import qualified Data.Aeson as A
3233import Data.Aeson.TH
34+import Data.Aeson.Types (Parser)
3335import Data.Char
3436import Data.Function (on)
3537import Data.Hashable
@@ -106,8 +108,14 @@ instance FromJSON Info where
106108 <*> o .:? "repeated" .!= False
107109 <*> o .:? "annotations" .!= mempty
108110
111+defaulted, required, parameter :: HasInfo a => a -> Bool
112+defaulted = isJust . view iDefault
113+required = view iRequired
114+parameter s = required s && not (defaulted s)
115+
109116data Schema a
110− = SRef Info Ref
117+ = SAny Info Any
118+ | SRef Info Ref
111119 | SLit Info Lit
112120 | SEnm Info Enm
113121 | SArr Info (Arr a)
@@ -118,6 +126,7 @@ instance FromJSON a => FromJSON (Schema a) where
118126 parseJSON o = do
119127 i <- parseJSON o
120128 SRef i <$> parseJSON o
129+ <|> SAny i <$> parseJSON o
121130 <|> SLit i <$> parseJSON o
122131 <|> SEnm i <$> parseJSON o
123132 <|> SArr i <$> parseJSON o
@@ -140,6 +149,18 @@ instance HasInfo (Schema a) where
140149 SArr _ x -> SArr i x
141150 SObj _ x -> SObj i x
142151
152+checkType :: Text -> A.Object -> Parser ()
153+checkType x o = do
154+ y <- o .: "type"
155+ unless (x == y) . fail . Text.unpack $
156+ "Schema type mismatch, expected " <> x <> ", but got " <> y
157+
158+data Any = Any
159+ deriving (Eq, Show)
160+
161+instance FromJSON Any where
162+ parseJSON = withObject "any" (\o -> Any <$ checkType "any" o)
163+
143164newtype Ref = Ref { ref :: Global }
144165 deriving (Eq, Show)
145166
@@ -187,6 +208,7 @@ newtype Enm = Enm { _eValues :: [(Text, Help)] }
187208
188209instance FromJSON Enm where
189210 parseJSON = withObject "enum" $ \o -> do
211+ checkType "string" o
190212 vs <- o .: "enum"
191213 ds <- o .: "enumDescriptions"
192214 pure $! Enm (zip vs (ds ++ repeat mempty))
@@ -195,19 +217,25 @@ newtype Arr a = Arr { _aItem :: a }
195217 deriving (Eq, Show)
196218
197219instance FromJSON a => FromJSON (Arr a) where
198− parseJSON = withObject "array" (fmap Arr . (.: "item"))
220+ parseJSON = withObject "array" $ \o -> do
221+ checkType "array" o
222+ Arr <$> o .: "item"
199223
200224data Obj a = Obj
201− { _oAdditionalProperties :: Maybe a
202− , _oProperties :: Map Local a
225+ { _oAdditional :: Maybe a
226+ , _oProperties :: Map Local a
203227 } deriving (Eq, Show)
204228
205−deriveFromJSON options ''Obj
229+instance FromJSON a => FromJSON (Obj a) where
230+ parseJSON = withObject "object" $ \o -> do
231+ checkType "object" o
232+ Obj <$> o .:? "additionalProperties"
233+ <*> o .:? "properties" .!= mempty
206234
207235data Param a = Param
208236 { _pLocation :: Location
209237 , _pParam :: a
210− } deriving (Eq, Show)
238+ } deriving (Eq, Show, Functor, Foldable, Traversable)
211239
212240makeLenses ''Param
213241
@@ -247,7 +275,7 @@ data Method a = Method
247275 , _mSupportsMediaDownload :: Bool
248276 , _mMediaUpload :: Maybe MediaUpload
249277 , _mSupportsSubscription :: Bool
250− } deriving (Eq, Show)
278+ } deriving (Eq, Show, Functor, Foldable, Traversable)
251279
252280instance FromJSON a => FromJSON (Method a) where
253281 parseJSON = withObject "method" $ \o -> Method
@@ -265,12 +293,12 @@ instance FromJSON a => FromJSON (Method a) where
265293 <*> o .:? "mediaUpload"
266294 <*> o .:? "supportsSubscription" .!= False
267295
268−data Resource a b = Resource
269− { _rResources :: Map a (Resource Local b)
270− , _rMethods :: [Method b]
271− } deriving (Eq, Show)
296+data Resource a = Resource
297+ { _rResources :: Map Local (Resource a)
298+ , _rMethods :: [Method a]
299+ } deriving (Eq, Show, Functor, Foldable, Traversable)
272300
273−instance (TextKey a, FromJSON a, FromJSON b) => FromJSON (Resource a b) where
301+instance FromJSON a => FromJSON (Resource a) where
274302 parseJSON = withObject "resource" $ \o -> Resource
275303 <$> o .:? "resources" .!= mempty
276304 <*> (o .:? "methods" .!= mempty <&> keyless)
@@ -300,11 +328,11 @@ data Description a = Description
300328 , _dRootUrl :: Text
301329 , _dServicePath :: Text
302330 , _dBatchPath :: Text
303− , _dParameters :: Map Local (Param a)
331+ , _dParameters :: Map Local (Param a)
304332 , _dAuth :: OAuth2
305333 , _dFeatures :: [Text]
306− , _dSchemas :: Map Global (Schema a)
307− , _dResources :: Map Global (Resource Global a)
334+ , _dSchemas :: Map Global a
335+ , _dResources :: Map Global (Resource a)
308336 , _dMethods :: [Method a]
309337 } deriving (Eq, Show)
310338