git.iko.soy/gogol
on develop help sign in
Adding AST traversals and flattening of fixpoint types
d59c635Brendan Hay
gen/src/Gen/AST.hsnew file+172
compare with develop
unifiedsplit
@@ -0,0 +1,172 @@
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+
13+-- Module : Gen.AST
14+-- Copyright : (c) 2015 Brendan Hay
15+-- License : Mozilla Public License, v. 2.0.
16+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
17+-- Stability : provisional
18+-- Portability : non-portable (GHC extensions)
19+
20+module Gen.AST where
21+
22+import Control.Applicative
23+import Control.Error
24+import Control.Lens
25+import Control.Monad.State
26+import Data.Aeson hiding (String)
27+import Data.Aeson.TH
28+import qualified Data.Attoparsec.Text as A
29+import Data.Char
30+import Data.Function (on)
31+import qualified Data.HashMap.Strict as Map
32+import Data.List (groupBy, intersect, nub, sort)
33+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
34+import qualified Data.List.NonEmpty as NE
35+import Data.Ord
36+import Data.Semigroup
37+import Data.Text (Text)
38+import qualified Data.Text as Text
39+import qualified Data.Text.Lazy as LText
40+import qualified Data.Text.Lazy.Builder as Build
41+import Data.Text.Manipulate
42+import qualified Filesystem.Path.CurrentOS as Path
43+import Formatting
44+import Gen.Formatting
45+import Gen.Text
46+import Gen.Types
47+import Text.EDE (Template)
48+
49+-- Just use hashmaps to lookup refs etc, and hide all the mutation
50+-- behind a StateT interface.
51+
52+data TType
53+ = TType Ref
54+ | TLit Lit
55+ | TMaybe TType
56+ | TEither TType TType
57+ | TList TType
58+
59+data Derive
60+ = DEq
61+ | DOrd
62+ | DRead
63+ | DShow
64+ | DEnum
65+ | DNum
66+ | DIntegral
67+ | DReal
68+ | DMonoid
69+ | DIsString
70+ | DData
71+ | DTypeable
72+ | DGeneric
73+ deriving (Eq)
74+
75+data Memo = Memo
76+ { _typed :: Map Ref TType
77+ , _derived :: Map Ref [Derive]
78+ , _schemas :: Map Ref (Schema Ref)
79+ }
80+
81+makeLenses ''Memo
82+
83+type AST = ExceptT Error (State Memo)
84+
85+schema :: Ref -> AST (Schema Ref)
86+schema k = do
87+ m <- gets (Map.lookup k . view schemas)
88+ case m of
89+ Nothing -> failure ("Missing Schema: " % ref) k
90+ Just v -> pure v
91+
92+memo :: Lens' Memo (Map Ref v) -> Ref -> (Schema Ref -> AST v) -> AST v
93+memo l k f = do
94+ m <- gets (Map.lookup k . view l)
95+ case m of
96+ Just x -> return x
97+ Nothing -> do
98+ x <- f =<< schema k
99+ l %= Map.insert k x
100+ return x
101+
102+typeOf :: Ref -> AST TType
103+typeOf k = memo typed k go
104+ where
105+ go = \case
106+ Obj {} -> pure (TType k)
107+ Arr _ r -> typeOf r
108+ Enum {} -> pure (TType k)
109+ Ref r -> typeOf r
110+ Any' -> pure (TEither (TLit String) (TLit Integer))
111+ Lit _ l -> pure (TLit l)
112+
113+derive :: Ref -> AST [Derive]
114+derive k = memo derived k go
115+ where
116+ go = \case
117+ Obj _ rs -> foldM props base (Map.keys rs)
118+ Arr _ r -> mappend monoid . intersect base <$> derive r
119+ Enum {} -> pure enum
120+ Ref r -> derive r
121+ Any' -> pure base
122+ Lit _ l -> pure $
123+ case l of
124+ String -> base <> [DOrd, DIsString]
125+ Boolean -> base <> enum
126+ Integer -> base <> [DNum, DIntegral, DReal] <> enum
127+
128+ props ds x = intersect ds <$> derive x
129+
130+ monoid = [DMonoid]
131+ enum = [DOrd, DEnum]
132+ base = [DEq, DRead, DShow, DData, DTypeable, DGeneric]
133+
134+-- mapM isn't lazy here and I don't care!
135+flatten :: Map Ref (Fix Schema) -> Map Ref (Schema Ref)
136+flatten m = execState (mapM_ (uncurry (prop Nothing)) (Map.toList m)) mempty
137+ where
138+ -- unfold the properties.
139+ prop p k (Fix f) = case f of
140+ Obj i ps -> do
141+ o <- Obj i <$> Map.traverseWithKey (prop (Just ref)) ps
142+ res o
143+
144+ Arr i e -> do
145+ e' <- prop Nothing ref e
146+ res (Arr i e')
147+
148+ Enum i vs ds -> res (Enum i vs ds)
149+ Lit i l -> res (Lit i l)
150+ Ref r -> res (Ref r) -- blow up if r == ref ?
151+ Any' -> res Any'
152+
153+ where
154+ res x = modify (Map.insert ref x) >> pure ref
155+
156+ ref = maybe k (<> k) p
157+
158+render :: Service (Schema Ref) -> Either Error (Service Data)
159+render s = undefined -- do
160+ -- rs <- traverse schema (_svcSchemas s)
161+ -- return $! s { _svcSchemas = rs }
162+ -- where
163+ -- schema :: Schema -> Either Error Data
164+ -- schema = \case
165+ -- Obj ->
166+ -- constructor [doc, sig, decl]
167+ -- decl
168+
169+ -- Arr -> Nothing
170+
171+
172+
gen/src/Gen/Tree.hs+1−1
@@ -86,7 +86,7 @@ populate d Templates{..} l = (encodeString d :/) . dir lib <$> layout
86 , file "README.md" readmeTemplate
86 , file "README.md" readmeTemplate
87 ]
87 ]
88
88
89− service :: Service -> [DirTree (Either Error Touch)]
89+ service :: Service Data -> [DirTree (Either Error Touch)]
90 service s =
90 service s =
91 [ write $ module' (tocNS s) mempty tocTemplate (pure svc)
91 [ write $ module' (tocNS s) mempty tocTemplate (pure svc)
92 , dir (fromText (svcAbbrev s))
92 , dir (fromText (svcAbbrev s))
gen/src/Gen/Types.hs+79−35
@@ -1,10 +1,16 @@
1−{-# LANGUAGE DataKinds #-}
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DeriveFoldable #-}
3+{-# LANGUAGE DeriveFunctor #-}
2−{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE DeriveGeneric #-}
5+{-# LANGUAGE DeriveTraversable #-}
6+{-# LANGUAGE FlexibleContexts #-}
7+{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE KindSignatures #-}
9+{-# LANGUAGE KindSignatures #-}
4−{-# LANGUAGE LambdaCase #-}
10+{-# LANGUAGE LambdaCase #-}
5−{-# LANGUAGE OverloadedStrings #-}
11+{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE RecordWildCards #-}
12+{-# LANGUAGE RecordWildCards #-}
7−{-# LANGUAGE TemplateHaskell #-}
13+{-# LANGUAGE TemplateHaskell #-}
8
14
9-- Module : Gen.Types
15-- Module : Gen.Types
10-- Copyright : (c) 2015 Brendan Hay
16-- Copyright : (c) 2015 Brendan Hay
@@ -22,8 +28,10 @@ import Control.Applicative
22import Data.Aeson hiding (String)
28import Data.Aeson hiding (String)
23import Data.Aeson.TH
29import Data.Aeson.TH
24import qualified Data.Attoparsec.Text as A
30import qualified Data.Attoparsec.Text as A
31+import Data.Bifunctor
25import Data.Char
32import Data.Char
26import Data.Function (on)
33import Data.Function (on)
34+import Data.Hashable
27import qualified Data.HashMap.Strict as Map
35import qualified Data.HashMap.Strict as Map
28import Data.List (groupBy, nub, sort)
36import Data.List (groupBy, nub, sort)
29import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
37import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
@@ -43,6 +51,8 @@ import GHC.Generics
43import GHC.TypeLits
51import GHC.TypeLits
44import Text.EDE (Template)
52import Text.EDE (Template)
45
53
54+newtype Fix f = Fix (f (Fix f))
55+
46type Map = Map.HashMap
56type Map = Map.HashMap
47type Error = LText.Text
57type Error = LText.Text
48type Rendered = LText.Text
58type Rendered = LText.Text
@@ -128,6 +138,7 @@ deriveJSON (js "") ''Location
128data Info = Info
138data Info = Info
129 { _infoDescription :: Maybe Text
139 { _infoDescription :: Maybe Text
130 , _infoDefault :: Maybe Text
140 , _infoDefault :: Maybe Text
141+ , _infoRequired :: Maybe Bool
131 } deriving (Eq, Show)
142 } deriving (Eq, Show)
132
143
133deriveJSON (js "_info") ''Info
144deriveJSON (js "_info") ''Info
@@ -135,50 +146,83 @@ deriveJSON (js "_info") ''Info
135data Lit
146data Lit
136 = String
147 = String
137 | Boolean
148 | Boolean
149+ | Integer
138 deriving (Eq, Show)
150 deriving (Eq, Show)
139
151
140deriveToJSON (js "") ''Lit
152deriveToJSON (js "") ''Lit
141
153
154+data Ref
155+ = Opaque [Text]
156+ | Direct Text
157+ deriving (Eq, Show, Generic)
158+
159+instance Semigroup Ref where
160+ a <> b = case (a, b) of
161+ (Opaque xs, Opaque ys) -> Opaque (xs <> ys)
162+ (Opaque xs, Direct y) -> Opaque (xs <> [y])
163+ (Direct x, Opaque ys) -> Opaque (x : ys)
164+ (Direct x, Direct y) -> Opaque [x, y]
165+
166+instance Hashable Ref
167+
168+instance FromJSON Ref where parseJSON = withText "ref" (pure . Direct)
169+instance ToJSON Ref where toJSON = toJSON . refToText
170+
171+instance FromJSON a => FromJSON (Map Ref a) where
172+ parseJSON = fmap (Map.fromList . map (first Direct) . Map.toList) . parseJSON
173+
174+instance ToJSON a => ToJSON (Map Ref a) where
175+ toJSON = toJSON . Map.fromList . map (first refToText) . Map.toList
176+
177+refToText :: Ref -> Text
178+refToText = \case
179+ Opaque xs -> Text.intercalate "." xs
180+ Direct n -> n
181+
182+ref :: Format a (Ref -> a)
183+ref = later (Build.fromText . refToText)
184+
142−data Schema
185+data Schema a
143− = Obj Info (Map Text Schema)
186+ = Obj Info (Map Ref a)
144− | Arr Info Schema
187+ | Arr Info a
145 | Enum Info [Text] [Text]
188 | Enum Info [Text] [Text]
146 | Lit Info Lit
189 | Lit Info Lit
147− | Ref Text
190+ | Ref Ref
148 | Any' -- String or Number
191 | Any' -- String or Number
149− deriving (Eq, Show)
192+ deriving (Eq, Show, Functor, Foldable, Traversable)
150
193
151−instance FromJSON Schema where
194+instance FromJSON (Fix Schema) where
152− parseJSON = withObject "schema" $ \o -> schema o <|> ref o
195+ parseJSON = withObject "schema" $ \o -> Fix <$> (schema o <|> ref o)
153 where
196 where
154 schema o = do
197 schema o = do
155 i <- parseJSON (Object o)
198 i <- parseJSON (Object o)
156− t <- o .: "type" -- <|> fail ("Missing 'type' in " ++ show o)
157− case t of
199+ o .: "type" >>= \case
158 "object" -> Obj i <$> o .: "properties"
200 "object" -> Obj i <$> o .: "properties"
159 "array" -> Arr i <$> o .: "items"
201 "array" -> Arr i <$> o .: "items"
160 "string" -> enum i o <|> pure (Lit i String)
202 "string" -> enum i o <|> pure (Lit i String)
161 "boolean" -> pure (Lit i Boolean)
203 "boolean" -> pure (Lit i Boolean)
162 "any" -> pure Any'
204 "any" -> pure Any'
163− _ -> fail $
205+ e -> fail $
164− "Unable to parse Schema from: '" ++ Text.unpack t ++ "'"
206+ "Unable to parse Schema from: '" ++ Text.unpack e ++ "'"
165
207
166 enum i o = Enum i <$> o .: "enum" <*> o .: "enumDescriptions"
208 enum i o = Enum i <$> o .: "enum" <*> o .: "enumDescriptions"
167−
168− ref o = Ref <$> o .: "$ref"
209+ ref o = Ref <$> o .: "$ref"
169
210
170deriveToJSON (js "") ''Schema
211deriveToJSON (js "") ''Schema
171
212
172−data Param = Param Location Schema
213+data Param a = Param Location a
173− deriving (Eq, Show)
214+ deriving (Eq, Show, Functor, Foldable, Traversable)
174
215
175−instance FromJSON Param where
216+instance FromJSON a => FromJSON (Param a) where
176 parseJSON = withObject "parameter" $ \o ->
217 parseJSON = withObject "parameter" $ \o ->
177 Param <$> o .: "location" <*> parseJSON (Object o)
218 Param <$> o .: "location" <*> parseJSON (Object o)
178
219
179deriveToJSON (js "") ''Param
220deriveToJSON (js "") ''Param
180
221
222+newtype Data = Data Rendered
223+ deriving (Eq, Show, ToJSON)
224+
181−data Service = Service
225+data Service a = Service
182 { _svcLibrary :: Text
226 { _svcLibrary :: Text
183 , _svcTitle :: Text
227 , _svcTitle :: Text
184 , _svcName :: Text
228 , _svcName :: Text
@@ -196,39 +240,39 @@ data Service = Service
196 , _svcServicePath :: Text
240 , _svcServicePath :: Text
197 , _svcBatchPath :: Text
241 , _svcBatchPath :: Text
198 , _svcAuth :: Maybe Object
242 , _svcAuth :: Maybe Object
199− , _svcParameters :: Map Text Param
243+ , _svcParameters :: Map Text (Param a)
200− , _svcSchemas :: Map Text Schema
244+ , _svcSchemas :: Map Text a
201 , _svcResources :: Object
245 , _svcResources :: Object
202− } deriving (Show, Generic)
246+ } deriving (Generic)
203
247
204deriveFromJSON (js "_svc") ''Service
248deriveFromJSON (js "_svc") ''Service
205
249
206−instance ToJSON Service where
250+instance ToJSON (Service Data) where
207 toJSON s = Object (x <> y)
251 toJSON s = Object (x <> y)
208 where
252 where
209 Object x = genericToJSON (js "_svc") s
253 Object x = genericToJSON (js "_svc") s
210 Object y = object
254 Object y = object
211− [ "exposedModules" .= exposedModules s
255+ [ "exposedModules" .= exposedModules s
212 ]
256 ]
213
257
214−svcAbbrev :: Service -> Text
258+svcAbbrev :: Service a -> Text
215svcAbbrev = renameAbbrev . _svcTitle
259svcAbbrev = renameAbbrev . _svcTitle
216
260
217−typeImports :: Service -> [NS]
261+typeImports :: Service a -> [NS]
218typeImports _ = ["Network.Google.Prelude"]
262typeImports _ = ["Network.Google.Prelude"]
219
263
220−tocNS, typesNS :: Service -> NS
264+tocNS, typesNS :: Service a -> NS
221tocNS s = NS ["Network", "Google", svcAbbrev s]
265tocNS s = NS ["Network", "Google", svcAbbrev s]
222typesNS = (<> "Types") . tocNS
266typesNS = (<> "Types") . tocNS
223
267
224−exposedModules :: Service -> [NS]
268+exposedModules :: Service a -> [NS]
225exposedModules s = [tocNS s, typesNS s]
269exposedModules s = [tocNS s, typesNS s]
226
270
227data Library = Library
271data Library = Library
228 { _libName :: Text
272 { _libName :: Text
229 , _libTitle :: Text
273 , _libTitle :: Text
230 , _libVersions :: Versions
274 , _libVersions :: Versions
231− , _libServices :: NonEmpty Service
275+ , _libServices :: NonEmpty (Service Data)
232 }
276 }
233
277
234instance ToJSON Library where
278instance ToJSON Library where
@@ -241,7 +285,7 @@ instance ToJSON Library where
241 , "exposedModules" .= concatMap exposedModules (NE.toList _libServices)
285 , "exposedModules" .= concatMap exposedModules (NE.toList _libServices)
242 ]
286 ]
243
287
244−mergeLibraries :: Versions -> [Service] -> [Library]
288+mergeLibraries :: Versions -> [Service Data] -> [Library]
245mergeLibraries v = map go . groupBy (on (==) _svcLibrary)
289mergeLibraries v = map go . groupBy (on (==) _svcLibrary)
246 where
290 where
247 go [x] = mk x
291 go [x] = mk x
gen/src/Main.hs+2−1
@@ -14,6 +14,7 @@
14
14
15module Main (main) where
15module Main (main) where
16
16
17+import Gen.AST
17import Control.Error
18import Control.Error
18import Control.Lens hiding ((<.>))
19import Control.Lens hiding ((<.>))
19import Control.Monad.State
20import Control.Monad.State
@@ -158,7 +159,7 @@ main = do
158
159
159 return s
160 return s
160
161
161− let libs = mergeLibraries _optVersions svcs
162+ libs = mergeLibraries _optVersions <$> renderSchemas svcs
162
163
163 void . counter "library" libs $ \l -> do
164 void . counter "library" libs $ \l -> do
164 say ("Creating " % stext % " package.") (_libTitle l)
165 say ("Creating " % stext % " package.") (_libTitle l)