git.iko.soy/gogol
on develop help sign in
Upgraded gogol-gen to work with lts-13 (ghc-8.6.3)
commit944435cafb02374e300579f1d8f339597630497c authorKoray Al <koray.al@soostone.com.tr> dateTue 12 Feb 2019, 13:44 (8 years ago) parentb866269
13 files changed+324−284
compare with develop
unifiedsplit
gen/gogol-gen.cabal+3−3 gen/src/Gen/AST/Render.hs+14−8 gen/src/Gen/IO.hs+2−2 gen/src/Gen/Orphans.hs+4−4 gen/src/Gen/Syntax.hs+258−233 gen/src/Gen/Text.hs−1 gen/src/Gen/Types/Data.hs+7−7 gen/src/Gen/Types/Help.hs+8−6 gen/src/Gen/Types/Id.hs+15−13 gen/src/Gen/Types/NS.hs−1 gen/src/Gen/Types/Schema.hs+3 gen/stack.yaml+9−5 stack-8.6.3.yaml+1−1
gen/gogol-gen.cabal+3−3
@@ -55,12 +55,12 @@ executable gogol-gen
5555 , errors >= 2.1.2
5656 , formatting
5757 , hashable
58− , haskell-src-exts == 1.17.1
59− , hindent == 4.6.4
58+ , haskell-src-exts == 1.20.3
59+ , hindent == 5.2.7
6060 , lens
6161 , mtl
6262 , optparse-applicative
63− , pandoc < 2.0
63+ , pandoc
6464 , parsec
6565 , semigroups
6666 , system-fileio
gen/src/Gen/AST/Render.hs+14−8
@@ -25,18 +25,21 @@ module Gen.AST.Render
2525import Control.Applicative
2626import Control.Error
2727import Control.Lens hiding (enum, lens)
28+import qualified Data.ByteString.Char8 as C8
29+import qualified Data.ByteString.Lazy.Char8 as LBS
30+import qualified Data.ByteString.Lazy.Builder as LBB
2831import Data.Char (isSpace)
2932import qualified Data.HashMap.Strict as Map
3033import Data.Maybe
3134import Data.Semigroup ((<>))
3235import Data.String
3336import qualified Data.Text.Lazy as LText
34−import qualified Data.Text.Lazy.Builder as Build
3537import Gen.AST.Solve (getSolved)
3638import Gen.Formatting
3739import Gen.Syntax
3840import Gen.Types
3941import HIndent
42+import HIndent.Types (defaultConfig)
4043import Language.Haskell.Exts.Build (name)
4144import Language.Haskell.Exts.Pretty as PP
4245import Prelude hiding (sum)
@@ -131,7 +134,10 @@ renderMethod s root suf m@Method {..} = do
131134 typ <- reserveType typ'
132135
133136 x@Solved {..} <- getSolved typ
134− Just d <- renderSchema x
137+ d' <- renderSchema x
138+ d <- case d' of
139+ Nothing -> error "failed to render the schema"
140+ Just d'' -> pure d''
135141
136142 i <- pp Print $ requestDecl _unique _prefix alias url (props _schema) m
137143 dl <- pp Print $ downloadDecl _unique _prefix alias url (props _schema) m
@@ -170,15 +176,15 @@ data PP
170176
171177pp :: (Pretty a, Show a) => PP -> a -> AST Rendered
172178pp i x
173− | i == Indent = result (reformat johanTibell Nothing p)
174− | otherwise = pure p
179+ | i == Indent = result (reformat defaultConfig Nothing Nothing p)
180+ | otherwise = pure (LText.pack (C8.unpack p))
175181 where
176− result = hoistEither . bimap e Build.toLazyText
182+ result = hoistEither . bimap (e . LText.pack) (LText.pack . LBS.unpack . LBB.toLazyByteString)
177183
178− e = flip mappend ("\nSyntax:\n" <> p <> "\nAST:\n" <> LText.pack (show x)) . LText.pack
184+ e = flip mappend ("\nSyntax:\n" <> LText.pack (C8.unpack p) <> "\nAST:\n" <> LText.pack (show x))
179185
180− p = LText.dropWhile isSpace
181− . LText.pack
186+ p = C8.dropWhile isSpace
187+ . C8.pack
182188 $ prettyPrintStyleMode s m x
183189
184190 s = style
gen/src/Gen/IO.hs+2−2
@@ -1,6 +1,5 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TupleSections #-}
43
54-- Module : Gen.IO
65-- Copyright : (c) 2015-2016 Brendan Hay
@@ -27,13 +26,14 @@ import System.IO
2726
2827import UnexceptionalIO (fromIO, runUIO)
2928
29+import qualified Data.Text as Text
3030import qualified Data.Text.Lazy as LText
3131import qualified Data.Text.Lazy.IO as LText
3232import qualified Filesystem as FS
3333import qualified Text.EDE as EDE
3434
3535run :: ExceptT Error IO a -> IO a
36−run = runScript . fmapLT LText.unpack
36+run = runScript . fmapLT (Text.pack . LText.unpack)
3737
3838io :: MonadIO m => IO a -> ExceptT Error m a
3939io = ExceptT . fmap (first (LText.pack . show)) . liftIO . runUIO . fromIO
gen/src/Gen/Orphans.hs+4−4
@@ -16,8 +16,8 @@ import Data.String
1616import Language.Haskell.Exts.Build
1717import Language.Haskell.Exts.Syntax
1818
19−instance Hashable Name
19+instance Hashable l => Hashable (Name l)
2020
21−instance IsString Name where fromString = name
22−instance IsString QName where fromString = UnQual . name
23−instance IsString QOp where fromString = op . sym
21+instance IsString (Name ()) where fromString = name
22+instance IsString (QName ()) where fromString = UnQual () . name
23+instance IsString (QOp ()) where fromString = op . sym
gen/src/Gen/Syntax.hs+258−233
@@ -26,39 +26,38 @@ import Gen.Text
2626import Gen.Types
2727import Language.Haskell.Exts.Build (app, appFun, infixApp, lamE, listE, name, noBinds, paren, patBind, pvar, sfun, strE, sym,
2828 var)
29−import Language.Haskell.Exts.SrcLoc
3029import Language.Haskell.Exts.Syntax hiding (Alt, Int, Lit)
3130
32−serviceSig :: Name -> Decl
33−serviceSig n = TypeSig noLoc [n] (TyCon "ServiceConfig")
31+serviceSig :: Name () -> Decl ()
32+serviceSig n = TypeSig () [n] (TyCon () "ServiceConfig")
3433
35−serviceDecl :: Service a -> Name -> Decl
36−serviceDecl s n = sfun noLoc n [] (UnGuardedRhs rhs) noBinds
34+serviceDecl :: Service a -> Name () -> Decl ()
35+serviceDecl s n = sfun n [] (UnGuardedRhs () rhs) noBinds
3736 where
3837 rhs = appFun (var "defaultService")
3938 [ app (var "ServiceId") (str (s ^. dId))
4039 , str . stripSuffix "/" $ stripPrefix "https://" (s ^. dRootUrl)
4140 ]
4241
43−scopeSig :: Name -> Text -> Decl
44−scopeSig n v = TypeSig noLoc [n] $
45− TyApp (TyCon "Proxy") $
46− TyPromoted $ PromotedList True
47− [ TyPromoted $ PromotedString (Text.unpack v)
42+scopeSig :: Name () -> Text -> Decl ()
43+scopeSig n v = TypeSig () [n] $
44+ TyApp () (TyCon () "Proxy") $
45+ TyPromoted () $ PromotedList () True
46+ [ TyPromoted () $ PromotedString () (Text.unpack v) (Text.unpack v)
4847 ]
4948
50−scopeDecl :: Name -> Decl
51−scopeDecl n = sfun noLoc n [] (UnGuardedRhs (var "Proxy")) noBinds
49+scopeDecl :: Name () -> Decl ()
50+scopeDecl n = sfun n [] (UnGuardedRhs () (var "Proxy")) noBinds
5251
53−apiAlias :: Name -> [Name] -> Decl
54−apiAlias n ls = TypeDecl noLoc n [] alias
52+apiAlias :: Name () -> [Name ()] -> Decl ()
53+apiAlias n ls = TypeDecl () (DHead () n) alias
5554 where
56− alias = case map (TyCon . UnQual) ls of
57− [] -> unit_tycon
58− x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r) x xs
55+ alias = case map (TyCon () . UnQual ()) ls of
56+ [] -> unit_tycon ()
57+ x:xs -> foldl' (\l r -> TyInfix () l ((UnpromotedName () . UnQual ()) (sym ":<|>")) r) x xs
5958
60−verbAlias :: HasDescription a s => a -> Name -> Method Solved -> Decl
61−verbAlias d n m = TypeDecl noLoc n [] $ servantOr meta (catMaybes [down, up])
59+verbAlias :: HasDescription a s => a -> Name () -> Method Solved -> Decl ()
60+verbAlias d n m = TypeDecl () (DHead () n) $ servantOr meta (catMaybes [down, up])
6261 where
6362 meta = path $ metadataAlias m
6463 down = path <$> downloadAlias m
@@ -68,18 +67,18 @@ verbAlias d n m = TypeDecl noLoc n [] $ servantOr meta (catMaybes [down, up])
6867
6968 root = subPaths (d ^. dServicePath) ++ requestPath m (_mPath m)
7069
71−metadataAlias :: Method Solved -> Type
70+metadataAlias :: Method Solved -> Type ()
7271metadataAlias m = servantSub (jsonVerb m) (params ++ media)
7372 where
7473 params = requestQuery m (requestQueryParams m)
7574 media = case _mRequest m of
7675 Nothing -> []
7776 Just b ->
78− [ TyApp (TyApp (TyCon "ReqBody") jsonMedia)
77+ [ TyApp () (TyApp () (TyCon () "ReqBody") jsonMedia)
7978 (tycon (ref b))
8079 ]
8180
82−downloadAlias :: Method Solved -> Maybe Type
81+downloadAlias :: Method Solved -> Maybe (Type ())
8382downloadAlias m
8483 | _mSupportsMediaDownload m = Just download
8584 | otherwise = Nothing
@@ -88,7 +87,7 @@ downloadAlias m
8887
8988 params = requestQuery m . Map.delete "alt" $ requestQueryParams m
9089
91−uploadAlias :: [Type] -> Method Solved -> Maybe Type
90+uploadAlias :: [Type ()] -> Method Solved -> Maybe (Type ())
9291uploadAlias sub m
9392 | _mSupportsMediaUpload m = Just upload
9493 | otherwise = Nothing
@@ -104,16 +103,16 @@ uploadAlias sub m
104103 media = case _mRequest m of
105104 Just b ->
106105 [ multipartParam
107− , TyApp (TyApp (TyCon "MultipartRelated") jsonMedia)
106+ , TyApp () (TyApp () (TyCon () "MultipartRelated") jsonMedia)
108107 (tycon (ref b))
109108 ]
110109
111110 Nothing ->
112111 [ mediaParam
113− , TyCon "AltMedia"
112+ , TyCon () "AltMedia"
114113 ]
115114
116−requestPath :: Method Solved -> Text -> [Type]
115+requestPath :: Method Solved -> Text -> [Type ()]
117116requestPath m = map go . extractPath
118117 where
119118 go (Left t) = sing t
@@ -121,29 +120,29 @@ requestPath m = map go . extractPath
121120 Nothing -> error $ "Unable to find path parameter " ++ show l
122121 Just x -> case c of
123122 Nothing | x ^. iRepeated ->
124− TyApp (TyApp (TyCon "Captures")
123+ TyApp () (TyApp () (TyCon () "Captures")
125124 (sing (local l)))
126125 (terminalType (_type (_pParam x)))
127126
128127 Nothing ->
129− TyApp (TyApp (TyCon "Capture")
128+ TyApp () (TyApp () (TyCon () "Capture")
130129 (sing (local l)))
131130 (terminalType (_type (_pParam x)))
132131
133132 Just y ->
134− TyApp (TyApp (TyApp (TyCon "CaptureMode")
133+ TyApp () (TyApp () (TyApp () (TyCon () "CaptureMode")
135134 (sing (local l)))
136135 (sing y))
137136 (terminalType (_type (_pParam x)))
138137
139−requestQuery :: Method Solved -> Map Local (Param Solved) -> [Type]
138+requestQuery :: Method Solved -> Map Local (Param Solved) -> [Type ()]
140139requestQuery m xs = mapMaybe go $
141140 orderParams fst (Map.toList xs) (_mParameterOrder m)
142141 where
143142 go (k, x) = case _pLocation x of
144143 Query | x ^. iRepeated
145− -> Just $ TyApp (TyApp (TyCon "QueryParams") n) t
146− Query -> Just $ TyApp (TyApp (TyCon "QueryParam") n) t
144+ -> Just $ TyApp () (TyApp () (TyCon () "QueryParams") n) t
145+ Query -> Just $ TyApp () (TyApp () (TyCon () "QueryParam") n) t
147146 Path -> Nothing
148147 where
149148 t = terminalType (_type (_pParam x))
@@ -152,52 +151,47 @@ requestQuery m xs = mapMaybe go $
152151requestQueryParams :: Method a -> Map Local (Param a)
153152requestQueryParams = Map.filter ((/= Path) . _pLocation) . _mParameters
154153
155−servantOr, servantSub :: Type -> [Type] -> Type
156−servantOr = foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r)
157−servantSub = foldr' (\l r -> TyInfix l (UnQual (sym ":>")) r)
154+servantOr, servantSub :: Type () -> [Type ()] -> Type ()
155+servantOr = foldl' (\l r -> TyInfix () l ((UnpromotedName () . UnQual ()) (sym ":<|>")) r)
156+servantSub = foldr' (\l r -> TyInfix () l ((UnpromotedName () . UnQual ()) (sym ":>")) r)
158157
159−jsonVerb :: Method a -> Type
158+jsonVerb :: Method a -> Type ()
160159jsonVerb m =
161− TyApp (TyApp (httpMethod m) jsonMedia)
162− $ maybe (TyCon "()") (tycon . ref) (_mResponse m)
160+ TyApp () (TyApp () (httpMethod m) jsonMedia)
161+ $ maybe (TyCon () "()") (tycon . ref) (_mResponse m)
163162
164−downloadVerb :: Method a -> Type
163+downloadVerb :: Method a -> Type ()
165164downloadVerb m =
166− TyApp (TyApp (httpMethod m) streamMedia)
167− (TyCon "Stream")
165+ TyApp () (TyApp () (httpMethod m) streamMedia)
166+ (TyCon () "Stream")
168167
169−httpMethod :: Method a -> Type
170−httpMethod = TyCon . unqual . Text.unpack . Text.toTitle . _mHttpMethod
168+httpMethod :: Method a -> Type ()
169+httpMethod = TyCon () . unqual . Text.unpack . Text.toTitle . _mHttpMethod
171170
172−subPaths :: Text -> [Type]
171+subPaths :: Text -> [Type ()]
173172subPaths = map sing . filter (not . Text.null) . Text.split (== '/')
174173
175−jsonMedia, streamMedia :: Type
174+jsonMedia, streamMedia :: Type ()
176175jsonMedia = tylist ["JSON"]
177176streamMedia = tylist ["OctetStream"]
178177
179−downloadParam :: Type
178+downloadParam :: Type ()
180179downloadParam =
181− TyApp (TyApp (TyCon "QueryParam") (sing "alt"))
182− (TyCon "AltMedia")
180+ TyApp () (TyApp () (TyCon () "QueryParam") (sing "alt"))
181+ (TyCon () "AltMedia")
183182
184−mediaParam :: Type
183+mediaParam :: Type ()
185184mediaParam =
186− TyApp (TyApp (TyCon "QueryParam") (sing "uploadType"))
187− (TyCon "AltMedia")
185+ TyApp () (TyApp () (TyCon () "QueryParam") (sing "uploadType"))
186+ (TyCon () "AltMedia")
188187
189−multipartParam :: Type
188+multipartParam :: Type ()
190189multipartParam =
191− TyApp (TyApp (TyCon "QueryParam") (sing "uploadType"))
192− (TyCon "Multipart")
190+ TyApp () (TyApp () (TyCon () "QueryParam") (sing "uploadType"))
191+ (TyCon () "Multipart")
193192
194−metadataPat, downloadPat, uploadPat :: Method a -> Pat
195−metadataPat = pattern 1
196−downloadPat = pattern 2
197−uploadPat = pattern 3
198−
199−pattern :: Integer -> Method a -> Pat
200−pattern n m = case (n, down, up) of
193+pattern' :: Integer -> Method a -> Pat ()
194+pattern' n m = case (n, down, up) of
201195 (1, True, True) -> infixOr go (infixOr wild wild)
202196 (2, True, True) -> infixOr wild (infixOr go wild)
203197 (_, True, True) -> infixOr wild (infixOr wild go)
@@ -214,51 +208,57 @@ pattern n m = case (n, down, up) of
214208 up = _mSupportsMediaUpload m
215209
216210 go = pvar "go"
217− wild = PWildCard
211+ wild = PWildCard ()
212+
213+ infixOr l = PInfixApp () l (UnQual () (sym ":<|>"))
214+
215+metadataPat, downloadPat, uploadPat :: Method a -> Pat ()
216+metadataPat = pattern' 1
217+downloadPat = pattern' 2
218+uploadPat = pattern' 3
218219
219− infixOr l r = PInfixApp l (UnQual (sym ":<|>")) r
220220
221221downloadDecl :: Global
222222 -> Prefix
223− -> Name
224− -> Name
223+ -> Name ()
224+ -> Name ()
225225 -> [Local]
226226 -> Method Solved
227− -> Decl
227+ -> Decl ()
228228downloadDecl n pre api url fs m =
229− googleRequestDecl ty [rs, ss] [alt] pre api url m pat prec
229+ googleRequestDecl (TyParen () ty) [rs, ss] [alt] pre api url m pat prec
230230 where
231− ty = TyApp (TyCon "MediaDownload") (tycon n)
231+ ty = TyApp () (TyCon () "MediaDownload") (tycon n)
232232
233− rs = InsType noLoc (TyApp (TyCon "Rs") ty) (TyCon "Stream")
233+ rs = InsType () (TyApp () (TyCon () "Rs") ty) (TyCon () "Stream")
234234
235− ss = InsType noLoc (TyApp (TyCon "Scopes") ty) $
236− TyApp (TyCon "Scopes") (tycon n)
235+ ss = InsType () (TyApp () (TyCon () "Scopes") ty) $
236+ TyApp () (TyCon () "Scopes") (tycon n)
237237
238238 alt = app (var "Just") (var "AltMedia")
239239 pat = downloadPat m
240240
241− prec = PApp (UnQual "MediaDownload")
242− [ PRec (UnQual (dname' n)) [PFieldWildcard | not (null fs)]
241+ prec = PApp () (UnQual () "MediaDownload")
242+ [ PRec () (UnQual () (dname' n)) [PFieldWildcard () | not (null fs)]
243243 ]
244244
245245uploadDecl :: Global
246246 -> Prefix
247− -> Name
248− -> Name
247+ -> Name ()
248+ -> Name ()
249249 -> [Local]
250250 -> Method Solved
251− -> Decl
251+ -> Decl ()
252252uploadDecl n pre api url fs m =
253− googleRequestDecl ty [rs, ss] extras pre api url m pat prec
253+ googleRequestDecl (TyParen () ty) [rs, ss] extras pre api url m pat prec
254254 where
255− ty = TyApp (TyCon "MediaUpload") (tycon n)
255+ ty = TyApp () (TyCon () "MediaUpload") (tycon n)
256256
257− rs = InsType noLoc (TyApp (TyCon "Rs") ty) $
258− maybe unit_tycon (tycon . ref) (_mResponse m)
257+ rs = InsType () (TyApp () (TyCon () "Rs") ty) $
258+ maybe (unit_tycon ()) (tycon . ref) (_mResponse m)
259259
260− ss = InsType noLoc (TyApp (TyCon "Scopes") ty) $
261− TyApp (TyCon "Scopes") (tycon n)
260+ ss = InsType () (TyApp () (TyCon () "Scopes") ty) $
261+ TyApp () (TyCon () "Scopes") (tycon n)
262262
263263 extras = maybeToList alt ++ [upl] ++ payload ++ [var media]
264264 where
@@ -276,30 +276,32 @@ uploadDecl n pre api url fs m =
276276
277277 pat = uploadPat m
278278
279− prec = PApp (UnQual "MediaUpload")
280− [ PRec (UnQual (dname' n)) [PFieldWildcard | not (null fs)]
281− , PVar media
279+ prec = PApp () (UnQual () "MediaUpload")
280+ [ PRec () (UnQual () (dname' n)) [PFieldWildcard () | not (null fs)]
281+ , PVar () media
282282 ]
283283
284284 media = name "body"
285285
286286requestDecl :: Global
287287 -> Prefix
288− -> Name
289− -> Name
288+ -> Name ()
289+ -> Name ()
290290 -> [Local]
291291 -> Method Solved
292− -> Decl
292+ -> Decl ()
293293requestDecl n pre api url fs m =
294294 googleRequestDecl (tycon n) [rs, ss] extras pre api url m pat prec
295295 where
296− rs = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $
297− maybe unit_tycon (tycon . ref) (_mResponse m)
296+ rs :: InstDecl ()
297+ rs = InsType () (TyApp () (TyCon () "Rs") (tycon n)) $
298+ maybe (unit_tycon ()) (tycon . ref) (_mResponse m)
298299
299− ss = InsType noLoc (TyApp (TyCon "Scopes") (tycon n)) $
300− TyPromoted $
301− PromotedList True $
302− map (TyPromoted . PromotedString . Text.unpack) (_mScopes m)
300+ ss :: InstDecl ()
301+ ss = InsType () (TyApp () (TyCon () "Scopes") (tycon n)) $
302+ TyPromoted () $
303+ PromotedList () True $
304+ map (\m' -> TyPromoted () (PromotedString () (Text.unpack m') "Scopes")) (_mScopes m)
303305
304306 extras = catMaybes [alt, payload]
305307 where
@@ -312,35 +314,35 @@ requestDecl n pre api url fs m =
312314
313315 pat = metadataPat m
314316
315− prec = PRec (UnQual (dname' n)) [PFieldWildcard | not (null fs)]
317+ prec = PRec () (UnQual () (dname' n)) [PFieldWildcard () | not (null fs)]
316318
317−googleRequestDecl :: Type
318− -> [InstDecl]
319− -> [Exp]
319+googleRequestDecl :: Type ()
320+ -> [InstDecl ()]
321+ -> [Exp ()]
320322 -> Prefix
321− -> Name
322− -> Name
323+ -> Name ()
324+ -> Name ()
323325 -> Method Solved
324− -> Pat
325− -> Pat
326− -> Decl
326+ -> Pat ()
327+ -> Pat ()
328+ -> Decl ()
327329googleRequestDecl n assoc extras pre api url m pat prec =
328− InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n] (assoc ++ [request])
330+ InstDecl () Nothing (instrule "GoogleRequest" n) (Just (assoc ++ [request]))
329331 where
330− request = InsDecl (FunBind [match])
332+ request = InsDecl () (FunBind () [match])
331333
332− match = Match noLoc (name "requestClient") [prec] Nothing rhs (Just decls)
334+ match = Match () (name "requestClient") [prec] rhs (Just decls)
333335
334− decls = BDecls
335− [ patBind noLoc pat $
336+ decls = BDecls ()
337+ [ patBind pat $
336338 appFun (var "buildClient") $
337− [ ExpTypeSig noLoc (var "Proxy") $
338− TyApp (TyCon "Proxy") (TyCon (UnQual api))
339+ [ ExpTypeSig () (var "Proxy") $
340+ TyApp () (TyCon () "Proxy") (TyCon () (UnQual () api))
339341 , var "mempty"
340342 ]
341343 ]
342344
343− rhs = UnGuardedRhs . appFun (var "go") $ map go fs ++ extras ++ [var url]
345+ rhs = UnGuardedRhs () . appFun (var "go") $ map go fs ++ extras ++ [var url]
344346 where
345347 go l = case Map.lookup l ps of
346348 Just p | _pLocation p == Query
@@ -365,16 +367,15 @@ googleRequestDecl n assoc extras pre api url m pat prec =
365367 . nub
366368 $ map fst (rights (extractPath (_mPath m))) ++ _mParameterOrder m
367369
368−jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]
370+jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl ()]
369371jsonDecls g p (Map.toList -> rs) = [from', to']
370372 where
371− from' = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon g]
373+ from' = InstDecl () Nothing (instrule "FromJSON" (tycon g)) (Just
372374 [ funD "parseJSON" $
373375 app (app (var "withObject") (dstr g)) $
374− lamE noLoc [pvar "o"] $
376+ lamE [pvar "o"] $
375377 ctorE g (map decode rs)
376− ]
377−
378+ ])
378379 decode (l, s)
379380 | _additional s = app (var "parseJSONObject") (var "o")
380381 | Just x <- def s = defJS l x
@@ -384,15 +385,15 @@ jsonDecls g p (Map.toList -> rs) = [from', to']
384385
385386 to' = case rs of
386387 [(k, v)] | _additional v ->
387− InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
388+ InstDecl () Nothing (instrule "ToJSON" (tycon g)) (Just
388389 [ funD "toJSON" $
389390 infixApp (var "toJSON") "." (var (fname p k))
390− ]
391+ ])
391392
392393 _ ->
393− InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
394+ InstDecl () Nothing (instrule "ToJSON" (tycon g)) (Just
394395 [ wildcardD "toJSON" g omit emptyObj (map encode rs)
395− ]
396+ ])
396397
397398 omit = app (var "object")
398399 . app (var "catMaybes")
@@ -410,81 +411,99 @@ jsonDecls g p (Map.toList -> rs) = [from', to']
410411
411412wildcardD :: String
412413 -> Global
413− -> ([Exp] -> Exp)
414− -> Exp
415− -> [Exp]
416− -> InstDecl
414+ -> ([Exp ()] -> Exp ())
415+ -> Exp ()
416+ -> [Exp ()]
417+ -> InstDecl ()
417418wildcardD f n enc x = \case
418419 [] -> constD f x
419− xs -> InsDecl (FunBind [match prec xs])
420+ xs -> InsDecl () (FunBind () [match prec xs])
420421 where
421422 match p es =
422− Match noLoc (name f) [p] Nothing (UnGuardedRhs (enc es)) noBinds
423+ Match () (name f) [p] (UnGuardedRhs () (enc es)) noBinds
423424
424− prec = PRec (UnQual (dname' n)) [PFieldWildcard]
425+ prec = PRec () (UnQual () (dname' n)) [PFieldWildcard ()]
425426
426−defJS :: Local -> Exp -> Exp
427+defJS :: Local -> Exp () -> Exp ()
427428defJS n x = infixApp (infixApp (var "o") ".:?" (fstr n)) ".!=" x
428429
429−reqJS :: Local -> Exp
430+reqJS :: Local -> Exp ()
430431reqJS = infixApp (var "o") ".:" . fstr
431432
432−optJS :: Local -> Exp
433+optJS :: Local -> Exp ()
433434optJS = infixApp (var "o") ".:?" . fstr
434435
435−funD :: String -> Exp -> InstDecl
436−funD f = InsDecl . patBind noLoc (pvar (name f))
436+funD :: String -> Exp () -> InstDecl ()
437+funD f = InsDecl () . patBind (pvar (name f))
437438
438−constD :: String -> Exp -> InstDecl
439−constD f x = InsDecl $
440− sfun noLoc (name f) [] (UnGuardedRhs (app (var "const") x)) noBinds
439+constD :: String -> Exp () -> InstDecl ()
440+constD f x = InsDecl () $
441+ sfun (name f) [] (UnGuardedRhs () (app (var "const") x)) noBinds
441442
442−ctorE :: Global -> [Exp] -> Exp
443+ctorE :: Global -> [Exp ()] -> Exp ()
443444ctorE n = seqE (var (dname' n)) . map paren
444445
445−seqE :: Exp -> [Exp] -> Exp
446+seqE :: Exp () -> [Exp ()] -> Exp ()
446447seqE l [] = app (var "pure") l
447448seqE l (r:rs) = infixApp l "<$>" (infixE r "<*>" rs)
448449
449−objDecl :: Global -> Prefix -> [Derive] -> Map Local Solved -> Decl
450+objDecl :: Global -> Prefix -> [Derive] -> Map Local Solved -> Decl ()
450451objDecl n p ds rs =
451− DataDecl noLoc arity [] (dname n) [] [conDecl (dname' n) p rs] (der ds)
452+ DataDecl () arity Nothing (DHead () (dname n)) [conDecl (dname' n) p rs] [(der ds)]
452453 where
453− arity | Map.size rs == 1 = NewType
454− | otherwise = DataType
455−
456− der = map ((,[]) . unqual . drop 1 . show)
457−
458−conDecl :: Name -> Prefix -> Map Local Solved -> QualConDecl
459−conDecl n p rs = QualConDecl noLoc [] [] body
454+ arity | Map.size rs == 1 = NewType ()
455+ | otherwise = DataType ()
456+
457+ der = Deriving () Nothing . map (unqualrule . drop 1 . show)
458+
459+-- decl =
460+-- DataDecl
461+-- ()
462+-- (DataType ())
463+-- Nothing
464+-- (DHead () (Ident () "AboutGet"))
465+-- [QualConDecl () Nothing Nothing (ConDecl () (Ident () "AboutGet'") [])]
466+-- [ Deriving
467+-- ()
468+-- Nothing
469+-- [ IRule () Nothing Nothing (IHCon () (UnQual () (Ident () "Eq")))
470+-- , IRule () Nothing Nothing (IHCon () (UnQual () (Ident () "Show")))
471+-- , IRule () Nothing Nothing (IHCon () (UnQual () (Ident () "Data")))
472+-- , IRule () Nothing Nothing (IHCon () (UnQual () (Ident () "Typeable")))
473+-- , IRule () Nothing Nothing (IHCon () (UnQual () (Ident () "Generic")))
474+-- ]
475+-- ]
476+
477+conDecl :: Name () -> Prefix -> Map Local Solved -> QualConDecl ()
478+conDecl n p rs = QualConDecl () Nothing Nothing body
460479 where
461480 body = case Map.toList rs of
462− [] -> ConDecl n []
463− [x] -> RecDecl n [field internalType x]
464− xs -> RecDecl n (map (field (strict . internalType)) xs)
481+ [] -> ConDecl () n []
482+ [x] -> RecDecl () n [field internalType x]
483+ xs -> RecDecl () n (map (field (strict . internalType)) xs)
465484
466− field f (l, v) = ([fname p l], f (_type v))
485+ field f (l, v) = FieldDecl () [fname p l] (f (_type v))
467486
468−ctorSig :: Global -> Map Local Solved -> Decl
469−ctorSig n rs = TypeSig noLoc [cname n] ts
487+ctorSig :: Global -> Map Local Solved -> Decl ()
488+ctorSig n rs = TypeSig () [cname n] ts
470489 where
471− ts = foldr' TyFun (TyCon (UnQual (dname n))) ps
490+ ts = foldr' (TyFun ()) (TyCon () (UnQual () (dname n))) ps
472491 ps = parameters (Map.elems rs)
473492
474−ctorDecl :: Global -> Prefix -> Map Local Solved -> Decl
475−ctorDecl n p rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds
493+ctorDecl :: Global -> Prefix -> Map Local Solved -> Decl ()
494+ctorDecl n p rs = sfun c ps (UnGuardedRhs () rhs) noBinds
476495 where
477496 c = cname n
478497 d = dname' n
479498
480499 rhs | Map.null rs = var d
481− | otherwise = RecConstr (UnQual d) $
500+ | otherwise = RecConstr () (UnQual () d) $
482501 map (uncurry (fieldUpdate p)) (Map.toList rs)
483502
484503 ps = map (pname p) . Map.keys $ Map.filter parameter rs
485504
486−fieldUpdate :: Prefix -> Local -> Solved -> FieldUpdate
487−fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
505+fieldUpdate :: Prefix -> Local -> Solved -> FieldUpdate ()
506+fieldUpdate p l s = FieldUpdate () (UnQual () (fname p l)) rhs
488507 where
489508 rhs | Just x <- def s, s ^. iRepeated = listE [x]
490509 | Just x <- def s = x
@@ -494,26 +513,26 @@ fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
494513
495514 v = var (pname p l)
496515
497−lensSig :: Global -> Prefix -> Local -> Solved -> Decl
498−lensSig n p l s = TypeSig noLoc [lname p l] $
499− TyApp (TyApp (TyCon "Lens'") (tycon n))
516+lensSig :: Global -> Prefix -> Local -> Solved -> Decl ()
517+lensSig n p l s = TypeSig () [lname p l] $
518+ TyApp () (TyApp () (TyCon () "Lens'") (tycon n))
500519 (externalType (_type s))
501520
502−lensDecl :: Prefix -> Local -> Solved -> Decl
503−lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds
521+lensDecl :: Prefix -> Local -> Solved -> Decl ()
522+lensDecl p l s = sfun (lname p l) [] (UnGuardedRhs () rhs) noBinds
504523 where
505524 f = fname p l
506525 t = _type s
507526
508527 rhs = mapping t $
509528 app (app (var "lens") (var f))
510− (paren (lamE noLoc [pvar "s", pvar "a"]
511− (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))
529+ (paren (lamE [pvar "s", pvar "a"]
530+ (RecUpdate () (var "s") [FieldUpdate () (UnQual () f) (var "a")])))
512531
513−parameters :: [Solved] -> [Type]
532+parameters :: [Solved] -> [Type ()]
514533parameters = map (externalType . _type) . filter parameter
515534
516−def :: Solved -> Maybe Exp
535+def :: Solved -> Maybe (Exp ())
517536def s
518537 | Just x <- s ^. iDefault = Just (go x (_prefix s) (_schema s))
519538 | otherwise = Nothing
@@ -527,77 +546,77 @@ def s
527546
528547 lit = var . name . Text.unpack
529548
530−terminalType :: TType -> Type
549+terminalType :: TType -> Type ()
531550terminalType = internalType . go
532551 where
533552 go (TMaybe x) = go x
534553 go (TList x) = go x
535554 go x = x
536555
537−externalType :: TType -> Type
556+externalType :: TType -> Type ()
538557externalType = \case
539558 TType r -> tycon r
540559 TMaybe t@TList {} -> externalType t
541− TMaybe t -> TyApp (TyCon "Maybe") (externalType t)
542− TList t -> TyList (externalType t)
560+ TMaybe t -> TyApp () (TyCon () "Maybe") (externalType t)
561+ TList t -> TyList () (externalType t)
543562 TLit l -> externalLit l
544563 TMap k v ->
545− TyApp (TyApp (TyCon "HashMap") (externalType k)) (externalType (require v))
564+ TyApp () (TyApp () (TyCon () "HashMap") (externalType k)) (externalType (require v))
546565
547−internalType :: TType -> Type
566+internalType :: TType -> Type ()
548567internalType = \case
549568 TType r -> tycon r
550− TMaybe t -> TyApp (TyCon "Maybe") (internalType t)
551− TList t -> TyList (internalType t)
569+ TMaybe t -> TyApp () (TyCon () "Maybe") (internalType t)
570+ TList t -> TyList () (internalType t)
552571 TLit l -> internalLit l
553572 TMap k v ->
554− TyApp (TyApp (TyCon "HashMap") (internalType k)) (internalType (require v))
573+ TyApp () (TyApp () (TyCon () "HashMap") (internalType k)) (internalType (require v))
555574
556−externalLit :: Lit -> Type
575+externalLit :: Lit -> Type ()
557576externalLit = \case
558− Text -> TyCon "Text"
559− Bool -> TyCon "Bool"
560− Time -> TyCon "TimeOfDay"
561− Date -> TyCon "Day"
562− DateTime -> TyCon "UTCTime"
563− Nat -> TyCon "Natural"
564− Float -> TyCon "Double"
565− Double -> TyCon "Double"
566− Byte -> TyCon "ByteString"
567− UInt32 -> TyCon "Word32"
568− UInt64 -> TyCon "Word64"
569− Int32 -> TyCon "Int32"
570− Int64 -> TyCon "Int64"
571− Alt t -> TyCon (unqual (Text.unpack t))
572− RqBody -> TyCon "RequestBody"
573− RsBody -> TyCon "Stream"
574− JSONValue -> TyCon "JSONValue"
575− GFieldMask -> TyCon "GFieldMask"
576− GDuration -> TyCon "Scientific"
577−
578−internalLit :: Lit -> Type
577+ Text -> TyCon () "Text"
578+ Bool -> TyCon () "Bool"
579+ Time -> TyCon () "TimeOfDay"
580+ Date -> TyCon () "Day"
581+ DateTime -> TyCon () "UTCTime"
582+ Nat -> TyCon () "Natural"
583+ Float -> TyCon () "Double"
584+ Double -> TyCon () "Double"
585+ Byte -> TyCon () "ByteString"
586+ UInt32 -> TyCon () "Word32"
587+ UInt64 -> TyCon () "Word64"
588+ Int32 -> TyCon () "Int32"
589+ Int64 -> TyCon () "Int64"
590+ Alt t -> TyCon () (unqual (Text.unpack t))
591+ RqBody -> TyCon () "RequestBody"
592+ RsBody -> TyCon () "Stream"
593+ JSONValue -> TyCon () "JSONValue"
594+ GFieldMask -> TyCon () "GFieldMask"
595+ GDuration -> TyCon () "Scientific"
596+
597+internalLit :: Lit -> Type ()
579598internalLit = \case
580− Text -> TyCon "Text"
581− Bool -> TyCon "Bool"
582− Time -> TyCon "Time'"
583− Date -> TyCon "Date'"
584− DateTime -> TyCon "DateTime'"
585− Nat -> TyApp (TyCon "Textual") (TyCon "Nat")
586− Float -> TyApp (TyCon "Textual") (TyCon "Double")
587− Double -> TyApp (TyCon "Textual") (TyCon "Double")
588− Byte -> TyCon "Bytes"
589− UInt32 -> TyApp (TyCon "Textual") (TyCon "Word32")
590− UInt64 -> TyApp (TyCon "Textual") (TyCon "Word64")
591− Int32 -> TyApp (TyCon "Textual") (TyCon "Int32")
592− Int64 -> TyApp (TyCon "Textual") (TyCon "Int64")
593− Alt t -> TyCon (unqual (Text.unpack t))
594− RqBody -> TyCon "RequestBody"
595− RsBody -> TyCon "Stream"
596− JSONValue -> TyCon "JSONValue"
597− GFieldMask -> TyCon "GFieldMask"
598− GDuration -> TyCon "GDuration"
599−
600−mapping :: TType -> Exp -> Exp
599+ Text -> TyCon () "Text"
600+ Bool -> TyCon () "Bool"
601+ Time -> TyCon () "Time'"
602+ Date -> TyCon () "Date'"
603+ DateTime -> TyCon () "DateTime'"
604+ Nat -> TyApp () (TyCon () "Textual") (TyCon () "Nat")
605+ Float -> TyApp () (TyCon () "Textual") (TyCon () "Double")
606+ Double -> TyApp () (TyCon () "Textual") (TyCon () "Double")
607+ Byte -> TyCon () "Bytes"
608+ UInt32 -> TyApp () (TyCon () "Textual") (TyCon () "Word32")
609+ UInt64 -> TyApp () (TyCon () "Textual") (TyCon () "Word64")
610+ Int32 -> TyApp () (TyCon () "Textual") (TyCon () "Int32")
611+ Int64 -> TyApp () (TyCon () "Textual") (TyCon () "Int64")
612+ Alt t -> TyCon () (unqual (Text.unpack t))
613+ RqBody -> TyCon () "RequestBody"
614+ RsBody -> TyCon () "Stream"
615+ JSONValue -> TyCon () "JSONValue"
616+ GFieldMask -> TyCon () "GFieldMask"
617+ GDuration -> TyCon () "GDuration"
618+
619+mapping :: TType -> Exp () -> Exp ()
601620mapping t e = infixE e "." (go t)
602621 where
603622 go = \case
@@ -608,7 +627,7 @@ mapping t e = infixE e "." (go t)
608627 nest [] = []
609628 nest (x:xs) = [app (var "mapping") (infixE x "." xs)]
610629
611−iso :: TType -> Maybe Exp
630+iso :: TType -> Maybe (Exp ())
612631iso = \case
613632 TList {} -> Just (var "_Coerce")
614633 TMap {} -> Just (var "_Coerce")
@@ -630,27 +649,33 @@ require :: TType -> TType
630649require (TMaybe t) = t
631650require t = t
632651
633−strict :: Type -> Type
634−strict = TyBang BangedTy . \case
635− t@TyApp{} -> TyParen t
652+strict :: Type () -> Type ()
653+strict = TyBang () (BangedTy ()) (NoUnpackPragma ()) . \case
654+ t@TyApp{} -> TyParen () t
636655 t -> t
637656
638−sing :: Text -> Type
639−sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""
657+sing :: Text -> Type ()
658+sing = TyCon () . unqual . Text.unpack . flip mappend "\"" . mappend "\""
640659
641−tylist :: [Text] -> Type
642−tylist xs = TyCon . UnQual . name . Text.unpack $
660+tylist :: [Text] -> Type ()
661+tylist xs = TyCon () . UnQual () . name . Text.unpack $
643662 "'[" <> Text.intercalate ", " xs <> "]"
644663
645−tycon :: Global -> Type
646−tycon = TyCon . UnQual . dname
664+tycon :: Global -> Type ()
665+tycon = TyCon () . UnQual () . dname
666+
667+unqual :: String -> QName ()
668+unqual = UnQual () . name
669+
670+unqualrule :: String -> InstRule ()
671+unqualrule = IRule () Nothing Nothing . IHCon () . unqual
647672
648−unqual :: String -> QName
649−unqual = UnQual . name
673+instrule :: String -> Type () -> InstRule ()
674+instrule n t = IRule () Nothing Nothing (IHApp () (IHCon () (unqual n)) t)
650675
651−infixE :: Exp -> QOp -> [Exp] -> Exp
676+infixE :: Exp () -> QOp () -> [Exp ()] -> Exp ()
652677infixE l _ [] = l
653678infixE l o (r:rs) = infixE (infixApp l o r) o rs
654679
655−str :: Text -> Exp
680+str :: Text -> Exp ()
656681str = strE . Text.unpack
gen/src/Gen/Text.hs−1
@@ -19,7 +19,6 @@ import Data.Char
1919import qualified Data.Foldable as Fold
2020import qualified Data.HashMap.Strict as Map
2121import qualified Data.HashSet as Set
22−import Data.Monoid
2322import Data.String
2423import Data.Text (Text)
2524import qualified Data.Text as Text
gen/src/Gen/Types/Data.hs+7−7
@@ -47,7 +47,7 @@ data Syn a = Syn { syntax :: a }
4747instance Pretty a => ToJSON (Syn a) where
4848 toJSON = toJSON . prettyPrint . syntax
4949
50−data Fun = Fun' Name (Maybe Help) Rendered Rendered
50+data Fun = Fun' (Name ()) (Maybe Help) Rendered Rendered
5151
5252instance ToJSON Fun where
5353 toJSON (Fun' n h s d) = object
@@ -57,7 +57,7 @@ instance ToJSON Fun where
5757 , "decl" .= d
5858 ]
5959
60−data Branch = Branch Name Text Help
60+data Branch = Branch (Name ()) Text Help
6161
6262instance ToJSON Branch where
6363 toJSON (Branch n v h) = object
@@ -67,8 +67,8 @@ instance ToJSON Branch where
6767 ]
6868
6969data Data
70− = Sum Name (Maybe Help) [Branch]
71− | Prod Name (Maybe Help) Rendered Fun [Fun] [Rendered]
70+ = Sum (Name ()) (Maybe Help) [Branch]
71+ | Prod (Name ()) (Maybe Help) Rendered Fun [Fun] [Rendered]
7272
7373instance ToJSON Data where
7474 toJSON = \case
@@ -89,7 +89,7 @@ instance ToJSON Data where
8989 , "instances" .= is
9090 ]
9191
92−dataName :: Data -> Name
92+dataName :: Data -> Name ()
9393dataName = \case
9494 Sum n _ _ -> n
9595 Prod n _ _ _ _ _ -> n
@@ -99,7 +99,7 @@ data Action = Action
9999 , _actType :: Global
100100 , _actNamespace :: NS
101101 , _actHelp :: Maybe Help
102− , _actAliasName :: Name
102+ , _actAliasName :: Name ()
103103 , _actAlias :: Rendered
104104 , _actData :: Data
105105 }
@@ -115,7 +115,7 @@ instance ToJSON Action where
115115 ]
116116
117117data API = API
118− { _apiAliasName :: Name
118+ { _apiAliasName :: Name ()
119119 , _apiAlias :: Rendered
120120 , _apiResources :: [Action]
121121 , _apiMethods :: [Action]
gen/src/Gen/Types/Help.hs+8−6
@@ -19,7 +19,7 @@ import Data.Aeson
1919import Data.Char (isSpace)
2020import Data.String
2121import Data.Text (Text)
22−import qualified Data.Text as T
22+import qualified System.IO.Unsafe as Unsafe
2323
2424import Text.Pandoc as Pandoc
2525import Text.Pandoc.Pretty
@@ -32,9 +32,8 @@ data Help
3232 | Raw !Text
3333 deriving (Eq)
3434
35−instance Monoid Help where
36− mempty = Help []
37− mappend x y =
35+instance Semigroup Help where
36+ (<>) x y =
3837 case (x, y) of
3938 (Help a, Help b) -> Help (a <> b)
4039 (Pan a a', Pan b b') -> Pan (a <> b) (a' <> b')
@@ -43,6 +42,9 @@ instance Monoid Help where
4342 (a, Help b) -> Help (a : b)
4443 (a, b) -> Help [a, b]
4544
45+instance Monoid Help where
46+ mempty = Help []
47+
4648-- | Empty Show instance to avoid verbose debugging output.
4749instance Show Help where
4850 show = const mempty
@@ -55,7 +57,7 @@ rawHelpText = Raw
5557
5658instance FromJSON Help where
5759 parseJSON = withText "help" $ \t ->
58− case Pandoc.readHtml def (T.unpack t) of
60+ case (Unsafe.unsafePerformIO . Pandoc.runIO) (Pandoc.readHtml def t) of
5961 Left e -> fail (show e)
6062 Right x -> pure $! Pan x t
6163
@@ -84,7 +86,7 @@ flatten :: Help -> String
8486flatten = \case
8587 Help xs -> foldMap flatten xs
8688 Raw t -> Text.unpack t
87− Pan d _t -> Pandoc.writeHaddock def d
89+ Pan d _t -> Text.unpack ((Unsafe.unsafePerformIO . Pandoc.runIOorExplode) (Pandoc.writeHaddock def d))
8890
8991wrap :: String -> String -> Text
9092wrap sep =
gen/src/Gen/Types/Id.hs+15−13
@@ -64,7 +64,6 @@ import Data.Function (on)
6464import Data.Hashable
6565import Data.List (intersperse)
6666import Data.List (elemIndex, nub, sortOn)
67−import Data.Semigroup hiding (Sum)
6867import Data.String
6968import Data.Text (Text)
7069import qualified Data.Text as Text
@@ -76,10 +75,10 @@ import GHC.Generics (Generic)
7675import Language.Haskell.Exts.Build
7776import Language.Haskell.Exts.Syntax (Exp, Name (..))
7877
79−aname :: Text -> Name
78+aname :: Text -> Name ()
8079aname = name . Text.unpack . (<> "API") . upperHead . Text.replace "." ""
8180
82−mname :: Text -> Suffix -> Global -> (Name, Global, Text)
81+mname :: Text -> Suffix -> Global -> (Name (), Global, Text)
8382mname abrv (Suffix suf) (Global g) =
8483 ( name . Text.unpack $ mconcat n <> suf -- Action service type alias.
8584 , Global n -- Action data type.
@@ -94,13 +93,13 @@ mname abrv (Suffix suf) (Global g) =
9493 e = Text.replace "." "" abrv
9594 x:xs = map (upperAcronym . toPascal) g
9695
97−dname' :: Global -> Name
96+dname' :: Global -> Name ()
9897dname' g =
9998 case dname g of
100− Ident s -> Ident (s <> "'")
101− Symbol s -> Symbol (s <> "'")
99+ Ident () s -> Ident () (s <> "'")
100+ Symbol () s -> Symbol () (s <> "'")
102101
103−dname :: Global -> Name
102+dname :: Global -> Name ()
104103dname = name
105104 . Text.unpack
106105 . renameReserved
@@ -108,7 +107,7 @@ dname = name
108107 . Text.dropWhile separator
109108 . global
110109
111−cname :: Global -> Name
110+cname :: Global -> Name ()
112111cname = name
113112 . Text.unpack
114113 . renameReserved
@@ -117,24 +116,24 @@ cname = name
117116 . lowerFirstAcronym
118117 . global
119118
120−bname :: Prefix -> Text -> Name
119+bname :: Prefix -> Text -> Name ()
121120bname (Prefix p) = name
122121 . Text.unpack
123122 . mappend (Text.toUpper p)
124123 . renameBranch
125124
126−fname, lname, pname :: Prefix -> Local -> Name
125+fname, lname, pname :: Prefix -> Local -> Name ()
127126fname = pre (Text.cons '_' . renameField)
128127lname = pre renameField
129128pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead . renameField)
130129
131−dstr :: Global -> Exp
130+dstr :: Global -> Exp ()
132131dstr = strE . Text.unpack . toPascal . global
133132
134−fstr :: Local -> Exp
133+fstr :: Local -> Exp ()
135134fstr = strE . Text.unpack . local
136135
137−pre :: (Text -> Text) -> Prefix -> Local -> Name
136+pre :: (Text -> Text) -> Prefix -> Local -> Name ()
138137pre f (Prefix p) = name . Text.unpack . f . mappend p . upperHead . local
139138
140139newtype Suffix = Suffix Text
@@ -143,6 +142,9 @@ newtype Suffix = Suffix Text
143142newtype Prefix = Prefix Text
144143 deriving (Show, Monoid)
145144
145+instance Semigroup Prefix where
146+ Prefix a <> Prefix b = Prefix (a <> b)
147+
146148newtype Global = Global { unsafeGlobal :: [Text] }
147149 deriving (Ord, Show, Generic)
148150
gen/src/Gen/Types/NS.hs−1
@@ -14,7 +14,6 @@ module Gen.Types.NS
1414 ) where
1515
1616import Data.Aeson
17−import Data.Semigroup
1817import Data.String
1918import Data.Text (Text)
2019import qualified Data.Text as Text
gen/src/Gen/Types/Schema.hs+3
@@ -60,6 +60,9 @@ deriveJSON options ''Location
6060newtype Ann = Ann { annRequired :: [Local] }
6161 deriving (Eq, Show, Monoid)
6262
63+instance Semigroup Ann where
64+ a <> b = Ann (annRequired a <> annRequired b)
65+
6366deriveJSON options ''Ann
6467
6568data Info = Info
gen/stack.yaml+9−5
@@ -1,11 +1,15 @@
1−resolver: lts-8.18
1+resolver: lts-13.7
22
33flags: {}
44
55extra-deps:
6− - text-regex-replace-0.1.1.1
7− - haskell-src-exts-1.17.1
8− - hindent-4.6.4
6+ - text-regex-replace-0.1.1.3
7+ - ede-0.2.9
8+ - unexceptionalio-0.3.0
9+ - github: chrisdone/hindent
10+ size: 51114
11+ commit: ad0c2a9f8755d37f09b356ab7e45a4e49bcda0b3
12+ sha256: 19954fc7dff3d008d9c7688d1c571999c1869f86e5c115aef8b28c2ae622972f
913
1014packages:
11− - '.'
15+ - "."
stack-8.6.3.yaml+1−1
@@ -1,4 +1,4 @@
1−resolver: lts-13.2
1+resolver: lts-13.7
22
33local-bin-path: bin
44