846d081 · gogol · git.iko.soy

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

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

2626import Control.Lens hiding (lens)

2727import Control.Monad.Except

2828import Control.Monad.State.Strict

29−import Data.Bifunctor

3029import Data.Char

31−import Data.Function (on)

3230import qualified Data.HashMap.Strict as Map

33−import Data.List (groupBy)

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

3531import Data.Semigroup ((<>))

32+import qualified Data.Text as Text

3633import qualified Data.Text.Lazy as LText

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

3835import Gen.Formatting

3936import Gen.Solve

4037import Gen.Syntax

41−import Gen.Text

4238import Gen.Types

4339import HIndent

4440import Language.Haskell.Exts (Name)

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

4542import Language.Haskell.Exts.Pretty

4643import Prelude hiding (sum)

4744

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

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

5451render svc = do

5552 x <- kvTraverseMaybe typ (_svcSchemas svc)

56− y <- api (_svcResources svc)

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

53+ y <- api (_svcApi svc)

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

5855 where

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

6057 typ k = \case

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

9289 k

9390

9491 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

9693 where

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

98− res p = \case

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

100− Sub ms | Just x <- p

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

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

103−

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

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

106−

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

108− sub p (n, m) = (mname p n,) <$> traverse (pp None) (apiTypes svc p 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

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

95+

96+ nouns = map nname . \case

97+ Top rs -> Map.keys rs

98+ Sub ms -> Map.keys ms

99+

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

101+ top = \case

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

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

104+

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

106+ sub l = \case

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+

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

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

114121

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

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

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

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

1515import Control.Monad.Except

1616import Control.Monad.State

1717import Data.ByteString (ByteString)

18+import qualified Data.HashMap.Strict as Map

1819import Data.Text (Text)

1920import qualified Data.Text as Text

2021import qualified Data.Text.Lazy as LText

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

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

24+import Debug.Trace

2325import qualified Filesystem as FS

2426import Filesystem.Path.CurrentOS

2527import Gen.Formatting

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

8385readTemplate :: MonadIO m

8486 => Path

8587 -> Path

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

87−readTemplate d f = do

88− let tmpl = d </> f

89− lift (readBSFile tmpl)

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

91− >>= EDE.result (throwError . LText.pack . show) 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

88+ -> ExceptT Error m EDE.Template

89+readTemplate d f =

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

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

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

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

3232import Language.Haskell.Exts.SrcLoc

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

3434

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

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

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

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

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

3738 where

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

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

53+ . filter (not . Text.null)

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

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

4156

4257 -- FIXME: order by _mParameterOrder

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

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

45−

46− param (k, p) =

47− -- FIXME: types, many/repeated

48− let t = literal (_prmLiteral p)

49− n = sing (local k)

50− in case _prmLocation p of

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

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

53−

54− end = TyApp (TyApp meth typ) res

55−

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

57− typ = tycon "'[JSON]"

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

59−

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

58+ prms :: [Type]

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

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

61+ where

62+ f (k, p) =

63+ -- FIXME: types, many/repeated

64+ let t = literal (_prmLiteral p)

65+ n = sing (local k)

66+ in case _prmLocation p of

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

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

69+

70+ verb :: Type

71+ verb = TyApp (TyApp meth typ) res

72+ where

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

74+ typ = tycon "'[JSON]"

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

6176

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

6378objDecl 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

326326 , "lenses" .= ls

327327 ]

328328

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

329+data Action = Action Name Rendered

330330

331−instance ToJSON API where

332− toJSON (API n ms) = object

333− [ "name" .= Syn n

334− , "methods" .= ms

331+instance ToJSON Action where

332+ toJSON (Action n d) = object

333+ [ "name" .= Syn n

334+ , "decl" .= d

335335 ]

336336

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+

337346data Method = Method

338347 { _mId :: Text

339348 , _mPath :: Text

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

364373deriveToJSON (js "_m") ''Method

365374

366375data Resource

367− = Parent (Map Local Resource)

368− | Sub (Map Local Method)

376+ = Top (Map Local Resource)

377+ | Sub (Map Local Method)

369378

370379instance FromJSON Resource where

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

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

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

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

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

374383

375384data Service s r = Service

376385 { _svcLibrary :: Text

377386 , _svcTitle :: Text

378387 , _svcName :: Text

379388 , _svcCanonicalName :: Maybe Text

380− , _svcDescription :: Text

389+ , _svcDescription :: Help

381390 , _svcRevision :: Maybe Text

382391 , _svcVersion :: Text

383392 , _svcOwnerName :: Text

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

392401 , _svcAuth :: Maybe Object

393402 , _svcParameters :: Map Local Param

394403 , _svcSchemas :: Map Id s

395− , _svcResources :: r

404+ , _svcApi :: r

396405 } deriving (Generic)

397406

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

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

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

425434 Object y = object

426435 [ "exposedModules" .= exposedModules s

427− , "api" .= svcAbbrev s

428436 ]

429437

430438svcAbbrev :: Service s r -> Text

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

458466

459467instance ToJSON Library where

460468 toJSON Library{..} = object

461− [ "libraryName" .= _libName

462− , "libraryTitle" .= _libTitle

463− , "libraryVersion" .= _libraryVersion _libVersions

464− , "coreVersion" .= _coreVersion _libVersions

465− , "clientVersion" .= _clientVersion _libVersions

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

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

469+ [ "libraryName" .= _libName

470+ , "libraryTitle" .= _libTitle

471+ , "libraryVersion" .= _libraryVersion _libVersions

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

473+ , "coreVersion" .= _coreVersion _libVersions

474+ , "clientVersion" .= _clientVersion _libVersions

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

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

468477 ]

469478

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

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

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

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

1212

1313module 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

3614

3715import Control.Applicative

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

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

6038import Gen.Types.Map

6139import GHC.Generics

6240import Language.Haskell.Exts.Build

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

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

6443

6544aname :: Id -> Name

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

6746

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

69−mname x y = aname $ mkProp x y

47+nname :: Local -> Name

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

49+

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

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

52+ where

53+ f = Text.unpack . upperHead . local

7054

7155dname, cname :: Id -> Name

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

gen/src/Main.hs+2−3

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

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

1919import Control.Monad.State

2020import Data.List (nub, sort)

21−import Data.Maybe

2221import Data.String

2322import Data.Text (Text)

2423import qualified Data.Text as Text

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

132131

133132 let load = readTemplate _optTemplates

134133

135− tmpl <- flip evalStateT mempty $ Templates

134+ tmpl <- Templates

136135 <$> load "cabal.ede"

137136 <*> load "toc.ede"

138137 <*> load "readme.ede"

139138 <*> load "types.ede"

140139 <*> load "prod.ede"

141140 <*> load "sum.ede"

142− <* lift done

141+ <* done

143142

144143 title "Selecting new service models..."

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

gen/template/cabal.ede+6−1

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

1414extra-source-files: README.md

1515

1616description:

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!

1823

1924source-repository head

2025 type: git

gen/template/toc.ede+13−40

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

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

66module {{ moduleName }}

77 (

8− -- * API Definition

9− {{ api }}

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

8+ -- * Resources

9+ {{ api.name }}

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

1111

12− {# -- * Resources #}

13− {# -- $resources #}

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

15−

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

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

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

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

20− {# {% endfor %} #}

21− {# {% endfor %} #}

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

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

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

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

16+ {# {% endfor %} #}

17+ {# {% endfor %} #}

2218

2319 -- * Types

2420 {% for schema in schemas %}

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

4945TODO

5046-}

5147

52−type {{ api }} = ()

53−

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 %} #}

48+{{ api.decl }}

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

7950

51+{{ action.value.decl }}

52+{% endfor %}