@@ -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 #-}
13−
141-- Module : Gen.AST
152-- Copyright : (c) 2015 Brendan Hay
163-- License : Mozilla Public License, v. 2.0.
@@ -20,28 +7,13 @@
207
218module Gen.AST where
229
23−import Control.Applicative
24−import Control.Error
25−import Control.Lens hiding (lens)
2610import Control.Monad.Except
2711import Control.Monad.State.Strict
28−import Data.Char
29−import qualified Data.HashMap.Strict as Map
30−import Data.Maybe
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
3512import Debug.Trace
36−import Gen.AST.Flatten (flatten)
37−import Gen.AST.Render (render)
38−import Gen.AST.Solve (solve)
39−import Gen.Formatting
13+import Gen.AST.Flatten (flatten)
14+import Gen.AST.Render (render)
15+import Gen.AST.Solve (solve)
4016import Gen.Types
41−import HIndent
42−import Language.Haskell.Exts.Build (name)
43−import Language.Haskell.Exts.Pretty
44−import Prelude hiding (sum)
4517
4618runAST :: Versions -> Service (Fix Schema) -> Either Error Library
4719runAST v s = evalState (runExceptT go) (initial s)
@@ -50,133 +22,3 @@ runAST v s = evalState (runExceptT go) (initial s)
5022 gs <- flatten s
5123 (api, ds) <- render =<< solve gs
5224 pure $! Library v gs api ds
53−
54−-- flatten :: Parsed -> AST Flattened
55−-- flatten svc = do
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 }
61−-- where
62−-- typ :: Id -> Fix Schema -> AST Id
63−-- typ n (Fix f) = go f >>= ins n
64−-- where
65−-- go = \case
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))
68−
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)
73−
74−-- prop :: Id -> Local -> Fix Schema -> AST Id
75−-- prop p l (Fix f) = go f >>= ins this
76−-- where
77−-- go = \case
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))
80−
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)
85−
86−-- this = mkProp p l
87−
88−-- prm :: Id -> Local -> Param (Fix Schema) -> AST (Param Id)
89−-- prm p l x = do
90−-- n <- prop p l (_prmSchema x)
91−-- pure $! x { _prmSchema = n }
92−
93−-- api :: Map Local (Param Id) -> Resource (Fix Schema) -> AST (Resource Id)
94−-- api qs = \case
95−-- Top rs -> Top <$> Map.traverseWithKey sub rs
96−-- Sub ms -> Sub <$> Map.traverseWithKey (verb "") ms
97−-- where
98−-- sub l = \case
99−-- Top rs -> Top <$> Map.traverseWithKey sub rs
100−-- Sub ms -> Sub <$> Map.traverseWithKey (verb l) ms
101−
102−-- verb p l m = do
103−-- let (_, i, _) = vname (svcAbbrev svc) (_mId m)
104−-- rs <- Map.traverseWithKey (prm i) (_mParameters m)
105−-- _ <- ins i $
106−-- Obj (Info (_mDescription m) Nothing False Nothing) (Map.map _prmSchema (rs <> qs))
107−-- pure $! m { _mParameters = rs <> qs }
108−
109−-- ins :: Id -> Schema Id -> AST Id
110−-- ins n x = do
111−-- ms <- uses schemas (Map.lookup n)
112−-- case ms of
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
118−
119−-- return n
120−
121−
122−-- runAST :: Parsed -> Either Error Printed
123−-- runAST svc = evalState (runExceptT go) initial
124−-- where
125−-- go = do
126−-- x <- flatten svc
127−-- reserve x
128−-- solveAll x >>= render
129−
130−-- solveAll :: Flattened -> AST Typed
131−-- solveAll svc = do
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 }
136−
137−-- data PP
138−-- = Indent
139−-- | Print
140−-- | None
141−-- deriving (Eq)
142−
143−-- pp :: Pretty a => PP -> a -> AST Rendered
144−-- pp i x
145−-- | i == Indent = result (reformat johanTibell Nothing p)
146−-- | otherwise = pure p
147−-- where
148−-- result = hoistEither . bimap e Build.toLazyText
149−
150−-- e = flip mappend (", when formatting: " <> p) . LText.pack
151−
152−-- p = LText.dropWhile isSpace
153−-- . LText.pack
154−-- $ prettyPrintStyleMode s m x
155−
156−-- s = style
157−-- { mode = PageMode
158−-- , lineLength = 80
159−-- , ribbonsPerLine = 1.5
160−-- }
161−
162−-- m | i == Print = defaultMode
163−-- | i == Indent = defaultMode
164−-- | otherwise = defaultMode
165−-- { layout = PPNoLayout
166−-- , spacing = False
167−-- }
168−
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 -> "
174−-- . zipWith rel ps
175−-- . map LText.strip
176−-- . LText.splitOn "->"
177−-- where
178−-- ks = filter (parameter . _schema . snd) rs
179−-- ps = map (Just . fst) ks ++ repeat Nothing
180−
181−-- rel Nothing t = t
182−-- rel (Just l) t = t <> " -- ^ '" <> LText.fromStrict (local l) <> "'"