765a478 · gogol · git.iko.soy

git.iko.soy/gogol

Merge pull request #123 from korayal/upgrade-gen

Upgraded gogol-gen to work with lts-13 (ghc-8.6.3)

commit765a4785dc61fa1c0610dded512494871f327a3a authorMichael Xavier <michael@michaelxavier.net> dateMon 18 Feb 2019, 08:19 (8 years ago) parentb866269 658ad42

17 files changed+369−354

compare with develop

unifiedsplit

gen/gogol-gen.cabal+3−3 gen/src/Gen/AST/Flatten.hs+1−5 gen/src/Gen/AST/Render.hs+32−28 gen/src/Gen/AST/Solve.hs+2−7 gen/src/Gen/Formatting.hs−2 gen/src/Gen/IO.hs+2−2 gen/src/Gen/Orphans.hs+4−4 gen/src/Gen/Syntax.hs+263−239 gen/src/Gen/Text.hs−2 gen/src/Gen/Tree.hs−1 gen/src/Gen/Types/Data.hs+15−22 gen/src/Gen/Types/Help.hs+15−13 gen/src/Gen/Types/Id.hs+16−16 gen/src/Gen/Types/NS.hs−1 gen/src/Gen/Types/Schema.hs+6−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/Flatten.hs+1−5

@@ -1,14 +1,10 @@

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

32{-# LANGUAGE FlexibleContexts #-}

43{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE KindSignatures #-}

74{-# LANGUAGE LambdaCase #-}

85{-# LANGUAGE OverloadedStrings #-}

96{-# LANGUAGE RankNTypes #-}

107{-# LANGUAGE RecordWildCards #-}

11−{-# LANGUAGE TemplateHaskell #-}

128{-# LANGUAGE TupleSections #-}

139

1410-- Module : Gen.AST.Flatten

@@ -136,7 +132,7 @@ resource :: Map Local (Param Global)

136132 -> Resource (Fix Schema)

137133 -> AST (Resource Global)

138134resource qs suf g r@Resource {..} = do

139− rs <- Map.traverseWithKey (\l -> resource qs suf (reference g l)) _rResources

135+ rs <- Map.traverseWithKey (resource qs suf . reference g) _rResources

140136 ms <- traverse (method qs suf) _rMethods

141137 pure $! r

142138 { _rResources = rs

gen/src/Gen/AST/Render.hs+32−28

@@ -1,15 +1,11 @@

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE LambdaCase #-}

5+{-# LANGUAGE OverloadedStrings #-}

6+{-# LANGUAGE RankNTypes #-}

7+{-# LANGUAGE RecordWildCards #-}

8+{-# LANGUAGE ViewPatterns #-}

139

1410-- Module : Gen.AST.Render

@@ -25,18 +21,21 @@ module Gen.AST.Render

2521import Control.Applicative

2622import Control.Error

2723import Control.Lens hiding (enum, lens)

24+import qualified Data.ByteString.Char8 as C8

25+import qualified Data.ByteString.Lazy.Builder as LBB

26+import qualified Data.ByteString.Lazy.Char8 as LBS

2827import Data.Char (isSpace)

2928import qualified Data.HashMap.Strict as Map

3029import Data.Maybe

3130import Data.Semigroup ((<>))

3231import Data.String

3332import qualified Data.Text.Lazy as LText

34−import qualified Data.Text.Lazy.Builder as Build

3533import Gen.AST.Solve (getSolved)

3634import Gen.Formatting

3735import Gen.Syntax

3836import Gen.Types

3937import HIndent

38+import HIndent.Types

4039import Language.Haskell.Exts.Build (name)

4140import Language.Haskell.Exts.Pretty as PP

4241import Prelude hiding (sum)

@@ -131,7 +130,10 @@ renderMethod s root suf m@Method {..} = do

131130 typ <- reserveType typ'

132131

133132 x@Solved {..} <- getSolved typ

134− Just d <- renderSchema x

133+ d' <- renderSchema x

134+ d <- case d' of

135+ Nothing -> error "failed to render the schema"

136+ Just d'' -> pure d''

135137

136138 i <- pp Print $ requestDecl _unique _prefix alias url (props _schema) m

137139 dl <- pp Print $ downloadDecl _unique _prefix alias url (props _schema) m

@@ -170,17 +172,22 @@ data PP

170172

171173pp :: (Pretty a, Show a) => PP -> a -> AST Rendered

172174pp i x

173− | i == Indent = result (reformat johanTibell Nothing p)

174− | otherwise = pure p

175+ | i == Indent = result (reformat hindentConfig Nothing Nothing p)

176+ | otherwise = pure (LText.pack (C8.unpack p))

175177 where

176− result = hoistEither . bimap e Build.toLazyText

178+ result = hoistEither . bimap (e . LText.pack) (LText.pack . LBS.unpack . LBB.toLazyByteString)

177179

178− e = flip mappend ("\nSyntax:\n" <> p <> "\nAST:\n" <> LText.pack (show x)) . LText.pack

180+ e = flip mappend ("\nSyntax:\n" <> LText.pack (C8.unpack p) <> "\nAST:\n" <> LText.pack (show x))

179181

180− p = LText.dropWhile isSpace

181− . LText.pack

182+ p = C8.dropWhile isSpace

183+ . C8.pack

182184 $ prettyPrintStyleMode s m x

183185

186+ hindentConfig = defaultConfig

187+ { configTrailingNewline = False

188+ , configSortImports = False

189+ }

190+

184191 s = style

185192 { mode = PageMode

186193 , lineLength = 80

@@ -197,15 +204,12 @@ pp i x

197204-- FIXME: dirty hack to render smart ctor parameter comments.

198205comments :: Prefix -> Map Local Solved -> Rendered -> Rendered

199206comments p (Map.toList -> rs) =

200− LText.replace " :: " "\n :: "

201− . LText.intercalate "\n -> "

202− . zipWith rel ps

203− . map LText.strip

204− . LText.splitOn "->"

207+ LText.replace " :: " "\n :: " .

208+ LText.intercalate "\n -> " .

209+ zipWith rel ps . map LText.strip . LText.splitOn "->"

205210 where

206211 ks = filter (parameter . _schema . snd) rs

207212 ps = map (Just . fst) ks ++ repeat Nothing

208−

209− rel Nothing t = t

213+ rel Nothing t = t

210214 rel (Just l) t =

211− t <> " -- ^ '" <> fromString (PP.prettyPrint (lname p l)) <> "'"

215+ t <> " -- ^ '" <> fromString (PP.prettyPrint (lname p l)) <> "'"

gen/src/Gen/AST/Solve.hs+2−7

@@ -1,14 +1,9 @@

11{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

32{-# LANGUAGE FlexibleContexts #-}

43{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE KindSignatures #-}

74{-# LANGUAGE LambdaCase #-}

85{-# LANGUAGE OverloadedStrings #-}

96{-# LANGUAGE RankNTypes #-}

10−{-# LANGUAGE RecordWildCards #-}

11−{-# LANGUAGE TemplateHaskell #-}

127{-# LANGUAGE ViewPatterns #-}

138

149-- Module : Gen.AST.Solve

@@ -94,7 +89,7 @@ getType g = loc "getType" g $ memo typed g go

9489 --- FIXME: add natural/numeric manipulations

9590 SLit _ l -> res (TLit l)

9691 SEnm {} -> res (TType g)

97− SArr _ (Arr e) -> (TList <$> (getType e)) >>= pure . may

92+ SArr _ (Arr e) -> may <$> (TList <$> getType e)

9893 SObj {} -> res (TType g)

9994 SRef _ r

10095 | ref r /= g -> req <$> getType (ref r)

@@ -195,7 +190,7 @@ overlap :: (Eq a, Hashable a) => Set a -> Set a -> Bool

195190overlap xs ys = not . Set.null $ Set.intersection xs ys

196191

197192acronymPrefixes :: Global -> [CI Text]

198−acronymPrefixes (global -> renameSpecial -> g) =

193+acronymPrefixes (global -> (renameSpecial -> g)) =

199194 filter (/= full) $ map CI.mk (xs ++ map suffix ys ++ zs)

200195 where

201196 -- Take the next char

gen/src/Gen/Formatting.hs−2

@@ -1,5 +1,3 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−

31-- Module : Gen.Formatting

53-- License : Mozilla Public License, v. 2.0.

gen/src/Gen/IO.hs+2−2

@@ -1,6 +1,5 @@

11{-# LANGUAGE FlexibleContexts #-}

22{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE TupleSections #-}

54-- Module : Gen.IO

@@ -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+263−239

@@ -1,6 +1,5 @@

11{-# LANGUAGE LambdaCase #-}

22{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE TupleSections #-}

43{-# LANGUAGE ViewPatterns #-}

65-- Module : Gen.Syntax

@@ -26,39 +25,38 @@ import Gen.Text

2625import Gen.Types

2726import Language.Haskell.Exts.Build (app, appFun, infixApp, lamE, listE, name, noBinds, paren, patBind, pvar, sfun, strE, sym,

2827 var)

29−import Language.Haskell.Exts.SrcLoc

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

3129

32−serviceSig :: Name -> Decl

33−serviceSig n = TypeSig noLoc [n] (TyCon "ServiceConfig")

30+serviceSig :: Name () -> Decl ()

31+serviceSig n = TypeSig () [n] (TyCon () "ServiceConfig")

3432

35−serviceDecl :: Service a -> Name -> Decl

36−serviceDecl s n = sfun noLoc n [] (UnGuardedRhs rhs) noBinds

33+serviceDecl :: Service a -> Name () -> Decl ()

34+serviceDecl s n = sfun n [] (UnGuardedRhs () rhs) noBinds

3735 where

3836 rhs = appFun (var "defaultService")

3937 [ app (var "ServiceId") (str (s ^. dId))

4038 , str . stripSuffix "/" $ stripPrefix "https://" (s ^. dRootUrl)

4139 ]

4240

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)

41+scopeSig :: Name () -> Text -> Decl ()

42+scopeSig n v = TypeSig () [n] $

43+ TyApp () (TyCon () "Proxy") $

44+ TyPromoted () $ PromotedList () True

45+ [ TyPromoted () $ PromotedString () (Text.unpack v) (Text.unpack v)

4846 ]

4947

50−scopeDecl :: Name -> Decl

51−scopeDecl n = sfun noLoc n [] (UnGuardedRhs (var "Proxy")) noBinds

48+scopeDecl :: Name () -> Decl ()

49+scopeDecl n = sfun n [] (UnGuardedRhs () (var "Proxy")) noBinds

5250

53−apiAlias :: Name -> [Name] -> Decl

54−apiAlias n ls = TypeDecl noLoc n [] alias

51+apiAlias :: Name () -> [Name ()] -> Decl ()

52+apiAlias n ls = TypeDecl () (DHead () n) alias

5553 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

54+ alias = case map (TyCon () . UnQual ()) ls of

55+ [] -> unit_tycon ()

56+ x:xs -> foldl' (\l r -> TyInfix () l ((UnpromotedName () . UnQual ()) (sym ":<|>")) r) x xs

5957

60−verbAlias :: HasDescription a s => a -> Name -> Method Solved -> Decl

61−verbAlias d n m = TypeDecl noLoc n [] $ servantOr meta (catMaybes [down, up])

58+verbAlias :: HasDescription a s => a -> Name () -> Method Solved -> Decl ()

59+verbAlias d n m = TypeDecl () (DHead () n) $ servantOr meta (catMaybes [down, up])

6260 where

6361 meta = path $ metadataAlias m

6462 down = path <$> downloadAlias m

@@ -68,18 +66,18 @@ verbAlias d n m = TypeDecl noLoc n [] $ servantOr meta (catMaybes [down, up])

6866

6967 root = subPaths (d ^. dServicePath) ++ requestPath m (_mPath m)

7068

71−metadataAlias :: Method Solved -> Type

69+metadataAlias :: Method Solved -> Type ()

7270metadataAlias m = servantSub (jsonVerb m) (params ++ media)

7371 where

7472 params = requestQuery m (requestQueryParams m)

7573 media = case _mRequest m of

7674 Nothing -> []

7775 Just b ->

78− [ TyApp (TyApp (TyCon "ReqBody") jsonMedia)

76+ [ TyApp () (TyApp () (TyCon () "ReqBody") jsonMedia)

7977 (tycon (ref b))

8078 ]

8179

82−downloadAlias :: Method Solved -> Maybe Type

80+downloadAlias :: Method Solved -> Maybe (Type ())

8381downloadAlias m

8482 | _mSupportsMediaDownload m = Just download

8583 | otherwise = Nothing

@@ -88,7 +86,7 @@ downloadAlias m

8886

8987 params = requestQuery m . Map.delete "alt" $ requestQueryParams m

9088

91−uploadAlias :: [Type] -> Method Solved -> Maybe Type

89+uploadAlias :: [Type ()] -> Method Solved -> Maybe (Type ())

9290uploadAlias sub m

9391 | _mSupportsMediaUpload m = Just upload

9492 | otherwise = Nothing

@@ -104,16 +102,16 @@ uploadAlias sub m

104102 media = case _mRequest m of

105103 Just b ->

106104 [ multipartParam

107− , TyApp (TyApp (TyCon "MultipartRelated") jsonMedia)

105+ , TyApp () (TyApp () (TyCon () "MultipartRelated") jsonMedia)

108106 (tycon (ref b))

109107 ]

110108

111109 Nothing ->

112110 [ mediaParam

113− , TyCon "AltMedia"

111+ , TyCon () "AltMedia"

114112 ]

115113

116−requestPath :: Method Solved -> Text -> [Type]

114+requestPath :: Method Solved -> Text -> [Type ()]

117115requestPath m = map go . extractPath

118116 where

119117 go (Left t) = sing t

@@ -121,29 +119,29 @@ requestPath m = map go . extractPath

121119 Nothing -> error $ "Unable to find path parameter " ++ show l

122120 Just x -> case c of

123121 Nothing | x ^. iRepeated ->

124− TyApp (TyApp (TyCon "Captures")

122+ TyApp () (TyApp () (TyCon () "Captures")

125123 (sing (local l)))

126124 (terminalType (_type (_pParam x)))

127125

128126 Nothing ->

129− TyApp (TyApp (TyCon "Capture")

127+ TyApp () (TyApp () (TyCon () "Capture")

130128 (sing (local l)))

131129 (terminalType (_type (_pParam x)))

132130

133131 Just y ->

134− TyApp (TyApp (TyApp (TyCon "CaptureMode")

132+ TyApp () (TyApp () (TyApp () (TyCon () "CaptureMode")

135133 (sing (local l)))

136134 (sing y))

137135 (terminalType (_type (_pParam x)))

138136

139−requestQuery :: Method Solved -> Map Local (Param Solved) -> [Type]

137+requestQuery :: Method Solved -> Map Local (Param Solved) -> [Type ()]

140138requestQuery m xs = mapMaybe go $

141139 orderParams fst (Map.toList xs) (_mParameterOrder m)

142140 where

143141 go (k, x) = case _pLocation x of

144142 Query | x ^. iRepeated

145− -> Just $ TyApp (TyApp (TyCon "QueryParams") n) t

146− Query -> Just $ TyApp (TyApp (TyCon "QueryParam") n) t

143+ -> Just $ TyApp () (TyApp () (TyCon () "QueryParams") n) t

144+ Query -> Just $ TyApp () (TyApp () (TyCon () "QueryParam") n) t

147145 Path -> Nothing

148146 where

149147 t = terminalType (_type (_pParam x))

@@ -152,52 +150,47 @@ requestQuery m xs = mapMaybe go $

152150requestQueryParams :: Method a -> Map Local (Param a)

153151requestQueryParams = Map.filter ((/= Path) . _pLocation) . _mParameters

154152

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)

153+servantOr, servantSub :: Type () -> [Type ()] -> Type ()

154+servantOr = foldl' (\l r -> TyInfix () l ((UnpromotedName () . UnQual ()) (sym ":<|>")) r)

155+servantSub = foldr' (\l r -> TyInfix () l ((UnpromotedName () . UnQual ()) (sym ":>")) r)

158156

159−jsonVerb :: Method a -> Type

157+jsonVerb :: Method a -> Type ()

160158jsonVerb m =

161− TyApp (TyApp (httpMethod m) jsonMedia)

162− $ maybe (TyCon "()") (tycon . ref) (_mResponse m)

159+ TyApp () (TyApp () (httpMethod m) jsonMedia)

160+ $ maybe (TyCon () "()") (tycon . ref) (_mResponse m)

163161

164−downloadVerb :: Method a -> Type

162+downloadVerb :: Method a -> Type ()

165163downloadVerb m =

166− TyApp (TyApp (httpMethod m) streamMedia)

167− (TyCon "Stream")

164+ TyApp () (TyApp () (httpMethod m) streamMedia)

165+ (TyCon () "Stream")

168166

169−httpMethod :: Method a -> Type

170−httpMethod = TyCon . unqual . Text.unpack . Text.toTitle . _mHttpMethod

167+httpMethod :: Method a -> Type ()

168+httpMethod = TyCon () . unqual . Text.unpack . Text.toTitle . _mHttpMethod

171169

172−subPaths :: Text -> [Type]

170+subPaths :: Text -> [Type ()]

173171subPaths = map sing . filter (not . Text.null) . Text.split (== '/')

174172

175−jsonMedia, streamMedia :: Type

173+jsonMedia, streamMedia :: Type ()

176174jsonMedia = tylist ["JSON"]

177175streamMedia = tylist ["OctetStream"]

178176

179−downloadParam :: Type

177+downloadParam :: Type ()

180178downloadParam =

181− TyApp (TyApp (TyCon "QueryParam") (sing "alt"))

182− (TyCon "AltMedia")

179+ TyApp () (TyApp () (TyCon () "QueryParam") (sing "alt"))

180+ (TyCon () "AltMedia")

183181

184−mediaParam :: Type

182+mediaParam :: Type ()

185183mediaParam =

186− TyApp (TyApp (TyCon "QueryParam") (sing "uploadType"))

187− (TyCon "AltMedia")

184+ TyApp () (TyApp () (TyCon () "QueryParam") (sing "uploadType"))

185+ (TyCon () "AltMedia")

188186

189−multipartParam :: Type

187+multipartParam :: Type ()

190188multipartParam =

191− TyApp (TyApp (TyCon "QueryParam") (sing "uploadType"))

192− (TyCon "Multipart")

189+ TyApp () (TyApp () (TyCon () "QueryParam") (sing "uploadType"))

190+ (TyCon () "Multipart")

193191

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

192+pattern' :: Integer -> Method a -> Pat ()

193+pattern' n m = case (n, down, up) of

201194 (1, True, True) -> infixOr go (infixOr wild wild)

202195 (2, True, True) -> infixOr wild (infixOr go wild)

203196 (_, True, True) -> infixOr wild (infixOr wild go)

@@ -214,51 +207,57 @@ pattern n m = case (n, down, up) of

214207 up = _mSupportsMediaUpload m

215208

216209 go = pvar "go"

217− wild = PWildCard

210+ wild = PWildCard ()

211+

212+ infixOr l = PInfixApp () l (UnQual () (sym ":<|>"))

213+

214+metadataPat, downloadPat, uploadPat :: Method a -> Pat ()

215+metadataPat = pattern' 1

216+downloadPat = pattern' 2

217+uploadPat = pattern' 3

218218

219− infixOr l r = PInfixApp l (UnQual (sym ":<|>")) r

220219

221220downloadDecl :: Global

222221 -> Prefix

223− -> Name

224− -> Name

222+ -> Name ()

223+ -> Name ()

225224 -> [Local]

226225 -> Method Solved

227− -> Decl

226+ -> Decl ()

228227downloadDecl n pre api url fs m =

229− googleRequestDecl ty [rs, ss] [alt] pre api url m pat prec

228+ googleRequestDecl (TyParen () ty) [rs, ss] [alt] pre api url m pat prec

230229 where

231− ty = TyApp (TyCon "MediaDownload") (tycon n)

230+ ty = TyApp () (TyCon () "MediaDownload") (tycon n)

232231

233− rs = InsType noLoc (TyApp (TyCon "Rs") ty) (TyCon "Stream")

232+ rs = InsType () (TyApp () (TyCon () "Rs") ty) (TyCon () "Stream")

234233

235− ss = InsType noLoc (TyApp (TyCon "Scopes") ty) $

236− TyApp (TyCon "Scopes") (tycon n)

234+ ss = InsType () (TyApp () (TyCon () "Scopes") ty) $

235+ TyApp () (TyCon () "Scopes") (tycon n)

237236

238237 alt = app (var "Just") (var "AltMedia")

239238 pat = downloadPat m

240239

241− prec = PApp (UnQual "MediaDownload")

242− [ PRec (UnQual (dname' n)) [PFieldWildcard | not (null fs)]

240+ prec = PApp () (UnQual () "MediaDownload")

241+ [ PRec () (UnQual () (dname' n)) [PFieldWildcard () | not (null fs)]

243242 ]

244243

245244uploadDecl :: Global

246245 -> Prefix

247− -> Name

248− -> Name

246+ -> Name ()

247+ -> Name ()

249248 -> [Local]

250249 -> Method Solved

251− -> Decl

250+ -> Decl ()

252251uploadDecl n pre api url fs m =

253− googleRequestDecl ty [rs, ss] extras pre api url m pat prec

252+ googleRequestDecl (TyParen () ty) [rs, ss] extras pre api url m pat prec

254253 where

255− ty = TyApp (TyCon "MediaUpload") (tycon n)

254+ ty = TyApp () (TyCon () "MediaUpload") (tycon n)

256255

257− rs = InsType noLoc (TyApp (TyCon "Rs") ty) $

258− maybe unit_tycon (tycon . ref) (_mResponse m)

256+ rs = InsType () (TyApp () (TyCon () "Rs") ty) $

257+ maybe (unit_tycon ()) (tycon . ref) (_mResponse m)

259258

260− ss = InsType noLoc (TyApp (TyCon "Scopes") ty) $

261− TyApp (TyCon "Scopes") (tycon n)

259+ ss = InsType () (TyApp () (TyCon () "Scopes") ty) $

260+ TyApp () (TyCon () "Scopes") (tycon n)

262261

263262 extras = maybeToList alt ++ [upl] ++ payload ++ [var media]

264263 where

@@ -276,30 +275,32 @@ uploadDecl n pre api url fs m =

276275

277276 pat = uploadPat m

278277

279− prec = PApp (UnQual "MediaUpload")

280− [ PRec (UnQual (dname' n)) [PFieldWildcard | not (null fs)]

281− , PVar media

278+ prec = PApp () (UnQual () "MediaUpload")

279+ [ PRec () (UnQual () (dname' n)) [PFieldWildcard () | not (null fs)]

280+ , PVar () media

282281 ]

283282

284283 media = name "body"

285284

286285requestDecl :: Global

287286 -> Prefix

288− -> Name

289− -> Name

287+ -> Name ()

288+ -> Name ()

290289 -> [Local]

291290 -> Method Solved

292− -> Decl

291+ -> Decl ()

293292requestDecl n pre api url fs m =

294293 googleRequestDecl (tycon n) [rs, ss] extras pre api url m pat prec

295294 where

296− rs = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $

297− maybe unit_tycon (tycon . ref) (_mResponse m)

295+ rs :: InstDecl ()

296+ rs = InsType () (TyApp () (TyCon () "Rs") (tycon n)) $

297+ maybe (unit_tycon ()) (tycon . ref) (_mResponse m)

298298

299− ss = InsType noLoc (TyApp (TyCon "Scopes") (tycon n)) $

300− TyPromoted $

301− PromotedList True $

302− map (TyPromoted . PromotedString . Text.unpack) (_mScopes m)

299+ ss :: InstDecl ()

300+ ss = InsType () (TyApp () (TyCon () "Scopes") (tycon n)) $

301+ TyPromoted () $

302+ PromotedList () True $

303+ map (\m' -> TyPromoted () (PromotedString () (Text.unpack m') "Scopes")) (_mScopes m)

303304

304305 extras = catMaybes [alt, payload]

305306 where

@@ -312,35 +313,35 @@ requestDecl n pre api url fs m =

312313

313314 pat = metadataPat m

314315

315− prec = PRec (UnQual (dname' n)) [PFieldWildcard | not (null fs)]

316+ prec = PRec () (UnQual () (dname' n)) [PFieldWildcard () | not (null fs)]

316317

317−googleRequestDecl :: Type

318− -> [InstDecl]

319− -> [Exp]

318+googleRequestDecl :: Type ()

319+ -> [InstDecl ()]

320+ -> [Exp ()]

320321 -> Prefix

321− -> Name

322− -> Name

322+ -> Name ()

323+ -> Name ()

323324 -> Method Solved

324− -> Pat

325− -> Pat

326− -> Decl

325+ -> Pat ()

326+ -> Pat ()

327+ -> Decl ()

327328googleRequestDecl n assoc extras pre api url m pat prec =

328− InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [n] (assoc ++ [request])

329+ InstDecl () Nothing (instrule "GoogleRequest" n) (Just (assoc ++ [request]))

329330 where

330− request = InsDecl (FunBind [match])

331+ request = InsDecl () (FunBind () [match])

331332

332− match = Match noLoc (name "requestClient") [prec] Nothing rhs (Just decls)

333+ match = Match () (name "requestClient") [prec] rhs (Just decls)

333334

334− decls = BDecls

335− [ patBind noLoc pat $

336− appFun (var "buildClient") $

337− [ ExpTypeSig noLoc (var "Proxy") $

338− TyApp (TyCon "Proxy") (TyCon (UnQual api))

335+ decls = BDecls ()

336+ [ patBind pat $

337+ appFun (var "buildClient")

338+ [ ExpTypeSig () (var "Proxy") $

339+ TyApp () (TyCon () "Proxy") (TyCon () (UnQual () api))

339340 , var "mempty"

340341 ]

341342 ]

342343

343− rhs = UnGuardedRhs . appFun (var "go") $ map go fs ++ extras ++ [var url]

344+ rhs = UnGuardedRhs () . appFun (var "go") $ map go fs ++ extras ++ [var url]

344345 where

345346 go l = case Map.lookup l ps of

346347 Just p | _pLocation p == Query

@@ -365,16 +366,15 @@ googleRequestDecl n assoc extras pre api url m pat prec =

365366 . nub

366367 $ map fst (rights (extractPath (_mPath m))) ++ _mParameterOrder m

367368

368−jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]

369+jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl ()]

369370jsonDecls g p (Map.toList -> rs) = [from', to']

370371 where

371− from' = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon g]

372+ from' = InstDecl () Nothing (instrule "FromJSON" (tycon g)) (Just

372373 [ funD "parseJSON" $

373374 app (app (var "withObject") (dstr g)) $

374− lamE noLoc [pvar "o"] $

375+ lamE [pvar "o"] $

375376 ctorE g (map decode rs)

376− ]

377−

377+ ])

378378 decode (l, s)

379379 | _additional s = app (var "parseJSONObject") (var "o")

380380 | Just x <- def s = defJS l x

@@ -384,15 +384,15 @@ jsonDecls g p (Map.toList -> rs) = [from', to']

384384

385385 to' = case rs of

386386 [(k, v)] | _additional v ->

387− InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]

387+ InstDecl () Nothing (instrule "ToJSON" (tycon g)) (Just

388388 [ funD "toJSON" $

389389 infixApp (var "toJSON") "." (var (fname p k))

390− ]

390+ ])

391391

392392 _ ->

393− InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]

393+ InstDecl () Nothing (instrule "ToJSON" (tycon g)) (Just

394394 [ wildcardD "toJSON" g omit emptyObj (map encode rs)

395− ]

395+ ])

396396

397397 omit = app (var "object")

398398 . app (var "catMaybes")

@@ -410,81 +410,99 @@ jsonDecls g p (Map.toList -> rs) = [from', to']

410410

411411wildcardD :: String

412412 -> Global

413− -> ([Exp] -> Exp)

414− -> Exp

415− -> [Exp]

416− -> InstDecl

413+ -> ([Exp ()] -> Exp ())

414+ -> Exp ()

415+ -> [Exp ()]

416+ -> InstDecl ()

417417wildcardD f n enc x = \case

418418 [] -> constD f x

419− xs -> InsDecl (FunBind [match prec xs])

419+ xs -> InsDecl () (FunBind () [match prec xs])

420420 where

421421 match p es =

422− Match noLoc (name f) [p] Nothing (UnGuardedRhs (enc es)) noBinds

422+ Match () (name f) [p] (UnGuardedRhs () (enc es)) noBinds

423423

424− prec = PRec (UnQual (dname' n)) [PFieldWildcard]

424+ prec = PRec () (UnQual () (dname' n)) [PFieldWildcard ()]

425425

426−defJS :: Local -> Exp -> Exp

427−defJS n x = infixApp (infixApp (var "o") ".:?" (fstr n)) ".!=" x

426+defJS :: Local -> Exp () -> Exp ()

427+defJS n = infixApp (infixApp (var "o") ".:?" (fstr n)) ".!="

428428

429−reqJS :: Local -> Exp

429+reqJS :: Local -> Exp ()

430430reqJS = infixApp (var "o") ".:" . fstr

431431

432−optJS :: Local -> Exp

432+optJS :: Local -> Exp ()

433433optJS = infixApp (var "o") ".:?" . fstr

434434

435−funD :: String -> Exp -> InstDecl

436−funD f = InsDecl . patBind noLoc (pvar (name f))

435+funD :: String -> Exp () -> InstDecl ()

436+funD f = InsDecl () . patBind (pvar (name f))

437437

438−constD :: String -> Exp -> InstDecl

439−constD f x = InsDecl $

440− sfun noLoc (name f) [] (UnGuardedRhs (app (var "const") x)) noBinds

438+constD :: String -> Exp () -> InstDecl ()

439+constD f x = InsDecl () $

440+ sfun (name f) [] (UnGuardedRhs () (app (var "const") x)) noBinds

441441

442−ctorE :: Global -> [Exp] -> Exp

442+ctorE :: Global -> [Exp ()] -> Exp ()

443443ctorE n = seqE (var (dname' n)) . map paren

444444

445−seqE :: Exp -> [Exp] -> Exp

445+seqE :: Exp () -> [Exp ()] -> Exp ()

446446seqE l [] = app (var "pure") l

447447seqE l (r:rs) = infixApp l "<$>" (infixE r "<*>" rs)

448448

449−objDecl :: Global -> Prefix -> [Derive] -> Map Local Solved -> Decl

449+objDecl :: Global -> Prefix -> [Derive] -> Map Local Solved -> Decl ()

450450objDecl n p ds rs =

451− DataDecl noLoc arity [] (dname n) [] [conDecl (dname' n) p rs] (der ds)

451+ DataDecl () arity Nothing (DHead () (dname n)) [conDecl (dname' n) p rs] [der ds]

452452 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

453+ arity | Map.size rs == 1 = NewType ()

454+ | otherwise = DataType ()

455+

456+ der = Deriving () Nothing . map (unqualrule . drop 1 . show)

457+

458+-- decl =

459+-- DataDecl

460+-- ()

461+-- (DataType ())

462+-- Nothing

463+-- (DHead () (Ident () "AboutGet"))

464+-- [QualConDecl () Nothing Nothing (ConDecl () (Ident () "AboutGet'") [])]

465+-- [ Deriving

466+-- ()

467+-- Nothing

468+-- [ IRule () Nothing Nothing (IHCon () (UnQual () (Ident () "Eq")))

469+-- , IRule () Nothing Nothing (IHCon () (UnQual () (Ident () "Show")))

470+-- , IRule () Nothing Nothing (IHCon () (UnQual () (Ident () "Data")))

471+-- , IRule () Nothing Nothing (IHCon () (UnQual () (Ident () "Typeable")))

472+-- , IRule () Nothing Nothing (IHCon () (UnQual () (Ident () "Generic")))

473+-- ]

474+-- ]

475+

476+conDecl :: Name () -> Prefix -> Map Local Solved -> QualConDecl ()

477+conDecl n p rs = QualConDecl () Nothing Nothing body

460478 where

461479 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)

480+ [] -> ConDecl () n []

481+ [x] -> RecDecl () n [field internalType x]

482+ xs -> RecDecl () n (map (field (strict . internalType)) xs)

465483

466− field f (l, v) = ([fname p l], f (_type v))

484+ field f (l, v) = FieldDecl () [fname p l] (f (_type v))

467485

468−ctorSig :: Global -> Map Local Solved -> Decl

469−ctorSig n rs = TypeSig noLoc [cname n] ts

486+ctorSig :: Global -> Map Local Solved -> Decl ()

487+ctorSig n rs = TypeSig () [cname n] ts

470488 where

471− ts = foldr' TyFun (TyCon (UnQual (dname n))) ps

489+ ts = foldr' (TyFun ()) (TyCon () (UnQual () (dname n))) ps

472490 ps = parameters (Map.elems rs)

473491

474−ctorDecl :: Global -> Prefix -> Map Local Solved -> Decl

475−ctorDecl n p rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds

492+ctorDecl :: Global -> Prefix -> Map Local Solved -> Decl ()

493+ctorDecl n p rs = sfun c ps (UnGuardedRhs () rhs) noBinds

476494 where

477495 c = cname n

478496 d = dname' n

479497

480498 rhs | Map.null rs = var d

481− | otherwise = RecConstr (UnQual d) $

499+ | otherwise = RecConstr () (UnQual () d) $

482500 map (uncurry (fieldUpdate p)) (Map.toList rs)

483501

484502 ps = map (pname p) . Map.keys $ Map.filter parameter rs

485503

486−fieldUpdate :: Prefix -> Local -> Solved -> FieldUpdate

487−fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs

504+fieldUpdate :: Prefix -> Local -> Solved -> FieldUpdate ()

505+fieldUpdate p l s = FieldUpdate () (UnQual () (fname p l)) rhs

488506 where

489507 rhs | Just x <- def s, s ^. iRepeated = listE [x]

490508 | Just x <- def s = x

@@ -494,26 +512,26 @@ fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs

494512

495513 v = var (pname p l)

496514

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))

515+lensSig :: Global -> Prefix -> Local -> Solved -> Decl ()

516+lensSig n p l s = TypeSig () [lname p l] $

517+ TyApp () (TyApp () (TyCon () "Lens'") (tycon n))

500518 (externalType (_type s))

501519

502−lensDecl :: Prefix -> Local -> Solved -> Decl

503−lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds

520+lensDecl :: Prefix -> Local -> Solved -> Decl ()

521+lensDecl p l s = sfun (lname p l) [] (UnGuardedRhs () rhs) noBinds

504522 where

505523 f = fname p l

506524 t = _type s

507525

508526 rhs = mapping t $

509527 app (app (var "lens") (var f))

510− (paren (lamE noLoc [pvar "s", pvar "a"]

511− (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))

528+ (paren (lamE [pvar "s", pvar "a"]

529+ (RecUpdate () (var "s") [FieldUpdate () (UnQual () f) (var "a")])))

512530

513−parameters :: [Solved] -> [Type]

531+parameters :: [Solved] -> [Type ()]

514532parameters = map (externalType . _type) . filter parameter

515533

516−def :: Solved -> Maybe Exp

534+def :: Solved -> Maybe (Exp ())

517535def s

518536 | Just x <- s ^. iDefault = Just (go x (_prefix s) (_schema s))

519537 | otherwise = Nothing

@@ -527,88 +545,88 @@ def s

527545

528546 lit = var . name . Text.unpack

529547

530−terminalType :: TType -> Type

548+terminalType :: TType -> Type ()

531549terminalType = internalType . go

532550 where

533551 go (TMaybe x) = go x

534552 go (TList x) = go x

535553 go x = x

536554

537−externalType :: TType -> Type

555+externalType :: TType -> Type ()

538556externalType = \case

539557 TType r -> tycon r

540558 TMaybe t@TList {} -> externalType t

541− TMaybe t -> TyApp (TyCon "Maybe") (externalType t)

542− TList t -> TyList (externalType t)

559+ TMaybe t -> TyApp () (TyCon () "Maybe") (externalType t)

560+ TList t -> TyList () (externalType t)

543561 TLit l -> externalLit l

544562 TMap k v ->

545− TyApp (TyApp (TyCon "HashMap") (externalType k)) (externalType (require v))

563+ TyApp () (TyApp () (TyCon () "HashMap") (externalType k)) (externalType (require v))

546564

547−internalType :: TType -> Type

565+internalType :: TType -> Type ()

548566internalType = \case

549567 TType r -> tycon r

550− TMaybe t -> TyApp (TyCon "Maybe") (internalType t)

551− TList t -> TyList (internalType t)

568+ TMaybe t -> TyApp () (TyCon () "Maybe") (internalType t)

569+ TList t -> TyList () (internalType t)

552570 TLit l -> internalLit l

553571 TMap k v ->

554− TyApp (TyApp (TyCon "HashMap") (internalType k)) (internalType (require v))

572+ TyApp () (TyApp () (TyCon () "HashMap") (internalType k)) (internalType (require v))

555573

556−externalLit :: Lit -> Type

574+externalLit :: Lit -> Type ()

557575externalLit = \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

576+ Text -> TyCon () "Text"

577+ Bool -> TyCon () "Bool"

578+ Time -> TyCon () "TimeOfDay"

579+ Date -> TyCon () "Day"

580+ DateTime -> TyCon () "UTCTime"

581+ Nat -> TyCon () "Natural"

582+ Float -> TyCon () "Double"

583+ Double -> TyCon () "Double"

584+ Byte -> TyCon () "ByteString"

585+ UInt32 -> TyCon () "Word32"

586+ UInt64 -> TyCon () "Word64"

587+ Int32 -> TyCon () "Int32"

588+ Int64 -> TyCon () "Int64"

589+ Alt t -> TyCon () (unqual (Text.unpack t))

590+ RqBody -> TyCon () "RequestBody"

591+ RsBody -> TyCon () "Stream"

592+ JSONValue -> TyCon () "JSONValue"

593+ GFieldMask -> TyCon () "GFieldMask"

594+ GDuration -> TyCon () "Scientific"

595+

596+internalLit :: Lit -> Type ()

579597internalLit = \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

598+ Text -> TyCon () "Text"

599+ Bool -> TyCon () "Bool"

600+ Time -> TyCon () "Time'"

601+ Date -> TyCon () "Date'"

602+ DateTime -> TyCon () "DateTime'"

603+ Nat -> TyApp () (TyCon () "Textual") (TyCon () "Nat")

604+ Float -> TyApp () (TyCon () "Textual") (TyCon () "Double")

605+ Double -> TyApp () (TyCon () "Textual") (TyCon () "Double")

606+ Byte -> TyCon () "Bytes"

607+ UInt32 -> TyApp () (TyCon () "Textual") (TyCon () "Word32")

608+ UInt64 -> TyApp () (TyCon () "Textual") (TyCon () "Word64")

609+ Int32 -> TyApp () (TyCon () "Textual") (TyCon () "Int32")

610+ Int64 -> TyApp () (TyCon () "Textual") (TyCon () "Int64")

611+ Alt t -> TyCon () (unqual (Text.unpack t))

612+ RqBody -> TyCon () "RequestBody"

613+ RsBody -> TyCon () "Stream"

614+ JSONValue -> TyCon () "JSONValue"

615+ GFieldMask -> TyCon () "GFieldMask"

616+ GDuration -> TyCon () "GDuration"

617+

618+mapping :: TType -> Exp () -> Exp ()

601619mapping t e = infixE e "." (go t)

602620 where

603621 go = \case

604− TMaybe x@(TList {}) -> var "_Default" : go x

605− TMaybe x -> nest (go x)

606− x -> maybeToList (iso x)

622+ TMaybe x@TList {} -> var "_Default" : go x

623+ TMaybe x -> nest (go x)

624+ x -> maybeToList (iso x)

607625

608626 nest [] = []

609627 nest (x:xs) = [app (var "mapping") (infixE x "." xs)]

610628

611−iso :: TType -> Maybe Exp

629+iso :: TType -> Maybe (Exp ())

612630iso = \case

613631 TList {} -> Just (var "_Coerce")

614632 TMap {} -> Just (var "_Coerce")

@@ -630,27 +648,33 @@ require :: TType -> TType

630648require (TMaybe t) = t

631649require t = t

632650

633−strict :: Type -> Type

634−strict = TyBang BangedTy . \case

635− t@TyApp{} -> TyParen t

651+strict :: Type () -> Type ()

652+strict = TyBang () (BangedTy ()) (NoUnpackPragma ()) . \case

653+ t@TyApp{} -> TyParen () t

636654 t -> t

637655

638−sing :: Text -> Type

639−sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""

656+sing :: Text -> Type ()

657+sing = TyCon () . unqual . Text.unpack . flip mappend "\"" . mappend "\""

640658

641−tylist :: [Text] -> Type

642−tylist xs = TyCon . UnQual . name . Text.unpack $

659+tylist :: [Text] -> Type ()

660+tylist xs = TyCon () . UnQual () . name . Text.unpack $

643661 "'[" <> Text.intercalate ", " xs <> "]"

644662

645−tycon :: Global -> Type

646−tycon = TyCon . UnQual . dname

663+tycon :: Global -> Type ()

664+tycon = TyCon () . UnQual () . dname

665+

666+unqual :: String -> QName ()

667+unqual = UnQual () . name

668+

669+unqualrule :: String -> InstRule ()

670+unqualrule = IRule () Nothing Nothing . IHCon () . unqual

647671

648−unqual :: String -> QName

649−unqual = UnQual . name

672+instrule :: String -> Type () -> InstRule ()

673+instrule n t = IRule () Nothing Nothing (IHApp () (IHCon () (unqual n)) t)

650674

651−infixE :: Exp -> QOp -> [Exp] -> Exp

675+infixE :: Exp () -> QOp () -> [Exp ()] -> Exp ()

652676infixE l _ [] = l

653677infixE l o (r:rs) = infixE (infixApp l o r) o rs

654678

655−str :: Text -> Exp

679+str :: Text -> Exp ()

656680str = strE . Text.unpack

gen/src/Gen/Text.hs−2

@@ -1,5 +1,4 @@

11{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE TupleSections #-}

43-- Module : Gen.Text

@@ -19,7 +18,6 @@ import Data.Char

1918import qualified Data.Foldable as Fold

2019import qualified Data.HashMap.Strict as Map

2120import qualified Data.HashSet as Set

22−import Data.Monoid

2321import Data.String

2422import Data.Text (Text)

2523import qualified Data.Text as Text

gen/src/Gen/Tree.hs−1

@@ -5,7 +5,6 @@

55{-# LANGUAGE MultiParamTypeClasses #-}

66{-# LANGUAGE OverloadedStrings #-}

77{-# LANGUAGE RecordWildCards #-}

8−{-# LANGUAGE TupleSections #-}

98{-# LANGUAGE ViewPatterns #-}

109

1110-- Module : Gen.Tree

gen/src/Gen/Types/Data.hs+15−22

@@ -1,17 +1,10 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveFoldable #-}

3−{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE DeriveTraversable #-}

6−{-# LANGUAGE ExtendedDefaultRules #-}

7−{-# LANGUAGE FlexibleContexts #-}

8−{-# LANGUAGE FlexibleInstances #-}

9−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

10−{-# LANGUAGE KindSignatures #-}

11−{-# LANGUAGE LambdaCase #-}

12−{-# LANGUAGE OverloadedStrings #-}

13−{-# LANGUAGE RecordWildCards #-}

14−{-# LANGUAGE TemplateHaskell #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE ExtendedDefaultRules #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE LambdaCase #-}

6+{-# LANGUAGE OverloadedStrings #-}

7+{-# LANGUAGE RecordWildCards #-}

158

169{-# OPTIONS_GHC -fno-warn-type-defaults #-}

1710

@@ -42,12 +35,12 @@ default (Text)

4235

4336type Rendered = LText.Text

4437

45−data Syn a = Syn { syntax :: a }

38+newtype Syn a = Syn { syntax :: a }

4639

4740instance Pretty a => ToJSON (Syn a) where

4841 toJSON = toJSON . prettyPrint . syntax

4942

50−data Fun = Fun' Name (Maybe Help) Rendered Rendered

43+data Fun = Fun' (Name ()) (Maybe Help) Rendered Rendered

5144

5245instance ToJSON Fun where

5346 toJSON (Fun' n h s d) = object

@@ -57,7 +50,7 @@ instance ToJSON Fun where

5750 , "decl" .= d

5851 ]

5952

60−data Branch = Branch Name Text Help

53+data Branch = Branch (Name ()) Text Help

6154

6255instance ToJSON Branch where

6356 toJSON (Branch n v h) = object

@@ -67,8 +60,8 @@ instance ToJSON Branch where

6760 ]

6861

6962data Data

70− = Sum Name (Maybe Help) [Branch]

71− | Prod Name (Maybe Help) Rendered Fun [Fun] [Rendered]

63+ = Sum (Name ()) (Maybe Help) [Branch]

64+ | Prod (Name ()) (Maybe Help) Rendered Fun [Fun] [Rendered]

7265

7366instance ToJSON Data where

7467 toJSON = \case

@@ -89,7 +82,7 @@ instance ToJSON Data where

8982 , "instances" .= is

9083 ]

9184

92−dataName :: Data -> Name

85+dataName :: Data -> Name ()

9386dataName = \case

9487 Sum n _ _ -> n

9588 Prod n _ _ _ _ _ -> n

@@ -99,7 +92,7 @@ data Action = Action

9992 , _actType :: Global

10093 , _actNamespace :: NS

10194 , _actHelp :: Maybe Help

102− , _actAliasName :: Name

95+ , _actAliasName :: Name ()

10396 , _actAlias :: Rendered

10497 , _actData :: Data

10598 }

@@ -115,7 +108,7 @@ instance ToJSON Action where

115108 ]

116109

117110data API = API

118− { _apiAliasName :: Name

111+ { _apiAliasName :: Name ()

119112 , _apiAlias :: Rendered

120113 , _apiResources :: [Action]

121114 , _apiMethods :: [Action]

gen/src/Gen/Types/Help.hs+15−13

@@ -15,16 +15,16 @@ module Gen.Types.Help

1515 , rawHelpText

1616 ) where

1717

18−import Data.Aeson

19−import Data.Char (isSpace)

20−import Data.String

21−import Data.Text (Text)

22−import qualified Data.Text as T

18+import Data.Aeson

19+import Data.Char (isSpace)

20+import Data.String

21+import Data.Text (Text)

22+import qualified System.IO.Unsafe as Unsafe

2323

24−import Text.Pandoc as Pandoc

25−import Text.Pandoc.Pretty

24+import Text.Pandoc as Pandoc

25+import Text.Pandoc.Pretty

2626

27−import qualified Data.Text as Text

27+import qualified Data.Text as Text

2828

2929data Help

3030 = Help ![Help]

@@ -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+16−16

@@ -1,7 +1,6 @@

11{-# LANGUAGE DeriveGeneric #-}

22{-# LANGUAGE FlexibleInstances #-}

33{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4−{-# LANGUAGE LambdaCase #-}

54{-# LANGUAGE OverloadedStrings #-}

65{-# LANGUAGE ScopedTypeVariables #-}

76{-# LANGUAGE TupleSections #-}

@@ -62,9 +61,7 @@ import qualified Data.CaseInsensitive as CI

6261import Data.Foldable (foldl')

6362import Data.Function (on)

6463import Data.Hashable

65−import Data.List (intersperse)

66−import Data.List (elemIndex, nub, sortOn)

67−import Data.Semigroup hiding (Sum)

64+import Data.List (elemIndex, intersperse, nub, sortOn)

6865import Data.String

6966import Data.Text (Text)

7067import qualified Data.Text as Text

@@ -76,10 +73,10 @@ import GHC.Generics (Generic)

7673import Language.Haskell.Exts.Build

7774import Language.Haskell.Exts.Syntax (Exp, Name (..))

7875

79−aname :: Text -> Name

76+aname :: Text -> Name ()

8077aname = name . Text.unpack . (<> "API") . upperHead . Text.replace "." ""

8178

82−mname :: Text -> Suffix -> Global -> (Name, Global, Text)

79+mname :: Text -> Suffix -> Global -> (Name (), Global, Text)

8380mname abrv (Suffix suf) (Global g) =

8481 ( name . Text.unpack $ mconcat n <> suf -- Action service type alias.

8582 , Global n -- Action data type.

@@ -94,13 +91,13 @@ mname abrv (Suffix suf) (Global g) =

9491 e = Text.replace "." "" abrv

9592 x:xs = map (upperAcronym . toPascal) g

9693

97−dname' :: Global -> Name

94+dname' :: Global -> Name ()

9895dname' g =

9996 case dname g of

100− Ident s -> Ident (s <> "'")

101− Symbol s -> Symbol (s <> "'")

97+ Ident () s -> Ident () (s <> "'")

98+ Symbol () s -> Symbol () (s <> "'")

10299

103−dname :: Global -> Name

100+dname :: Global -> Name ()

104101dname = name

105102 . Text.unpack

106103 . renameReserved

@@ -108,7 +105,7 @@ dname = name

108105 . Text.dropWhile separator

109106 . global

110107

111−cname :: Global -> Name

108+cname :: Global -> Name ()

112109cname = name

113110 . Text.unpack

114111 . renameReserved

@@ -117,24 +114,24 @@ cname = name

117114 . lowerFirstAcronym

118115 . global

119116

120−bname :: Prefix -> Text -> Name

117+bname :: Prefix -> Text -> Name ()

121118bname (Prefix p) = name

122119 . Text.unpack

123120 . mappend (Text.toUpper p)

124121 . renameBranch

125122

126−fname, lname, pname :: Prefix -> Local -> Name

123+fname, lname, pname :: Prefix -> Local -> Name ()

127124fname = pre (Text.cons '_' . renameField)

128125lname = pre renameField

129126pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead . renameField)

130127

131−dstr :: Global -> Exp

128+dstr :: Global -> Exp ()

132129dstr = strE . Text.unpack . toPascal . global

133130

134−fstr :: Local -> Exp

131+fstr :: Local -> Exp ()

135132fstr = strE . Text.unpack . local

136133

137−pre :: (Text -> Text) -> Prefix -> Local -> Name

134+pre :: (Text -> Text) -> Prefix -> Local -> Name ()

138135pre f (Prefix p) = name . Text.unpack . f . mappend p . upperHead . local

139136

140137newtype Suffix = Suffix Text

@@ -143,6 +140,9 @@ newtype Suffix = Suffix Text

143140newtype Prefix = Prefix Text

144141 deriving (Show, Monoid)

145142

143+instance Semigroup Prefix where

144+ Prefix a <> Prefix b = Prefix (a <> b)

145+

146146newtype Global = Global { unsafeGlobal :: [Text] }

147147 deriving (Ord, Show, Generic)

148148

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+6−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

@@ -422,7 +425,7 @@ data Service a = Service

422425 , _sOwnerName :: Text

423426 , _sOwnerDomain :: Text

424427 , _sPackagePath :: Maybe Text

425− , _sDescription :: (Description a)

428+ , _sDescription :: Description a

426429 } deriving (Eq, Show)

427430

428431makeClassy ''Service

@@ -445,8 +448,8 @@ serviceName = Text.unpack . (<> "Service") . toCamel . _sCanonicalName

445448scopeName :: Service a -> Text -> String

446449scopeName s k = Text.unpack . lowerHead . lowerFirstAcronym $

447450 case breakParts k of

448− [] -> _sCanonicalName s <> "AllScope"

449− xs -> foldMap named xs <> "Scope"

451+ [] -> _sCanonicalName s <> "AllScope"

452+ xs -> foldMap named xs <> "Scope"

450453 where

451454 breakParts =

452455 concatMap (Text.split split)

gen/stack.yaml+9−5

@@ -1,11 +1,15 @@

1−resolver: lts-8.18

1+resolver: lts-13.7

33flags: {}

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

33local-bin-path: bin