@@ -0,0 +1,241 @@
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 ViewPatterns #-}
13+
14+-- Module : Gen.AST.Render
15+-- Copyright : (c) 2015 Brendan Hay
16+-- License : Mozilla Public License, v. 2.0.
17+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
18+-- Stability : provisional
19+-- Portability : non-portable (GHC extensions)
20+
21+module Gen.AST.Render
22+ ( render
23+ ) where
24+
25+import Control.Applicative
26+import Control.Error
27+import Control.Lens hiding (enum, lens)
28+import Control.Monad.Except
29+import Data.CaseInsensitive (CI)
30+import qualified Data.CaseInsensitive as CI
31+import Data.Char
32+import Data.Hashable
33+import qualified Data.HashMap.Strict as Map
34+import qualified Data.HashSet as Set
35+import Data.List (intersect)
36+import Data.Maybe
37+import Data.Semigroup ((<>))
38+import Data.Text (Text)
39+import qualified Data.Text as Text
40+import qualified Data.Text.Lazy as LText
41+import qualified Data.Text.Lazy.Builder as Build
42+import Data.Text.Manipulate
43+import Debug.Trace
44+import Gen.AST.Solve (getSolved)
45+import Gen.Formatting
46+import Gen.Syntax
47+import Gen.Text
48+import Gen.Types
49+import Gen.Types.Data
50+import HIndent
51+import Language.Haskell.Exts.Build (name)
52+import Language.Haskell.Exts.Pretty
53+import Prelude hiding (sum)
54+
55+render :: Service Solved -> AST (API, [Data])
56+render s = do
57+ a <- renderAPI s
58+ ds <- traverse renderSchema (Map.elems (s ^. dSchemas)) <&> catMaybes
59+ pure (a, ds)
60+
61+ -- FIXME: filter out action/methods types
62+-- let as = map actionTypeName (Map.elems (_apiActions y))
63+-- f d = elem (dataName d) as
64+-- z = trace (show as) $ filter (not . f) (catMaybes x)
65+
66+renderSchema :: Solved -> AST (Maybe Data)
67+renderSchema s = go (_schema s)
68+ where
69+ go = \case
70+ SEnm i e -> pure (Just (enum i e))
71+ SObj i o -> Just <$> object i o
72+ _ -> pure Nothing
73+
74+ k = _unique s
75+ p = _prefix s
76+ ds = _deriving s
77+
78+ enum i (Enm vs) = Sum (dname k) (i ^. iDescription) $
79+ map (\(v, h) -> Branch (bname p v) v h) vs
80+
81+ object i (Obj aps ps) = traverse getSolved ps >>= prod
82+ where
83+ prod ts = Prod (dname k) (i ^. iDescription)
84+ <$> pp Indent (objDecl k p ds ts)
85+ <*> ctor ts
86+ <*> traverse lens (Map.toList ts)
87+ <*> traverse (pp Print) (jsonDecls k p ts)
88+
89+ ctor ts = Fun' (cname k) (Just help)
90+ <$> (pp None (ctorSig k ts) <&> comments ts)
91+ <*> pp Indent (ctorDecl k p ts)
92+
93+ lens (l, v) = Fun' (lname p l) (v ^. iDescription)
94+ <$> pp None (lensSig k p l v)
95+ <*> pp Print (lensDecl p l v)
96+
97+ help = rawHelpText $
98+ sformat ("Creates a value of '" % gid %
99+ "' with the minimum fields required to make a request.\n")
100+ k
101+
102+renderMethod :: Service a -> Method Solved -> AST Action
103+renderMethod s m@Method {..} = do
104+ x@Solved {..} <- getSolved typ
105+ Just d <- renderSchema x
106+
107+ i <- pp Print $ requestDecl _unique _prefix alias url (props _schema) m
108+
109+ Action _mId (mkNS ns) _mDescription alias
110+ <$> pp Print (verbAlias alias m)
111+ <*> pure (insts [i] d)
112+ where
113+ (alias, typ, ns) = mname (_sCanonicalName s) _mId
114+
115+ url = name (Text.unpack (urlName s))
116+
117+ insts is = \case
118+ Prod n h r c ls _ -> Prod n h r c ls is
119+ d -> d
120+
121+ props = \case
122+ SObj _ (Obj _ ps) -> Map.keys ps
123+ _ -> mempty
124+
125+renderResource :: Service a -> Resource Solved -> AST [Action]
126+renderResource s Resource {..} =
127+ liftA2 (<>)
128+ (traverse (renderResource s) (Map.elems _rResources) <&> concat)
129+ (traverse (renderMethod s) _rMethods)
130+
131+renderAPI :: Service Solved -> AST API
132+renderAPI s = do
133+ rs <- traverse (renderResource s) (Map.elems (s ^. dResources)) <&> concat
134+ ms <- traverse (renderMethod s) (s ^. dMethods)
135+ d <- pp Print (apiAlias alias names)
136+
137+ API alias d rs ms <$> serviceURL
138+ where
139+ alias = aname (_sCanonicalName s)
140+
141+ names = map _mId (s ^. dMethods)
142+ <> Map.keys (s ^. dResources)
143+
144+ url = name (Text.unpack (urlName s))
145+
146+ serviceURL = Fun' url (Just (rawHelpText h))
147+ <$> pp None (urlSig url)
148+ <*> pp Print d
149+ where
150+ d | "http://" `Text.isPrefixOf` u = urlDecl url "Http" u 80
151+ | otherwise = urlDecl url "Https" u 443
152+
153+ u = s ^. dBaseUrl
154+
155+ h = sformat ("URL referring to version @" % stext %
156+ "@ of the " % stext % ".")
157+ (s ^. dVersion) (s ^. dTitle)
158+
159+-- api :: Resource Solved -> AST API
160+-- api x = do
161+-- as <- Map.fromList <$> top x
162+-- API n <$> pp Print (apiAlias n (Map.keys as))
163+-- <*> pure as
164+-- <*> url
165+-- where
166+-- n = name (Text.unpack (svcAbbrev svc))
167+-- un = name (Text.unpack (svcURL svc))
168+
169+-- top = \case
170+-- Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
171+-- Sub ms -> traverse (uncurry verb) (Map.toList ms)
172+
173+-- sub l = \case
174+-- Top rs -> traverse (uncurry sub) (Map.toList rs) <&> concat
175+-- Sub ms -> traverse (uncurry verb) (Map.toList ms)
176+
177+-- verb l m = do
178+-- let (k, i, ns) = vname (svcAbbrev svc) (_mId m)
179+-- s <- solve i
180+-- Just d <- typ s
181+-- fmap (k,) $
182+-- Action k (_mId m) (actionNS ns) (_mDescription m)
183+-- <$> pp Print (verbAlias k m)
184+-- <*> reset k m s d
185+
186+-- reset k m s = \case
187+-- d@Sum {} -> pure d
188+-- Prod n' h r c ls _ ->
189+-- Prod n' h r c ls . (:[]) <$> pp Print
190+-- (requestDecl (_ident s) (_prefix s) k un (fields (_schema s)) m)
191+
192+-- fields = \case
193+-- Obj _ rs -> Map.keys rs
194+-- _ -> mempty
195+
196+data PP
197+ = Indent
198+ | Print
199+ | None
200+ deriving (Eq)
201+
202+pp :: Pretty a => PP -> a -> AST Rendered
203+pp i x
204+ | i == Indent = result (reformat johanTibell Nothing p)
205+ | otherwise = pure p
206+ where
207+ result = hoistEither . bimap e Build.toLazyText
208+
209+ e = flip mappend (", when formatting: " <> p) . LText.pack
210+
211+ p = LText.dropWhile isSpace
212+ . LText.pack
213+ $ prettyPrintStyleMode s m x
214+
215+ s = style
216+ { mode = PageMode
217+ , lineLength = 80
218+ , ribbonsPerLine = 1.5
219+ }
220+
221+ m | i == Print = defaultMode
222+ | i == Indent = defaultMode
223+ | otherwise = defaultMode
224+ { layout = PPNoLayout
225+ , spacing = False
226+ }
227+
228+-- FIXME: dirty hack to render smart ctor parameter comments.
229+comments :: Map Local Solved -> Rendered -> Rendered
230+comments (Map.toList -> rs) =
231+ LText.replace " :: " "\n :: "
232+ . LText.intercalate "\n -> "
233+ . zipWith rel ps
234+ . map LText.strip
235+ . LText.splitOn "->"
236+ where
237+ ks = filter (parameter . _schema . snd) rs
238+ ps = map (Just . fst) ks ++ repeat Nothing
239+
240+ rel Nothing t = t
241+ rel (Just l) t = t <> " -- ^ '" <> LText.fromStrict (local l) <> "'"