b38c700 · gogol · git.iko.soy

git.iko.soy/gogol

WIP

commitb38c700f7fa4746721c9a281425d204dd5d90e17 authorBrendan Hay <brendan.g.hay@gmail.com> dateThu 24 Sep 2015, 20:19 (11 years ago) parent24d1d6b

10 files changed+251−125

compare with develop

unifiedsplit

gen/annex/translate.json+1 gen/src/Gen/AST.hs+78−30 gen/src/Gen/Solve.hs+5−36 gen/src/Gen/Syntax.hs+34−13 gen/src/Gen/Tree.hs−1 gen/src/Gen/Types.hs+75−32 gen/src/Gen/Types/Id.hs+36−10 gen/src/Main.hs+1−2 gen/template/operation.ede gen/template/toc.ede+21−1

gen/annex/translate.json+1

@@ -1,3 +1,4 @@

11{

2+ "library": "gozen-translate"

23}

gen/src/Gen/AST.hs+78−30

@@ -42,11 +42,43 @@ import HIndent

4242import Language.Haskell.Exts.Pretty

4343import Prelude hiding (sum)

4444

45−-- mapM isn't lazy here and I don't care!

46−flatten :: Map Id (Fix Schema) -> Map Id (Schema Id)

47−flatten m = execState (mapM_ (uncurry (prop Nothing)) (Map.toList m)) mempty

45+runAST :: Versions

46+ -> [Service (Fix Schema) (Fix Schema) (Resource (Fix Schema))]

47+ -> Either Error [Library]

48+runAST v ss = merge v <$> evalState (runExceptT go) initial

4849 where

49− -- unfold the properties.

50+ go = traverse (flatten >=> render) ss

51+

52+flatten :: Service (Fix Schema) (Fix Schema) (Resource (Fix Schema))

53+ -> AST (Service (Schema Id) (Schema Id) (Resource (Schema Id)))

54+flatten svc = do

55+ mapM_ (uncurry (prop Nothing)) (Map.toList (_svcSchemas svc))

56+ ss <- gets (view schemas)

57+ ps <- Map.traverseWithKey global (_svcParameters svc)

58+ rs <- Map.traverseWithKey resource (_svcResources svc)

59+ return $! svc { _svcSchemas = ss, _svcParameters = ps, _svcResources = rs }

60+ where

61+ resource :: Id -> Resource (Fix Schema) -> AST (Resource (Schema Id))

62+ resource k (Resource ms) = Resource <$> traverse go ms

63+ where

64+ go m = do

65+ ps <- Map.traverseWithKey (local k) (_mParameters m)

66+ return $! m { _mParameters = ps }

67+

68+ global = param (Just "param")

69+ local k = param (Just k)

70+

71+ param :: Maybe Id -> Id -> Param (Fix Schema) -> AST (Param (Schema Id))

72+ param p k (Param l m f) = do

73+ n <- prop p k f

74+ s <- schema n

75+ return $! Param l m s

76+

77+ -- unfold a schema property.

78+ prop :: Maybe Id

79+ -> Id

80+ -> Fix Schema

81+ -> AST Id

5082 prop p k (Fix f) = case f of

5183 Obj i ps -> do

5284 o <- Obj i <$> Map.traverseWithKey (prop (Just this)) ps

@@ -60,41 +92,26 @@ flatten m = execState (mapM_ (uncurry (prop Nothing)) (Map.toList m)) mempty

6092 Lit i l -> res (Lit i l)

6193 Ref _ r -> pure r

6294 Any i -> res (Any i)

63−

6495 where

6596 res x = do

66− s <- gets (Map.lookup this)

97+ s <- gets (Map.lookup this . view schemas)

6798 case s of

68− Nothing -> modify (Map.insert this x) >> pure this

99+ Nothing -> (schemas %= Map.insert this x) >> pure this

69100 -- FIXME:

70101 Just e -> error $ "Already exists: " ++ show (this, e, x)

71102

72103 this = maybe k (<> k) p

73104

74−merge :: Versions -> [Service Data] -> [Library]

75−merge v = map go . groupBy (on (==) _svcLibrary)

76− where

77− go [x] = mk x

78− go (x:xs) = (mk x) { _libServices = x :| xs }

79− -- FIXME:

80− go [] = error "Empty merge set!"

81−

82− mk x = Library

83− { _libName = _svcLibrary x

84− , _libTitle = renameTitle (_svcTitle x)

85− , _libVersions = v

86− , _libServices = x :| []

87− }

88−

89−render :: Service (Fix Schema) -> Either Error (Service Data)

90−render s = runAST (Memo mempty mempty ss) $ do

91− r <- kvTraverseMaybe go ss

92− return $! s { _svcSchemas = r }

105+render :: Service (Schema Id) (Schema Id) (Resource (Schema Id))

106+ -> AST (Service Data Solved API)

107+render svc = do

108+ x <- kvTraverseMaybe typ (_svcSchemas svc)

109+ y <- Map.traverseWithKey prm (_svcParameters svc)

110+ z <- Map.traverseWithKey (api y) (_svcResources svc)

111+ return $! svc { _svcSchemas = x, _svcParameters = y, _svcResources = z }

93112 where

94− ss = flatten (_svcSchemas s)

95−

96− go :: Id -> Schema Id -> AST (Maybe Data)

97− go k = \case

113+ typ :: Id -> Schema Id -> AST (Maybe Data)

114+ typ k = \case

98115 Arr {} -> pure Nothing

99116 Ref {} -> pure Nothing

100117 Any {} -> pure Nothing

@@ -124,6 +141,37 @@ render s = runAST (Memo mempty mempty ss) $ do

124141 "' with the minimum fields required to make a request.\n")

125142 k

126143

144+Make param types lit only, and fail at json parse time?

145+Then avoid any solving/id memo steps.

146+

147+ prm :: Id -> Param (Schema Id) -> AST (Param Solved)

148+ prm r p = do

149+ let k = "param" <> r

150+ traverse (const (solve k)) p

151+

152+ api :: Map Id (Param Solved) -> Id -> Resource (Schema Id) -> AST API

153+ api cmn k (methods -> Map.toList -> ms) = do

154+ z <- Map.traverseWithKey (\n p -> traverse (const $ solve (k <> n)) p) (_mParameters y)

155+ API (aname k) <$>

156+ traverse (pp None) (apiTypes svc cmn x (y { _mParameters = z }))

157+ where

158+ (x, y) = head ms

159+

160+merge :: Versions -> [Service Data Solved API] -> [Library]

161+merge v = map go . groupBy (on (==) _svcLibrary)

162+ where

163+ go [x] = mk x

164+ go (x:xs) = (mk x) { _libServices = x :| xs }

165+ -- FIXME:

166+ go [] = error "Empty merge set!"

167+

168+ mk x = Library

169+ { _libName = _svcLibrary x

170+ , _libTitle = renameTitle (_svcTitle x)

171+ , _libVersions = v

172+ , _libServices = x :| []

173+ }

174+

127175data PP

128176 = Indent

129177 | Print

gen/src/Gen/Solve.hs+5−36

@@ -35,52 +35,21 @@ import Prelude hiding (sum)

3535-- Just use hashmaps to lookup refs etc, and hide all the mutation

3636-- behind a StateT interface.

3737

38−data TType

39− = TType Id

40− | TLit Lit

41− | TMaybe TType

42− | TEither TType TType

43− | TList TType

44−

45−data Derive

46− = DEq

47− | DOrd

48− | DRead

49− | DShow

50− | DEnum

51− | DNum

52− | DIntegral

53− | DReal

54− | DMonoid

55− | DIsString

56− | DData

57− | DTypeable

58− | DGeneric

59− deriving (Eq, Show)

60−

6138data Memo = Memo

6239 { _typed :: Map Id TType

6340 , _derived :: Map Id [Derive]

6441 , _schemas :: Map Id (Schema Id)

6542 }

6643

44+initial :: Memo

45+initial = Memo mempty mempty mempty

46+

6747makeLenses ''Memo

6848

6949type AST = ExceptT Error (State Memo)

7050

71−data Solved = Solved

72− { _schema :: Schema Id

73− , _type :: TType

74− , _deriving :: [Derive]

75− }

76−

77−instance HasInfo Solved where

78− info = f . info

79− where

80− f = lens _schema (\s a -> s { _schema = a })

81−

82−runAST :: Memo -> AST a -> Either Error a

83−runAST s m = evalState (runExceptT m) s

51+-- runAST :: AST a -> Either Error a

52+-- runAST m = evalState (runExceptT m) initial

8453

8554schema :: Id -> AST (Schema Id)

8655schema k = do

gen/src/Gen/Syntax.hs+34−13

@@ -17,6 +17,7 @@ import Control.Lens hiding (iso, mapping, op, strict)

1717import Data.Foldable (foldr')

1818import qualified Data.HashMap.Strict as Map

1919import Data.Maybe

20+import Data.Semigroup ((<>))

2021import Data.String

2122import Data.Text (Text)

2223import qualified Data.Text as Text

@@ -28,11 +29,38 @@ import Language.Haskell.Exts.Build

2829import Language.Haskell.Exts.SrcLoc

2930import Language.Haskell.Exts.Syntax hiding (Int)

3031

31−instance IsString Name where

32− fromString = name

32+instance IsString Name where fromString = name

33+instance IsString QName where fromString = UnQual . name

34+instance IsString QOp where fromString = op . sym

3335

34−instance IsString QOp where

35− fromString = op . name

36+apiTypes :: Service s p r

37+ -> Map Id (Param Solved)

38+ -> Id

39+ -> Method Solved

40+ -> [Type]

41+apiTypes s qps r m = map sing ps ++ qs ++ [end]

42+ where

43+ ps = filter (not . Text.null)

44+ $ Text.split (== '/') (_svcServicePath s)

45+ <> Text.split (== '/') (_mPath m)

46+

47+ -- FIXME: order by _mParameterOrder

48+ qs = map param (Map.toList qps)

49+ ++ map param (Map.toList (_mParameters m))

50+

51+ param (k, Param l _ t) =

52+ -- FIXME: types, many/repeated

53+ case l of

54+ Path -> TyApp (TyApp (tycon "Capture") (sing (idToText k))) (external (_type t))

55+ Query -> TyApp (TyApp (tycon "QueryParam") (sing (idToText k))) (external (_type t))

56+

57+ end = TyApp (TyApp meth typ) res

58+

59+ meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mMethod m)

60+ typ = tycon "'[JSON]"

61+ res = maybe (tycon "()") tycon (_mResponse m)

62+

63+ -- method (titlecase) '[JSON] (responsetype)

3664

3765objDecl :: Id -> Map Id Solved -> AST Decl

3866objDecl r rs = DataDecl noLoc arity [] d [] [conDecl d rs] <$> derivings r

@@ -157,19 +185,12 @@ strict = TyBang BangedTy . \case

157185 t@TyApp{} -> TyParen t

158186 t -> t

159187

160−dname, cname, fname, lname, pname :: Id -> Name

161−dname = name . ref upperHead

162−cname = name . ref (renameReserved . lowerHead)

163−fname = name . ref (Text.cons '_' . lowerHead)

164−lname = name . ref lowerHead

165−pname = name . ref (flip Text.snoc '_' . Text.cons 'p' . upperHead)

188+sing :: Text -> Type

189+sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""

166190

167191tycon :: Id -> Type

168192tycon = TyCon . unqual . ref upperHead

169193

170−ref :: (Text -> Text) -> Id -> String

171−ref f = Text.unpack . f . idToText

172−

173194unqual :: String -> QName

174195unqual = UnQual . name

175196

gen/src/Gen/Tree.hs−1

@@ -83,7 +83,6 @@ populate d Templates{..} l = (encodeString d :/) . dir lib <$> layout

8383 , file "README.md" readmeTemplate

8484 ]

8585

86− service :: Service Data -> [DirTree (Either Error Touch)]

8786 service s =

8887 [ write $ module' (tocNS s) mempty tocTemplate (pure svc)

8988 , dir (fromText (svcAbbrev s))

gen/src/Gen/Types.hs+75−32

@@ -36,7 +36,6 @@ import Data.Aeson hiding (Bool, String)

3636import Data.Aeson.TH

3737import Data.Char

3838import Data.Function (on)

39−import qualified Data.HashMap.Strict as Map

4039import Data.List.NonEmpty (NonEmpty (..))

4140import qualified Data.List.NonEmpty as NE

4241import Data.Maybe

@@ -72,11 +71,10 @@ toTextIgnore :: Path -> Text

7271toTextIgnore = either id id . Path.toText

7372

7473data Templates = Templates

75− { cabalTemplate :: Template

76− , tocTemplate :: Template

77− , readmeTemplate :: Template

78− , operationTemplate :: Template

79− , typesTemplate :: Template

74+ { cabalTemplate :: Template

75+ , tocTemplate :: Template

76+ , readmeTemplate :: Template

77+ , typesTemplate :: Template

8078 }

8179

8280newtype Version (v :: Symbol) = Version Text

@@ -127,6 +125,8 @@ specFromPath x = Spec n p v x

127125 p = toTextIgnore (Path.parent (Path.parent x))

128126 v = toTextIgnore (Path.dirname x)

129127

128+

129+

130130data Protocol = REST

131131 deriving (Eq, Show)

132132

@@ -257,11 +257,14 @@ instance HasInfo (Schema a) where

257257 Ref _ r -> Ref i r

258258 Any {} -> Any i

259259

260−data Param = Param Location -- (Fix Schema)

260+data Param a = Param !Location !Bool a

261+ deriving (Functor, Foldable, Traversable)

261262

262−instance FromJSON Param where

263− parseJSON = withObject "parameter" $ \o ->

264− Param <$> o .: "location" -- <*> parseJSON (Object o)

263+instance FromJSON a => FromJSON (Param a) where

264+ parseJSON = withObject "parameter" $ \o -> Param

265+ <$> o .: "location"

266+ <*> o .:? "repeated" .!= False

267+ <*> parseJSON (Object o)

265268

266269deriveToJSON (js "") ''Param

267270

@@ -302,27 +305,71 @@ instance ToJSON Data where

302305 , "lenses" .= ls

303306 ]

304307

305−data Method = Method

308+

309+data TType

310+ = TType Id

311+ | TLit Lit

312+ | TMaybe TType

313+ | TEither TType TType

314+ | TList TType

315+

316+data Derive

317+ = DEq

318+ | DOrd

319+ | DRead

320+ | DShow

321+ | DEnum

322+ | DNum

323+ | DIntegral

324+ | DReal

325+ | DMonoid

326+ | DIsString

327+ | DData

328+ | DTypeable

329+ | DGeneric

330+ deriving (Eq, Show)

331+

332+data Solved = Solved

333+ { _schema :: Schema Id

334+ , _type :: TType

335+ , _deriving :: [Derive]

336+ }

337+

338+instance HasInfo Solved where

339+ info = f . info

340+ where

341+ f = lens _schema (\s a -> s { _schema = a })

342+

343+deriveToJSON (js "T") ''TType

344+deriveToJSON (js "D") ''Derive

345+deriveToJSON (js "_") ''Solved

346+

347+data API = API Name [Rendered]

348+

349+instance ToJSON API where

350+ toJSON (API n d) = object ["name" .= Syn n, "types" .= d]

351+

352+data Method a = Method

306353 { _mId :: Text

307354 , _mPath :: Text

308355 , _mMethod :: Text

309− , _mDescription :: Help

310− , _mParameters :: Map Id Param

356+ , _mDescription :: Maybe Help

357+ , _mParameters :: Map Id (Param a)

311358 , _mParameterOrder :: [Id]

312359 , _mScopes :: [Text]

313360 , _mRequest :: Maybe Id

314361 , _mResponse :: Maybe Id

315362 } deriving (Generic)

316363

317−instance FromJSON Method where

364+instance FromJSON a => FromJSON (Method a) where

318365 parseJSON = withObject "method" $ \o -> Method

319366 <$> o .: "id"

320367 <*> o .: "path"

321368 <*> o .: "httpMethod"

322− <*> o .: "description"

369+ <*> o .:? "description"

323370 <*> o .: "parameters"

324371 <*> o .:? "parameterOrder" .!= mempty

325− <*> o .: "scopes"

372+ <*> o .:? "scopes" .!= mempty

326373 <*> ref o "request"

327374 <*> ref o "response"

328375 where

@@ -331,16 +378,11 @@ instance FromJSON Method where

331378

332379deriveToJSON (js "_m") ''Method

333380

334−newtype Resource = Resource { methods :: Map Id Method }

335− deriving (ToJSON)

381+newtype Resource a = Resource { methods :: Map Id (Method a) }

336382

337383deriveFromJSON (js "") ''Resource

338384

339−-- instance FromJSON Resource where

340−-- parseJSON = withObject "resource" $ \o ->

341−-- o .: "methods" -- <|> fail (show (Map.lookup "methods" o))

342−

343−data Service a = Service

385+data Service s p r = Service

344386 { _svcLibrary :: Text

345387 , _svcTitle :: Text

346388 , _svcName :: Text

@@ -358,39 +400,40 @@ data Service a = Service

358400 , _svcServicePath :: Text

359401 , _svcBatchPath :: Text

360402 , _svcAuth :: Maybe Object

361− , _svcParameters :: Map Id Param

362− , _svcSchemas :: Map Id a

363− , _svcResources :: Map Id Resource

403+ , _svcParameters :: Map Id (Param p)

404+ , _svcSchemas :: Map Id s

405+ , _svcResources :: Map Id r

364406 } deriving (Generic)

365407

366408deriveFromJSON (js "_svc") ''Service

367409

368−instance ToJSON (Service Data) where

410+instance ToJSON p => ToJSON (Service Data p API) where

369411 toJSON s = Object (x <> y)

370412 where

371413 Object x = genericToJSON (js "_svc") s

372414 Object y = object

373415 [ "exposedModules" .= exposedModules s

416+ , "api" .= Syn (aname (idFromText (_svcName s)))

374417 ]

375418

376−svcAbbrev :: Service a -> Text

419+svcAbbrev :: Service s p r -> Text

377420svcAbbrev = renameAbbrev . _svcTitle

378421

379−typeImports :: Service a -> [NS]

422+typeImports :: Service s p r -> [NS]

380423typeImports _ = ["Network.Google.Prelude"]

381424

382−tocNS, typesNS :: Service a -> NS

425+tocNS, typesNS :: Service s p r -> NS

383426tocNS s = NS ["Network", "Google", svcAbbrev s]

384427typesNS = (<> "Types") . tocNS

385428

386−exposedModules :: Service a -> [NS]

429+exposedModules :: Service s p r -> [NS]

387430exposedModules s = [tocNS s, typesNS s]

388431

389432data Library = Library

390433 { _libName :: Text

391434 , _libTitle :: Text

392435 , _libVersions :: Versions

393− , _libServices :: NonEmpty (Service Data)

436+ , _libServices :: NonEmpty (Service Data Solved API)

394437 }

395438

396439instance ToJSON Library where

gen/src/Gen/Types/Id.hs+36−10

@@ -11,34 +11,60 @@

1111

1212module Gen.Types.Id

1313 ( Id

14+

15+ -- * Conversion

1416 , idToText

1517 , idFromText

18+

19+ -- * Formatting

1620 , fid

21+ , ref

22+

23+ -- * Syntax

24+ , aname

25+ , dname

26+ , cname

27+ , fname

28+ , lname

29+ , pname

1730 ) where

1831

1932import Control.Applicative

20−import Control.Lens hiding ((.=))

21−import Data.Aeson hiding (Bool, String)

33+import Control.Lens hiding ((.=))

34+import Data.Aeson hiding (Bool, String)

2235import Data.Aeson.TH

23−import qualified Data.Attoparsec.Text as A

36+import qualified Data.Attoparsec.Text as A

2437import Data.Bifunctor

2538import Data.Char

26−import Data.Function (on)

39+import Data.Function (on)

2740import Data.Hashable

28−import qualified Data.HashMap.Strict as Map

41+import qualified Data.HashMap.Strict as Map

2942import Data.Maybe

3043import Data.Ord

31−import Data.Semigroup hiding (Sum)

44+import Data.Semigroup hiding (Sum)

3245import Data.String

33−import Data.Text (Text)

34−import qualified Data.Text as Text

35−import qualified Data.Text.Lazy as LText

36−import qualified Data.Text.Lazy.Builder as Build

46+import Data.Text (Text)

47+import qualified Data.Text as Text

48+import qualified Data.Text.Lazy as LText

49+import qualified Data.Text.Lazy.Builder as Build

3750import Data.Text.Manipulate

3851import Formatting

3952import Gen.Text

4053import Gen.Types.Map

4154import GHC.Generics

55+import Language.Haskell.Exts.Build

56+import Language.Haskell.Exts.Syntax (Name)

57+

58+aname, dname, cname, fname, lname, pname :: Id -> Name

59+aname = name . ref upperHead

60+dname = name . ref upperHead

61+cname = name . ref (renameReserved . lowerHead)

62+fname = name . ref (Text.cons '_' . lowerHead)

63+lname = name . ref lowerHead

64+pname = name . ref (flip Text.snoc '_' . Text.cons 'p' . upperHead)

65+

66+ref :: (Text -> Text) -> Id -> String

67+ref f = Text.unpack . f . idToText

4268

4369data Id

4470 = Opaque [Text]

gen/src/Main.hs+1−2

@@ -135,7 +135,6 @@ main = do

135135 <$> load "cabal.ede"

136136 <*> load "toc.ede"

137137 <*> load "readme.ede"

138− <*> load "operation.ede"

139138 <*> load "types.ede"

140139 <* lift done

141140

@@ -159,7 +158,7 @@ main = do

159158

160159 return s

161160

162− libs <- merge _optVersions <$> traverse (hoistEither . render) svcs

161+ libs <- hoistEither (runAST _optVersions svcs)

163162

164163 void . counter "library" libs $ \l -> do

165164 say ("Creating " % stext % " package.") (_libTitle l)

gen/template/operation.ededeleted

No changes to the content.

gen/template/toc.ede+21−1

@@ -6,11 +6,16 @@

66module {{ moduleName }}

77 (

88 -- * API Definition

9− {{ name | lowerHead }}

9+ {{ api }}

10+ , {{ api | lowerHead }}API

1011

1112 -- * Resources

1213 -- $resources

1314

15+ {% for resource in resources %}

16+ , {{ resource.value.name }}

17+ {% endfor %}

18+

1419 -- * Types

1520 {% for schema in schemas %}

1621 {% case schema.value.type %}

@@ -39,3 +44,18 @@ import {{ module.value }}

3944{- $resources

4045TODO

4146-}

47+

48+type {{ api }} =

49+{% for resource in resources %}

50+ {% if resource.first %} {% else %}:<|>{% endif %} {{ resource.value.name }}

51+{% endfor %}

52+

53+{{ api | lowerHead }}API :: Proxy {{ api }}

54+{{ api | lowerHead }}API = Proxy

55+{% for resource in resources %}

56+

57+type {{ resource.value.name }} =

58+ {% for type in resource.value.types %}

59+ {% if type.first %} {% else %}:>{% endif %} {{ type.value }}

60+ {% endfor %}

61+{% endfor %}