@@ -1,16 +1,3 @@
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 TupleSections #-}
14-- Module : Gen.AST
1-- Module : Gen.AST
15-- Copyright : (c) 2015 Brendan Hay
2-- Copyright : (c) 2015 Brendan Hay
16-- License : Mozilla Public License, v. 2.0.
3-- License : Mozilla Public License, v. 2.0.
@@ -20,28 +7,13 @@
21module Gen.AST where
8module Gen.AST where
23−import Control.Applicative
25−import Control.Lens hiding (lens)
26import Control.Monad.Except
10import Control.Monad.Except
27import Control.Monad.State.Strict
11import Control.Monad.State.Strict
29−import qualified Data.HashMap.Strict as Map
31−import Data.Semigroup ((<>))
32−import qualified Data.Text as Text
33−import qualified Data.Text.Lazy as LText
34−import qualified Data.Text.Lazy.Builder as Build
35import Debug.Trace
12import Debug.Trace
36−import Gen.AST.Flatten (flatten)
13+import Gen.AST.Flatten (flatten)
37−import Gen.AST.Render (render)
14+import Gen.AST.Render (render)
38−import Gen.AST.Solve (solve)
15+import Gen.AST.Solve (solve)
40import Gen.Types
16import Gen.Types
42−import Language.Haskell.Exts.Build (name)
43−import Language.Haskell.Exts.Pretty
44−import Prelude hiding (sum)
46runAST :: Versions -> Service (Fix Schema) -> Either Error Library
18runAST :: Versions -> Service (Fix Schema) -> Either Error Library
47runAST v s = evalState (runExceptT go) (initial s)
19runAST v s = evalState (runExceptT go) (initial s)
@@ -50,133 +22,3 @@ runAST v s = evalState (runExceptT go) (initial s)
50 gs <- flatten s
22 gs <- flatten s
51 (api, ds) <- render =<< solve gs
23 (api, ds) <- render =<< solve gs
52 pure $! Library v gs api ds
24 pure $! Library v gs api ds
54−-- flatten :: Parsed -> AST Flattened
56−-- _ <- Map.traverseWithKey typ (_svcSchemas svc)
57−-- ps <- Map.traverseWithKey (prm "") (_svcParameters svc)
58−-- a <- api ps (_svcApi svc)
59−-- ss <- uses schemas Map.keys
60−-- pure $! svc { _svcSchemas = ss, _svcParameters = Map.elems ps, _svcApi = a }
62−-- typ :: Id -> Fix Schema -> AST Id
63−-- typ n (Fix f) = go f >>= ins n
66−-- Obj i ps -> Obj i <$> Map.traverseWithKey (prop n) ps
67−-- Arr i (Fix e) -> Arr i <$> prop n "item" (Fix (e & required .~ True))
69−-- Enum i vs ds -> pure (Enum i vs ds)
70−-- Lit i x -> pure (Lit i x)
71−-- Ref i r -> pure (Ref i r)
72−-- Any i -> pure (Any i)
74−-- prop :: Id -> Local -> Fix Schema -> AST Id
75−-- prop p l (Fix f) = go f >>= ins this
78−-- Obj i ps -> Obj i <$> Map.traverseWithKey (prop this) ps
79−-- Arr i (Fix e) -> Arr i <$> prop this "item" (Fix (e & required .~ True))
81−-- Enum i vs ds -> pure (Enum i vs ds)
82−-- Lit i x -> pure (Lit i x)
83−-- Ref i r -> pure (Ref i r)
84−-- Any i -> pure (Any i)
88−-- prm :: Id -> Local -> Param (Fix Schema) -> AST (Param Id)
90−-- n <- prop p l (_prmSchema x)
91−-- pure $! x { _prmSchema = n }
93−-- api :: Map Local (Param Id) -> Resource (Fix Schema) -> AST (Resource Id)
95−-- Top rs -> Top <$> Map.traverseWithKey sub rs
96−-- Sub ms -> Sub <$> Map.traverseWithKey (verb "") ms
99−-- Top rs -> Top <$> Map.traverseWithKey sub rs
100−-- Sub ms -> Sub <$> Map.traverseWithKey (verb l) ms
103−-- let (_, i, _) = vname (svcAbbrev svc) (_mId m)
104−-- rs <- Map.traverseWithKey (prm i) (_mParameters m)
106−-- Obj (Info (_mDescription m) Nothing False Nothing) (Map.map _prmSchema (rs <> qs))
107−-- pure $! m { _mParameters = rs <> qs }
109−-- ins :: Id -> Schema Id -> AST Id
111−-- ms <- uses schemas (Map.lookup n)
113−-- Just y | x /= y -> throwError $
114−-- format ("Schema exists: " % stext % " - " % fid %
115−-- "\nCurrent: " % shown % "\nTried: " % shown)
116−-- (_svcCanonicalName svc) n y x
117−-- _ -> schemas %= Map.insert n x
122−-- runAST :: Parsed -> Either Error Printed
123−-- runAST svc = evalState (runExceptT go) initial
128−-- solveAll x >>= render
130−-- solveAll :: Flattened -> AST Typed
132−-- ss <- traverse solve (_svcSchemas svc)
133−-- ps <- traverse (traverse solve) (_svcParameters svc)
134−-- a <- traverse solve (_svcApi svc)
135−-- pure $! svc { _svcSchemas = ss, _svcParameters = ps, _svcApi = a }
143−-- pp :: Pretty a => PP -> a -> AST Rendered
145−-- | i == Indent = result (reformat johanTibell Nothing p)
146−-- | otherwise = pure p
148−-- result = hoistEither . bimap e Build.toLazyText
150−-- e = flip mappend (", when formatting: " <> p) . LText.pack
152−-- p = LText.dropWhile isSpace
154−-- $ prettyPrintStyleMode s m x
159−-- , ribbonsPerLine = 1.5
162−-- m | i == Print = defaultMode
163−-- | i == Indent = defaultMode
164−-- | otherwise = defaultMode
165−-- { layout = PPNoLayout
169−-- -- FIXME: dirty hack to render smart ctor parameter comments.
170−-- comments :: Map Local Solved -> Rendered -> Rendered
171−-- comments (Map.toList -> rs) =
172−-- LText.replace " :: " "\n :: "
173−-- . LText.intercalate "\n -> "
176−-- . LText.splitOn "->"
178−-- ks = filter (parameter . _schema . snd) rs
179−-- ps = map (Just . fst) ks ++ repeat Nothing
182−-- rel (Just l) t = t <> " -- ^ '" <> LText.fromStrict (local l) <> "'"