846d081 · gogol · git.iko.soy

git.iko.soy/gogol

on develop help sign in

Rendering API definitions using the AST

846d081Brendan Hay11 years ago

gen/src/Gen/AST.hs+32−25

compare with develop

unifiedsplit

@@ -26,22 +26,19 @@ import Control.Error

26import Control.Lens hiding (lens)

27import Control.Monad.Except

28import Control.Monad.State.Strict

29−import Data.Bifunctor

30import Data.Char

29import Data.Char

31−import Data.Function (on)

32import qualified Data.HashMap.Strict as Map

30import qualified Data.HashMap.Strict as Map

33−import Data.List (groupBy)

34−import Data.List.NonEmpty (NonEmpty (..))

35import Data.Semigroup ((<>))

31import Data.Semigroup ((<>))

32+import qualified Data.Text as Text

36import qualified Data.Text.Lazy as LText

33import qualified Data.Text.Lazy as LText

37import qualified Data.Text.Lazy.Builder as Build

34import qualified Data.Text.Lazy.Builder as Build

38import Gen.Formatting

35import Gen.Formatting

39import Gen.Solve

36import Gen.Solve

40import Gen.Syntax

37import Gen.Syntax

41−import Gen.Text

42import Gen.Types

38import Gen.Types

43import HIndent

39import HIndent

44import Language.Haskell.Exts (Name)

40import Language.Haskell.Exts (Name)

41+import Language.Haskell.Exts.Build (name)

45import Language.Haskell.Exts.Pretty

42import Language.Haskell.Exts.Pretty

46import Prelude hiding (sum)

43import Prelude hiding (sum)

@@ -53,8 +50,8 @@ runAST svc = evalState (runExceptT (render ss)) (initial (_svcSchemas ss))

53render :: Service (Schema Id) Resource -> AST (Service Data API)

50render :: Service (Schema Id) Resource -> AST (Service Data API)

54render svc = do

51render svc = do

55 x <- kvTraverseMaybe typ (_svcSchemas svc)

52 x <- kvTraverseMaybe typ (_svcSchemas svc)

56− y <- api (_svcResources svc)

53+ y <- api (_svcApi svc)

57− return $! svc { _svcSchemas = x, _svcResources = y }

54+ return $! svc { _svcSchemas = x, _svcApi = y }

58 where

55 where

59 typ :: Id -> Schema Id -> AST (Maybe Data)

56 typ :: Id -> Schema Id -> AST (Maybe Data)

60 typ k = \case

57 typ k = \case

@@ -92,25 +89,35 @@ render svc = do

92 k

89 k

94 api :: Resource -> AST API

91 api :: Resource -> AST API

95− api = fmap (API "API" . Map.fromList) . res Nothing

92+ api x = API n <$> pp Print (apiAlias n (nouns x)) <*> top x

96 where

93 where

97− res :: Maybe Id -> Resource -> AST [(Name, [Rendered])]

94+ n = name (Text.unpack (svcAbbrev svc))

98− res p = \case

95+

99− Parent rs -> traverse (parent p) (Map.toList rs) <&> concat

96+ nouns = map nname . \case

97+ Top rs -> Map.keys rs

100− Sub ms | Just x <- p

98+ Sub ms -> Map.keys ms

99+

100+ top :: Resource -> AST [Action]

101+ top = \case

101− -> traverse (sub x) (Map.toList ms)

102+ Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat

102− Sub ms -> traverse (sub "") (Map.toList ms)

103+ Sub ms -> traverse (uncurry (verb "")) (Map.toList ms)

103−

104+

104− parent :: Maybe Id -> (Local, Resource) -> AST [(Name, [Rendered])]

105+ sub :: Local -> Resource -> AST [Action]

105− parent p (n, r) = res (Just (pid p n)) r

106+ sub l = \case

106−

107+ t@(Top rs) -> do

108+ let k = nname l

109+ t <- Action k <$> pp Print (apiAlias k (nouns t))

110+ as <- traverse (uncurry sub) (Map.toList rs) <&> concat

111+ return (t : as)

112+

113+ Sub ms -> do

114+ let k = nname l

115+ t <- Action k <$> pp Print (apiAlias k (map (vname l) $ Map.keys ms))

116+ as <- traverse (uncurry (verb l)) (Map.toList ms)

117+ return (t : as)

118+

107− sub :: Id -> (Local, Method) -> AST (Name, [Rendered])

119+ verb :: Local -> Local -> Method -> AST Action

108− sub p (n, m) = (mname p n,) <$> traverse (pp None) (apiTypes svc p m)

120+ verb p l m = Action (vname p l) <$> pp Print (verbDecl svc p l m)

109−

110− -- FIXME: This breaks all naming invariants.

111− pid :: Maybe Id -> Local -> Id

112− pid Nothing = Free . Global . local

113− pid (Just p) = mkProp p

114

121

115flatten :: Service (Fix Schema) Resource -> Service (Schema Id) Resource

122flatten :: Service (Fix Schema) Resource -> Service (Schema Id) Resource

116flatten svc = svc { _svcSchemas = execState run mempty }

123flatten svc = svc { _svcSchemas = execState run mempty }

gen/src/Gen/IO.hs+6−11

@@ -15,11 +15,13 @@ import Control.Error

15import Control.Monad.Except

16import Control.Monad.State

17import Data.ByteString (ByteString)

18+import qualified Data.HashMap.Strict as Map

18import Data.Text (Text)

19import Data.Text (Text)

19import qualified Data.Text as Text

20import qualified Data.Text as Text

20import qualified Data.Text.Lazy as LText

21import qualified Data.Text.Lazy as LText

21import Data.Text.Lazy.Builder (toLazyText)

22import Data.Text.Lazy.Builder (toLazyText)

22import qualified Data.Text.Lazy.IO as LText

23import qualified Data.Text.Lazy.IO as LText

24+import Debug.Trace

23import qualified Filesystem as FS

25import qualified Filesystem as FS

24import Filesystem.Path.CurrentOS

26import Filesystem.Path.CurrentOS

25import Gen.Formatting

27import Gen.Formatting

@@ -83,14 +85,7 @@ copyDir src dst = io (FS.listDirectory src >>= mapM_ copy)

83readTemplate :: MonadIO m

85readTemplate :: MonadIO m

84 => Path

86 => Path

85 -> Path

87 -> Path

86− -> StateT (Map Text (EDE.Result EDE.Template)) (ExceptT Error m) EDE.Template

88+ -> ExceptT Error m EDE.Template

87−readTemplate d f = do

89+readTemplate d f =

88− let tmpl = d </> f

90+ liftIO (EDE.eitherParseFile (encodeString (d </> f)))

89− lift (readBSFile tmpl)

90− >>= EDE.parseWith EDE.defaultSyntax (load d) (toTextIgnore tmpl)

91− >>= EDE.result (throwError . LText.pack . show) return

91+ >>= either (throwError . LText.pack) return

92− where

93− load p o k _ = lift (readBSFile x) >>= EDE.parseWith o (load (directory x)) k

94− where

95− x | Text.null k = fromText k

96− | otherwise = p </> fromText k

gen/src/Gen/Syntax.hs+36−21

@@ -32,32 +32,47 @@ import Language.Haskell.Exts.Build

32import Language.Haskell.Exts.SrcLoc

33import Language.Haskell.Exts.Syntax hiding (Int, Lit)

35−apiTypes :: Service s r -> Id -> Method -> [Type]

35+ -- type API = :<|> ...

36−apiTypes s r m = map sing ps ++ qs ++ [end]

36+apiAlias :: Name -> [Name] -> Decl

37+apiAlias n ls = TypeDecl noLoc n [] alias

37 where

38 where

39+ alias = case map (TyCon . UnQual) ls of

40+ [] -> unit_tycon

41+ x:xs -> foldr' (\l r -> TyInfix l (UnQual (sym ":<|>")) r) x xs

42+

43+-- type Method = :> ...

44+verbDecl :: Service s r -> Local -> Local -> Method -> Decl

45+verbDecl s p l m = TypeDecl noLoc (vname p l) [] alias

46+ where

47+ alias = case path ++ prms of

48+ [] -> unit_tycon

49+ x:xs -> foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r) x xs

50+

51+ path :: [Type]

52+ path = map sing

38− ps = filter (not . Text.null)

53+ . filter (not . Text.null)

39 $ Text.split (== '/') (_svcServicePath s)

54 $ Text.split (== '/') (_svcServicePath s)

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

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

42 -- FIXME: order by _mParameterOrder

57 -- FIXME: order by _mParameterOrder

58+ prms :: [Type]

43− qs = map param (Map.toList (_svcParameters s))

59+ prms = map f (Map.toList (_svcParameters s))

44− ++ map param (Map.toList (_mParameters m))

60+ ++ map f (Map.toList (_mParameters m))

45−

61+ where

46− param (k, p) =

62+ f (k, p) =

47− -- FIXME: types, many/repeated

63+ -- FIXME: types, many/repeated

48− let t = literal (_prmLiteral p)

64+ let t = literal (_prmLiteral p)

49− n = sing (local k)

65+ n = sing (local k)

50− in case _prmLocation p of

66+ in case _prmLocation p of

51− Path -> TyApp (TyApp (tycon "Capture") n) t

67+ Path -> TyApp (TyApp (tycon "Capture") n) t

52− Query -> TyApp (TyApp (tycon "QueryParam") n) t

68+ Query -> TyApp (TyApp (tycon "QueryParam") n) t

53−

69+

70+ verb :: Type

54− end = TyApp (TyApp meth typ) res

71+ verb = TyApp (TyApp meth typ) res

55−

72+ where

56− meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mMethod m)

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

57− typ = tycon "'[JSON]"

74+ typ = tycon "'[JSON]"

58− res = maybe (tycon "()") (tycon . Free) (_mResponse m)

75+ res = maybe (tycon "()") (tycon . Free) (_mResponse m)

59−

60− -- method (titlecase) '[JSON] (responsetype)

62objDecl :: Id -> Pre -> Map Local Solved -> AST Decl

77objDecl :: Id -> Pre -> Map Local Solved -> AST Decl

63objDecl n p rs = DataDecl noLoc arity [] d [] [conDecl d p rs] <$> derivings n

78objDecl n p rs = DataDecl noLoc arity [] d [] [conDecl d p rs] <$> derivings n

gen/src/Gen/Types.hs+28−19

@@ -326,14 +326,23 @@ instance ToJSON Data where

326 , "lenses" .= ls

327 ]

328

329−data API = API Name (Map Name [Rendered])

329+data Action = Action Name Rendered

330

331−instance ToJSON API where

331+instance ToJSON Action where

332− toJSON (API n ms) = object

332+ toJSON (Action n d) = object

333− [ "name" .= Syn n

333+ [ "name" .= Syn n

334− , "methods" .= ms

334+ , "decl" .= d

335 ]

336

337+data API = API Name Rendered [Action]

338+

339+instance ToJSON API where

340+ toJSON (API n d as) = object

341+ [ "name" .= Syn n

342+ , "decl" .= d

343+ , "actions" .= as

344+ ]

345+

337data Method = Method

346data Method = Method

338 { _mId :: Text

347 { _mId :: Text

339 , _mPath :: Text

348 , _mPath :: Text

@@ -364,20 +373,20 @@ instance FromJSON Method where

364deriveToJSON (js "_m") ''Method

373deriveToJSON (js "_m") ''Method

365

374

366data Resource

375data Resource

367− = Parent (Map Local Resource)

376+ = Top (Map Local Resource)

368− | Sub (Map Local Method)

377+ | Sub (Map Local Method)

369

378

370instance FromJSON Resource where

379instance FromJSON Resource where

371 parseJSON = withObject "resource" $ \o ->

380 parseJSON = withObject "resource" $ \o ->

372− Parent <$> o .: "resources"

381+ Top <$> o .: "resources"

373− <|> Sub <$> o .: "methods"

382+ <|> Sub <$> o .: "methods"

374

383

375data Service s r = Service

384data Service s r = Service

376 { _svcLibrary :: Text

385 { _svcLibrary :: Text

377 , _svcTitle :: Text

386 , _svcTitle :: Text

378 , _svcName :: Text

387 , _svcName :: Text

379 , _svcCanonicalName :: Maybe Text

388 , _svcCanonicalName :: Maybe Text

380− , _svcDescription :: Text

389+ , _svcDescription :: Help

381 , _svcRevision :: Maybe Text

390 , _svcRevision :: Maybe Text

382 , _svcVersion :: Text

391 , _svcVersion :: Text

383 , _svcOwnerName :: Text

392 , _svcOwnerName :: Text

@@ -392,7 +401,7 @@ data Service s r = Service

392 , _svcAuth :: Maybe Object

401 , _svcAuth :: Maybe Object

393 , _svcParameters :: Map Local Param

402 , _svcParameters :: Map Local Param

394 , _svcSchemas :: Map Id s

403 , _svcSchemas :: Map Id s

395− , _svcResources :: r

404+ , _svcApi :: r

396 } deriving (Generic)

405 } deriving (Generic)

397

406

398instance FromJSON s => FromJSON (Service s Resource) where

407instance FromJSON s => FromJSON (Service s Resource) where

@@ -424,7 +433,6 @@ instance ToJSON (Service Data API) where

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

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

425 Object y = object

434 Object y = object

426 [ "exposedModules" .= exposedModules s

435 [ "exposedModules" .= exposedModules s

427− , "api" .= svcAbbrev s

428 ]

436 ]

429

437

430svcAbbrev :: Service s r -> Text

438svcAbbrev :: Service s r -> Text

@@ -458,13 +466,14 @@ data Library = Library

458

466

459instance ToJSON Library where

467instance ToJSON Library where

460 toJSON Library{..} = object

468 toJSON Library{..} = object

461− [ "libraryName" .= _libName

469+ [ "libraryName" .= _libName

462− , "libraryTitle" .= _libTitle

470+ , "libraryTitle" .= _libTitle

463− , "libraryVersion" .= _libraryVersion _libVersions

471+ , "libraryVersion" .= _libraryVersion _libVersions

472+ , "libraryDescriptions" .= map (Desc 4 . _svcDescription) (NE.toList _libServices)

464− , "coreVersion" .= _coreVersion _libVersions

473+ , "coreVersion" .= _coreVersion _libVersions

465− , "clientVersion" .= _clientVersion _libVersions

474+ , "clientVersion" .= _clientVersion _libVersions

466− , "exposedModules" .= concatMap exposedModules (NE.toList _libServices)

475+ , "exposedModules" .= concatMap exposedModules (NE.toList _libServices)

467− , "otherModules" .= concatMap otherModules (NE.toList _libServices)

476+ , "otherModules" .= concatMap otherModules (NE.toList _libServices)

468 ]

477 ]

469

478

470merge :: Versions -> [Service Data API] -> [Library]

479merge :: Versions -> [Service Data API] -> [Library]

gen/src/Gen/Types/Id.hs+8−24

@@ -11,28 +11,6 @@

11-- Portability : non-portable (GHC extensions)

13module Gen.Types.Id where

14− -- ( Id

15− -- , Pre (..)

16−

17− -- -- * Conversion

18− -- , idToText

19− -- , idFromText

20− -- , direct

21−

22− -- -- * Formatting

23− -- , fid

24− -- , ref

25− -- , pre

26−

27− -- -- * Syntax

28− -- , aname

29− -- , mname

30− -- , dname

31− -- , cname

32− -- , fname

33− -- , lname

34− -- , pname

35− -- ) where

37import Control.Applicative

15import Control.Applicative

38import Control.Lens hiding (pre, (.=))

16import Control.Lens hiding (pre, (.=))

@@ -60,13 +38,19 @@ import Gen.Text

60import Gen.Types.Map

38import Gen.Types.Map

61import GHC.Generics

39import GHC.Generics

62import Language.Haskell.Exts.Build

40import Language.Haskell.Exts.Build

41+import Language.Haskell.Exts.Pretty (prettyPrint)

63import Language.Haskell.Exts.Syntax (Name)

42import Language.Haskell.Exts.Syntax (Name)

65aname :: Id -> Name

44aname :: Id -> Name

66aname = name . Text.unpack . upperHead . idToText

45aname = name . Text.unpack . upperHead . idToText

47+nname :: Local -> Name

48+nname = name . Text.unpack . upperHead . local

49+

68−mname :: Id -> Local -> Name

50+vname :: Local -> Local -> Name

69−mname x y = aname $ mkProp x y

51+vname p l = name (f p <> f l)

52+ where

53+ f = Text.unpack . upperHead . local

71dname, cname :: Id -> Name

55dname, cname :: Id -> Name

72dname = name . Text.unpack . upperHead . idToText

56dname = name . Text.unpack . upperHead . idToText

gen/src/Main.hs+2−3

@@ -18,7 +18,6 @@ import Control.Error

18import Control.Lens hiding ((<.>))

19import Control.Monad.State

20import Data.List (nub, sort)

21−import Data.Maybe

22import Data.String

21import Data.String

23import Data.Text (Text)

22import Data.Text (Text)

24import qualified Data.Text as Text

23import qualified Data.Text as Text

@@ -132,14 +131,14 @@ main = do

132

131

133 let load = readTemplate _optTemplates

132 let load = readTemplate _optTemplates

134

133

135− tmpl <- flip evalStateT mempty $ Templates

134+ tmpl <- Templates

136 <$> load "cabal.ede"

135 <$> load "cabal.ede"

137 <*> load "toc.ede"

136 <*> load "toc.ede"

138 <*> load "readme.ede"

137 <*> load "readme.ede"

139 <*> load "types.ede"

138 <*> load "types.ede"

140 <*> load "prod.ede"

139 <*> load "prod.ede"

141 <*> load "sum.ede"

140 <*> load "sum.ede"

142− <* lift done

141+ <* done

143

142

144 title "Selecting new service models..."

143 title "Selecting new service models..."

145 say ("Found " % int % " model specifications.") (length _optModels)

144 say ("Found " % int % " model specifications.") (length _optModels)

gen/template/cabal.ede+6−1

@@ -14,7 +14,12 @@ cabal-version: >= 1.10

14extra-source-files: README.md

16description:

17− Pending

17+{% for desc in libraryDescriptions %}

18+{{ desc.value }}

19+{% endfor %}

20+ .

21+ /Warning:/ This is an experimental preview release which is still under

22+ heavy development and not intended for public consumption, caveat emptor!

19source-repository head

24source-repository head

20 type: git

25 type: git

gen/template/toc.ede+13−40

@@ -5,20 +5,16 @@

5-- /See:/ <{{ documentationLink }} {{ title }} Reference>

6module {{ moduleName }}

7 (

8− -- * API Definition

8+ -- * Resources

9− {{ api }}

9+ {{ api.name }}

10− {# , {{ api | lowerHead }} #}

10+ {# {% for act in api.actions %} #}

12− {# -- * Resources #}

13− {# -- $resources #}

14− {# {% for resource in resources %} #}

15−

16− {# -- ** {{ resource.value.name }} #}

12+ {# -- ** {{ act.value.name }} #}

17− {# , {{ resource.value.name }} #}

13+ {# , {{ act.value.name }} #}

18− {# {% for method in resource.value.methods %} #}

14+ {# {% for nv in act.value.actions %} #}

19− {# , {{ method.key }} #}

15+ {# , {{ nv.value.name }} #}

20− {# {% endfor %} #}

16+ {# {% endfor %} #}

21− {# {% endfor %} #}

17+ {# {% endfor %} #}

23 -- * Types

19 -- * Types

24 {% for schema in schemas %}

20 {% for schema in schemas %}

@@ -49,31 +45,8 @@ import {{ module.value }}

49TODO

45TODO

50-}

46-}

52−type {{ api }} = ()

48+{{ api.decl }}

53−

49+{% for action in api.actions %}

54−{{ api | lowerHead }} :: Proxy {{ api }}

55−{{ api | lowerHead }} = Proxy

56−

57−{{ resources.name }}

58−

59−

60−

61−{# type {{ api }} = #}

62−{# {% for resource in resources %} #}

63−{# {% if resource.first %} {% else %}:<|>{% endif %} {{ resource.value.name }} #}

64−{# {% endfor %} #}

65−{# {% for resource in resources %} #}

66−

67−{# type {{ resource.value.name }} = #}

68−{# {% for method in resource.value.methods %} #}

69−{# {% if !method.first %}:<|>{% else %} {% endif %} {{ method.key }} #}

70−{# {% endfor %} #}

71−{# {% for method in resource.value.methods %} #}

72−

73−{# type {{ method.key }} = #}

74−{# {% for type in method.value %} #}

75−{# {% if !type.first %}:>{% else %} {% endif %} {{ type.value }} #}

76−{# {% endfor %} #}

77−{# {% endfor %} #}

78−{# {% endfor %} #}

51+{{ action.value.decl }}

52+{% endfor %}