d430777 · gogol · git.iko.soy

core/gozen-core.cabal+2

compare with develop

unifiedsplit

@@ -43,6 +43,8 @@ library

43 build-depends:

44 base >= 4.7 && < 5

45 , hashable

46+ , text

47+ , lens

46

48

47 if !impl(ghc>=7.9)

49 if !impl(ghc>=7.9)

48 build-depends:

50 build-depends:

core/src/Network/Google/Prelude.hs+24

@@ -8,6 +8,30 @@

8--

9module Network.Google.Prelude

10 ( module Export

11+

12+ -- * Isos

13+ , _Coerce

14+ , _Default

11 ) where

15 ) where

12

16

17+import Control.Lens as Export (Lens', lens)

18+import Control.Lens hiding (coerce)

19+import Data.Coerce

20+import Data.Data as Export (Data, Typeable)

13import Data.Hashable as Export

21import Data.Hashable as Export

22+import Data.Int as Export (Int32, Int64)

23+import Data.Text as Export (Text)

24+import Data.Time as Export (UTCTime)

25+import Data.Word as Export (Word32, Word64, Word8)

26+import GHC.Generics as Export (Generic)

27+

28+_Coerce :: (Coercible a b, Coercible b a) => Iso' a b

29+_Coerce = iso coerce coerce

30+

31+-- | Invalid Iso, should be a Prism but exists for ease of composition

32+-- with the current 'Lens . Iso' chaining to hide internal types from the user.

33+_Default :: Monoid a => Iso' (Maybe a) a

34+_Default = iso f Just

35+ where

36+ f (Just x) = x

37+ f Nothing = mempty

gen/Makefile+2−2

@@ -16,7 +16,7 @@ MODELS ?= $(shell find $(MODEL_DIR) -type f -name '*.json' | sort)

16

17.PHONY: $(BIN)/gozen-gen gen format

18

19−release: gen # format

19+release: gen format

20

21gen: $(BIN)/gozen-gen $(MODEL_DIR)

22 $(BIN)/gozen-gen \

@@ -31,7 +31,7 @@ gen: $(BIN)/gozen-gen $(MODEL_DIR)

31

32format:

33 @echo -e '\nFormatting...'

34− @find $(wildcard $(OUT_DIR)/gozen-*/gen) $(wildcard $(OUT_DIR)/test/Test/AWS/Gen) \

34+ @find $(wildcard $(OUT_DIR)/gozen-*/gen) \

35 -type f \

36 -name '*.hs' \

37 -printf ' -> %p\n' \

gen/gozen-gen.cabal+1

@@ -32,6 +32,7 @@ executable gozen-gen

32 , Gen.Text

33 , Gen.Tree

34 , Gen.Types

35+ , Gen.Types.Help

35 , Gen.Types.Id

36 , Gen.Types.Id

36 , Gen.Types.Map

37 , Gen.Types.Map

37 , Gen.Types.NS

38 , Gen.Types.NS

gen/src/Gen/AST.hs+64−59

@@ -44,7 +44,7 @@ import HIndent

44import Language.Haskell.Exts.Pretty

45import Prelude hiding (sum)

46

47−--runAST :: Service (Schema Id) Resource -> Either Error a

47+runAST :: Service (Fix Schema) Resource -> Either Error (Service Data API)

48runAST svc = evalState (runExceptT (render ss)) (initial (_svcSchemas ss))

49 where

50 ss = flatten svc

@@ -57,34 +57,33 @@ render svc = do

57 where

58 typ :: Id -> Schema Id -> AST (Maybe Data)

59 typ k = \case

60− Arr {} -> pure Nothing

60+ Arr {} -> pure Nothing

61− Ref {} -> pure Nothing

61+ Ref {} -> pure Nothing

62− Any {} -> pure Nothing

62+ Any {} -> pure Nothing

63− Lit {} -> pure Nothing

63+ Lit {} -> pure Nothing

64− Enum i vs ds -> do

64+ Enum i vs ds -> Just . sum' <$> prefix k

65− n <- _prefix <$> solve k

66− return (Just (sum n))

67 where

65 where

68− sum n = Sum (dname n) (i ^. description)

66+ sum' p = Sum (dname k) (i ^. description) $

69− (Map.fromList $ map (first (dname . Pre . idFromText) . join (,)) vs)

67+ zipWith (branch p) vs (ds ++ repeat "")

70− (map rawHelpText ds)

68+

69+ branch p v = Branch (bname p v) v

71

70

72 Obj i rs -> do

71 Obj i rs -> do

73− n <- _prefix <$> solve k

72+ p <- prefix k

74− Just <$> (traverse solve rs >>= prod n)

73+ Just <$> (Map.traverseWithKey (const . solve . mkProp k) rs >>= prod p)

75 where

74 where

76− prod n ts = Prod (dname n) (i ^. description)

75+ prod p ts = Prod (dname k) (i ^. description)

77− <$> (objDecl k n ts >>= pp Indent)

76+ <$> (objDecl k p ts >>= pp Indent)

78− <*> ctor n ts

77+ <*> ctor p ts

79− <*> traverse (lens n) (Map.elems ts)

78+ <*> traverse (lens p) (Map.toList ts)

80

79

81− ctor n ts = Fun' (cname n) (Just help)

80+ ctor p ts = Fun' (cname k) (Just help)

82− <$> (pp None (ctorSig n ts) >>= comments ts)

81+ <$> (pp None (ctorSig k ts) <&> comments ts)

83− <*> pp Indent (ctorDecl n ts)

82+ <*> pp Indent (ctorDecl k p ts)

84

83

85− lens n v = Fun' (lname (_prefix v)) (v ^. description)

84+ lens p (l, v) = Fun' (lname p l) (v ^. description)

86− <$> pp None (lensSig n v)

85+ <$> pp None (lensSig k p l v)

87− <*> pp Print (lensDecl n v)

86+ <*> pp Print (lensDecl p l v)

88

87

89 help = rawHelpText $

88 help = rawHelpText $

90 sformat ("Creates a value of '" % fid %

89 sformat ("Creates a value of '" % fid %

@@ -97,36 +96,43 @@ render svc = do

97 return $! API (aname k) (Map.fromList rs)

96 return $! API (aname k) (Map.fromList rs)

98

97

99flatten :: Service (Fix Schema) Resource -> Service (Schema Id) Resource

98flatten :: Service (Fix Schema) Resource -> Service (Schema Id) Resource

100−flatten svc = svc

101− { _svcSchemas = execState (mapM_ (uncurry (prop Nothing)) ss) mempty

99+flatten svc = svc { _svcSchemas = execState run mempty }

102− }

103 where

100 where

104− ss = Map.toList (_svcSchemas svc)

101+ run = mapM_ (uncurry top) (Map.toList (_svcSchemas svc))

105−

106− -- unfold the properties.

107− prop p k (Fix f) = case f of

108− Obj i ps -> do

109− o <- Obj i <$> Map.traverseWithKey (prop (Just this)) ps

110− res o

111

102

112− Arr i (Fix e) -> do

103+ top :: Id -> Fix Schema -> State (Map Id (Schema Id)) Id

104+ top n (Fix f) = go f >>= ins n

105+ where

106+ go = \case

107+ Obj i ps -> Obj i <$> Map.traverseWithKey (prop n) ps

113− e' <- prop (Just this) "item" (Fix (e & required .~ True))

108+ Arr i (Fix e) -> Arr i <$> prop n "item" (Fix (e & required .~ True))

114− res (Arr i e')

115

109

116− Enum i vs ds -> res (Enum i vs ds)

110+ Enum i vs ds -> pure (Enum i vs ds)

117− Lit i l -> res (Lit i l)

111+ Lit i x -> pure (Lit i x)

118− Ref i r -> res (Ref i r)

112+ Ref i r -> pure (Ref i r)

119− Any i -> res (Any i)

113+ Any i -> pure (Any i)

120

114

115+ prop :: Id -> Local -> Fix Schema -> State (Map Id (Schema Id)) Id

116+ prop n l (Fix f) = go f >>= ins this

121 where

117 where

122− res x = do

123− s <- gets (Map.lookup this)

124− case s of

118+ go = \case

125− Nothing -> modify (Map.insert this x) >> pure this

119+ Obj i ps -> Obj i <$> Map.traverseWithKey (prop this) ps

126− -- FIXME:

120+ Arr i (Fix e) -> Arr i <$> prop this "item" (Fix (e & required .~ True))

127− Just e -> error $ "Already exists: " ++ show (this, e, x)

128

121

129− this = maybe k (<> k) p

122+ Enum i vs ds -> pure (Enum i vs ds)

123+ Lit i x -> pure (Lit i x)

124+ Ref i r -> pure (Ref i r)

125+ Any i -> pure (Any i)

126+

127+ this = mkProp n l

128+

129+ ins :: Id -> Schema Id -> State (Map Id (Schema Id)) Id

130+ ins n x = do

131+ s <- gets (Map.lookup n)

132+ case s of

133+ Nothing -> modify (Map.insert n x) >> pure n

134+ -- FIXME:

135+ Just e -> error $ "Already exists: " ++ show (n, e, x)

130

136

131merge :: Versions -> [Service Data API] -> [Library]

137merge :: Versions -> [Service Data API] -> [Library]

132merge v = map go . groupBy (on (==) _svcLibrary)

138merge v = map go . groupBy (on (==) _svcLibrary)

@@ -176,17 +182,16 @@ pp i x

176 }

182 }

177

183

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

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

179−comments :: Map Id Solved -> Rendered -> AST Rendered

185+comments :: Map Local Solved -> Rendered -> Rendered

180−comments (Map.toList -> rs) x = do

186+comments (Map.toList -> rs) =

181− let ks = filter (parameter . _schema . snd) rs

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

183− return

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

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

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

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

186− . zipWith rel ps

189+ . zipWith rel ps

187− . map LText.strip

190+ . map LText.strip

188− $ LText.splitOn "->" x

191+ . LText.splitOn "->"

189 where

192 where

193+ ks = filter (parameter . _schema . snd) rs

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

195+

190 rel Nothing t = t

196 rel Nothing t = t

191− rel (Just k) t =

192− t <> " -- ^ '" <> LText.fromStrict (idToText k) <> "'"

197+ rel (Just l) t = t <> " -- ^ '" <> LText.fromStrict (local l) <> "'"

gen/src/Gen/Solve.hs+20−31

@@ -27,10 +27,8 @@ import Control.Monad.Except

27import Control.Monad.State.Strict

28import Data.CaseInsensitive (CI)

29import qualified Data.CaseInsensitive as CI

30−import Data.Char (toLower)

31import Data.Hashable

30import Data.Hashable

32import qualified Data.HashMap.Strict as Map

31import qualified Data.HashMap.Strict as Map

33−import qualified Data.HashMap.Strict as Map

34import qualified Data.HashSet as Set

32import qualified Data.HashSet as Set

35import Data.List (intersect)

33import Data.List (intersect)

36import Data.Maybe

34import Data.Maybe

@@ -70,8 +68,7 @@ data Derive

70 deriving (Eq, Show)

68 deriving (Eq, Show)

71

69

72data Solved = Solved

70data Solved = Solved

73− { _prefix :: Pre

74− , _schema :: Schema Id

71+ { _schema :: Schema Id

75 , _type :: TType

72 , _type :: TType

76 , _deriving :: [Derive]

73 , _deriving :: [Derive]

77 }

74 }

@@ -101,14 +98,14 @@ type AST = ExceptT Error (State Memo)

101

98

102schema :: Id -> AST (Schema Id)

99schema :: Id -> AST (Schema Id)

103schema k = do

100schema k = do

104− m <- gets (Map.lookup k . view schemas)

101+ m <- uses schemas (Map.lookup k)

105 case m of

102 case m of

106 Nothing -> failure ("Missing Schema: " % fid) k

103 Nothing -> failure ("Missing Schema: " % fid) k

107 Just v -> pure v

104 Just v -> pure v

108

105

109memo :: Lens' Memo (Map Id v) -> Id -> (Schema Id -> AST v) -> AST v

106memo :: Lens' Memo (Map Id v) -> Id -> (Schema Id -> AST v) -> AST v

110memo l k f = do

107memo l k f = do

111− m <- gets (Map.lookup k . view l)

108+ m <- uses l (Map.lookup k)

112 case m of

109 case m of

113 Just x -> return x

110 Just x -> return x

114 Nothing -> do

111 Nothing -> do

@@ -117,16 +114,16 @@ memo l k f = do

117 return x

114 return x

118

115

119solve :: Id -> AST Solved

116solve :: Id -> AST Solved

120−solve k = Solved <$> prefix k <*> schema k <*> typeOf k <*> derive k

117+solve k = Solved <$> schema k <*> typeOf k <*> derive k

121

118

122typeOf :: Id -> AST TType

119typeOf :: Id -> AST TType

123−typeOf k = loc "typeOf" k $ memo typed k go

120+typeOf k = memo typed k go

124 where

121 where

125 go s = fmap may $ case s of

122 go s = fmap may $ case s of

126 Obj {} -> pure (TType k)

123 Obj {} -> pure (TType k)

127 Arr _ r -> TList <$> typeOf r

124 Arr _ r -> TList <$> typeOf r

128 Enum {} -> pure (TType k)

125 Enum {} -> pure (TType k)

129− Ref _ r -> typeOf r

126+ Ref _ r -> typeOf (Free r)

130 Any {} -> pure (TEither (TLit Text) (TLit Int64))

127 Any {} -> pure (TEither (TLit Text) (TLit Int64))

131 Lit _ l -> pure (TLit l)

128 Lit _ l -> pure (TLit l)

132 where

129 where

@@ -135,13 +132,13 @@ typeOf k = loc "typeOf" k $ memo typed k go

135 | otherwise = TMaybe

132 | otherwise = TMaybe

136

133

137derive :: Id -> AST [Derive]

134derive :: Id -> AST [Derive]

138−derive k = loc "derive" k $ memo derived k go

135+derive k = memo derived k go

139 where

136 where

140 go = \case

137 go = \case

141 Obj _ rs -> foldM props base (Map.elems rs)

138 Obj _ rs -> foldM props base (Map.elems rs)

142 Arr _ r -> mappend monoid . intersect base <$> derive r

139 Arr _ r -> mappend monoid . intersect base <$> derive r

143 Enum {} -> pure enum

140 Enum {} -> pure enum

144− Ref _ r -> derive r

141+ Ref _ r -> derive (Free r)

145 Any _ -> pure base

142 Any _ -> pure base

146 Lit _ l -> pure $

143 Lit _ l -> pure $

147 case l of

144 case l of

@@ -158,26 +155,24 @@ derive k = loc "derive" k $ memo derived k go

158 base = [DEq, DRead, DShow, DData, DTypeable, DGeneric]

155 base = [DEq, DRead, DShow, DData, DTypeable, DGeneric]

159

156

160prefix :: Id -> AST Pre

157prefix :: Id -> AST Pre

161−prefix k = loc "prefix" k $ memo prefixed k typ

158+prefix n = memo prefixed n typ

162 where

159 where

163 typ = \case

160 typ = \case

164− Obj i rs -> field rs >> pure (Pre k)

161+ Obj i rs -> field rs

165− Enum i vs ds -> pure (Pre k)

162+ Enum i vs ds -> pure mempty

166− _ -> pure (Pre k)

163+ _ -> pure mempty

167−

168− field (keys -> ks) = do

169− p <- uniq fields (acronymPrefixes k) ks

170− forM_ ks $ \n ->

171− prefixed %= Map.insert (k <> key n) (Pre (key p <> key n))

172− pure (Pre (key p))

173

164

174− key = idFromText . CI.foldedCase

165+ field rs = do

166+ let ls = Map.keys rs

167+ ks = Set.fromList (map (CI.mk . local) ls)

168+ p <- uniq fields (acronymPrefixes n) ks

169+ pure (Pre p)

175

170

176 uniq :: Lens' Memo Seen

171 uniq :: Lens' Memo Seen

177 -> [CI Text]

172 -> [CI Text]

178 -> Set (CI Text)

173 -> Set (CI Text)

179− -> AST (CI Text)

174+ -> AST Text

180− uniq _ [] ks = failure ("Unable to generate unique prefix: " % fid) k

175+ uniq _ [] ks = failure ("Unable to generate unique prefix: " % fid) n

181 uniq seen (x:xs) ks = do

176 uniq seen (x:xs) ks = do

182 m <- uses seen (Map.lookup x)

177 m <- uses seen (Map.lookup x)

183 case m of

178 case m of

@@ -185,14 +180,11 @@ prefix k = loc "prefix" k $ memo prefixed k typ

185 -> uniq seen xs ks

180 -> uniq seen xs ks

186 _ -> do

181 _ -> do

187 seen %= Map.insertWith (<>) x ks

182 seen %= Map.insertWith (<>) x ks

188− return x

183+ return (CI.foldedCase x)

189

184

190overlap :: (Eq a, Hashable a) => Set a -> Set a -> Bool

185overlap :: (Eq a, Hashable a) => Set a -> Set a -> Bool

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

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

192

187

193−keys :: Map Id a -> Set (CI Text)

194−keys = Set.fromList . map (CI.mk . idToText) . Map.keys

195−

196acronymPrefixes :: Id -> [CI Text]

188acronymPrefixes :: Id -> [CI Text]

197acronymPrefixes (idToText -> n) = map CI.mk (xs ++ map suffix ys)

189acronymPrefixes (idToText -> n) = map CI.mk (xs ++ map suffix ys)

198 where

190 where

@@ -232,6 +224,3 @@ acronymPrefixes (idToText -> n) = map CI.mk (xs ++ map suffix ys)

232

224

233 -- SomeTestTType -> Som

225 -- SomeTestTType -> Som

234 r6 = Text.take limit <$> listToMaybe (splitWords a)

226 r6 = Text.take limit <$> listToMaybe (splitWords a)

235−

236−loc :: String -> Id -> a -> a

237−loc _ _ = id -- trace (n ++ ": " ++ Text.unpack (refToText r))

gen/src/Gen/Syntax.hs+35−37

@@ -46,7 +46,7 @@ apiTypes s r m = map sing ps ++ qs ++ [end]

46 param (k, p) =

47 -- FIXME: types, many/repeated

48 let t = literal (_prmLiteral p)

49− n = sing (idToText k)

49+ n = sing (local k)

50 in case _prmLocation p of

51 Path -> TyApp (TyApp (tycon "Capture") n) t

52 Query -> TyApp (TyApp (tycon "QueryParam") n) t

@@ -55,70 +55,65 @@ apiTypes s r m = map sing ps ++ qs ++ [end]

55

56 meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mMethod m)

57 typ = tycon "'[JSON]"

58− res = maybe (tycon "()") (tycon . Pre) (_mResponse m)

58+ res = maybe (tycon "()") (tycon . Free) (_mResponse m)

59

60 -- method (titlecase) '[JSON] (responsetype)

61

62−objDecl :: Id -> Pre -> Map Id Solved -> AST Decl

62+objDecl :: Id -> Pre -> Map Local Solved -> AST Decl

63−objDecl r p rs = DataDecl noLoc arity [] d [] [conDecl d rs] <$> derivings r

63+objDecl n p rs = DataDecl noLoc arity [] d [] [conDecl d p rs] <$> derivings n

64 where

65− d = dname p

65+ d = dname n

66

67 arity | Map.size rs == 1 = NewType

68 | otherwise = DataType

69

70−conDecl :: Name -> Map Id Solved -> QualConDecl

70+conDecl :: Name -> Pre -> Map Local Solved -> QualConDecl

71−conDecl n rs = QualConDecl noLoc [] [] body

71+conDecl n p rs = QualConDecl noLoc [] [] body

72 where

73− body = case Map.elems rs of

73+ body = case Map.toList rs of

74 [] -> ConDecl n []

75 [x] -> RecDecl n [field internal x]

76 xs -> RecDecl n (map (field (strict . internal)) xs)

77

78− field f v = ([fname (_prefix v)], f (_type v))

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

79

80−ctorSig :: Pre -> Map Id Solved -> Decl

80+ctorSig :: Id -> Map Local Solved -> Decl

81−ctorSig r rs = TypeSig noLoc [c] ts

81+ctorSig n rs = TypeSig noLoc [cname n] ts

82 where

83− c = cname r

84− d = dname r

85−

86− ts = foldr' TyFun (TyCon (UnQual d)) ps

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

87 ps = parameters (Map.elems rs)

84 ps = parameters (Map.elems rs)

88

85

89−ctorDecl :: Pre -> Map Id Solved -> Decl

86+ctorDecl :: Id -> Pre -> Map Local Solved -> Decl

90−ctorDecl r rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds

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

91 where

88 where

92− c = cname r

89+ c = cname n

93− d = dname r

90+ d = dname n

94

91

95 rhs | Map.null rs = var d

92 rhs | Map.null rs = var d

96 | otherwise = RecConstr (UnQual d) $

93 | otherwise = RecConstr (UnQual d) $

97− map fieldUpdate (Map.elems rs)

94+ map (uncurry (fieldUpdate p)) (Map.toList rs)

98

95

99− ps = map (pname . _prefix) . Map.elems $ Map.filter (view required) rs

96+ ps = map (pname p) . Map.keys $ Map.filter (view required) rs

100

97

101−fieldUpdate :: Solved -> FieldUpdate

98+fieldUpdate :: Pre -> Local -> Solved -> FieldUpdate

102−fieldUpdate s = FieldUpdate (UnQual (fname n)) rhs

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

103 where

100 where

104− rhs | s ^. required = p

101+ rhs | s ^. required = v

105 | Just x <- s ^. defaulted = str x

102 | Just x <- s ^. defaulted = str x

106− | Just v <- iso (_type s) = infixApp v "#" p

103+ | Just x <- iso (_type s) = infixApp x "#" v

107 | otherwise = var (name "Nothing")

104 | otherwise = var (name "Nothing")

108

105

109− p = var (pname n)

106+ v = var (pname p l)

110− n = _prefix s

111

107

112−lensSig :: Pre -> Solved -> Decl

108+lensSig :: Id -> Pre -> Local -> Solved -> Decl

113−lensSig n s = TypeSig noLoc [lname (_prefix s)] $

109+lensSig n p l s = TypeSig noLoc [lname p l] $

114 TyApp (TyApp (tycon "Lens'") (tycon n))

110 TyApp (TyApp (tycon "Lens'") (tycon n))

115 (external (_type s))

111 (external (_type s))

116

112

117−lensDecl :: Pre -> Solved -> Decl

113+lensDecl :: Pre -> Local -> Solved -> Decl

118−lensDecl r s = sfun noLoc l [] (UnGuardedRhs rhs) noBinds

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

119 where

115 where

120− f = fname r

116+ f = fname p l

121− l = lname (_prefix s)

122 t = _type s

117 t = _type s

123

118

124 rhs = mapping t $

119 rhs = mapping t $

@@ -133,9 +128,12 @@ parameters :: [Solved] -> [Type]

133parameters = map (external . _type) . filter (view required)

128parameters = map (external . _type) . filter (view required)

134

129

135external, internal :: TType -> Type

130external, internal :: TType -> Type

136−external = internal

131+external = internal . \case

132+ TMaybe t@TList {} -> t

133+ t -> t

134+

137internal = \case

135internal = \case

138− TType r -> tycon (Pre r)

136+ TType r -> tycon r

139 TMaybe t -> TyApp (tycon "Maybe") (internal t)

137 TMaybe t -> TyApp (tycon "Maybe") (internal t)

140 TEither a b -> TyApp (TyApp (tycon "Either") (internal a)) (internal b)

138 TEither a b -> TyApp (TyApp (tycon "Either") (internal a)) (internal b)

141 TList t -> TyList (internal t)

139 TList t -> TyList (internal t)

@@ -179,8 +177,8 @@ strict = TyBang BangedTy . \case

179sing :: Text -> Type

177sing :: Text -> Type

180sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""

178sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""

181

179

182−tycon :: Pre -> Type

180+tycon :: Id -> Type

183−tycon = TyCon . unqual . pre upperHead

181+tycon = TyCon . unqual . Text.unpack . idToText

184

182

185unqual :: String -> QName

183unqual :: String -> QName

186unqual = UnQual . name

184unqual = UnQual . name

gen/src/Gen/Types.hs+23−15

@@ -217,11 +217,11 @@ instance FromJSON Lit where

217deriveToJSON (js "") ''Lit

218

219data Schema a

220− = Obj Info (Map Id a)

220+ = Obj Info (Map Local a)

221 | Arr Info a

222 | Enum Info [Text] [Text]

223 | Lit Info Lit

224− | Ref Info Id

224+ | Ref Info Global

225 | Any Info -- String or Number

226 deriving (Eq, Show, Functor, Foldable, Traversable)

227

@@ -291,18 +291,26 @@ instance ToJSON Fun where

291 , "decl" .= d

292 ]

293

294+data Branch = Branch Name Text Text

295+

296+instance ToJSON Branch where

297+ toJSON (Branch n v h) = object

298+ [ "name" .= Syn n

299+ , "value" .= v

300+ , "help" .= h

301+ ]

302+

294data Data

303data Data

295− = Sum Name (Maybe Help) (Map Name Text) [Help]

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

296 | Prod Name (Maybe Help) Rendered Fun [Fun]

305 | Prod Name (Maybe Help) Rendered Fun [Fun]

297

306

298instance ToJSON Data where

307instance ToJSON Data where

299 toJSON = \case

308 toJSON = \case

300− Sum n h vs ds -> object

309+ Sum n h bs -> object

301− [ "name" .= Syn n

310+ [ "name" .= Syn n

302− , "type" .= "sum"

311+ , "type" .= "sum"

303− , "help" .= h

312+ , "help" .= h

304− , "ctors" .= vs

313+ , "branches" .= bs

305− , "descriptions" .= ds

306 ]

314 ]

307

315

308 Prod n h d c ls -> object

316 Prod n h d c ls -> object

@@ -327,11 +335,11 @@ data Method = Method

327 , _mPath :: Text

335 , _mPath :: Text

328 , _mMethod :: Text

336 , _mMethod :: Text

329 , _mDescription :: Maybe Help

337 , _mDescription :: Maybe Help

330− , _mParameters :: Map Id Param

338+ , _mParameters :: Map Local Param

331− , _mParameterOrder :: [Id]

339+ , _mParameterOrder :: [Local]

332 , _mScopes :: [Text]

340 , _mScopes :: [Text]

333− , _mRequest :: Maybe Id

341+ , _mRequest :: Maybe Global

334− , _mResponse :: Maybe Id

342+ , _mResponse :: Maybe Global

335 } deriving (Generic)

343 } deriving (Generic)

336

344

337instance FromJSON Method where

345instance FromJSON Method where

@@ -351,7 +359,7 @@ instance FromJSON Method where

351

359

352deriveToJSON (js "_m") ''Method

360deriveToJSON (js "_m") ''Method

353

361

354−newtype Resource = Resource { methods :: Map Id Method }

362+newtype Resource = Resource { methods :: Map Global Method }

355

363

356deriveFromJSON (js "") ''Resource

364deriveFromJSON (js "") ''Resource

357

365

@@ -373,7 +381,7 @@ data Service s r = Service

373 , _svcServicePath :: Text

381 , _svcServicePath :: Text

374 , _svcBatchPath :: Text

382 , _svcBatchPath :: Text

375 , _svcAuth :: Maybe Object

383 , _svcAuth :: Maybe Object

376− , _svcParameters :: Map Id Param

384+ , _svcParameters :: Map Local Param

377 , _svcSchemas :: Map Id s

385 , _svcSchemas :: Map Id s

378 , _svcResources :: Map Id r

386 , _svcResources :: Map Id r

379 } deriving (Generic)

387 } deriving (Generic)

gen/src/Gen/Types/Id.hs+101−65

@@ -10,29 +10,29 @@

10-- Stability : provisional

11-- Portability : non-portable (GHC extensions)

12

13−module Gen.Types.Id

13+module Gen.Types.Id where

14− ( Id

14+ -- ( Id

15− , Pre (..)

15+ -- , Pre (..)

16−

16+

17− -- * Conversion

17+ -- -- * Conversion

18− , idToText

18+ -- , idToText

19− , idFromText

19+ -- , idFromText

20− , direct

20+ -- , direct

21−

21+

22− -- * Formatting

22+ -- -- * Formatting

23− , fid

23+ -- , fid

24− , ref

24+ -- , ref

25− , pre

25+ -- , pre

26−

26+

27− -- * Syntax

27+ -- -- * Syntax

28− , aname

28+ -- , aname

29− , mname

29+ -- , mname

30− , dname

30+ -- , dname

31− , cname

31+ -- , cname

32− , fname

32+ -- , fname

33− , lname

33+ -- , lname

34− , pname

34+ -- , pname

35− ) where

35+ -- ) where

36

37import Control.Applicative

38import Control.Lens hiding (pre, (.=))

@@ -44,6 +44,8 @@ import Data.Char

44import Data.Function (on)

45import Data.Hashable

46import qualified Data.HashMap.Strict as Map

47+import Data.List.NonEmpty (NonEmpty (..))

48+import qualified Data.List.NonEmpty as NE

47import Data.Maybe

49import Data.Maybe

48import Data.Ord

50import Data.Ord

49import Data.Semigroup hiding (Sum)

51import Data.Semigroup hiding (Sum)

@@ -60,66 +62,100 @@ import GHC.Generics

60import Language.Haskell.Exts.Build

62import Language.Haskell.Exts.Build

61import Language.Haskell.Exts.Syntax (Name)

63import Language.Haskell.Exts.Syntax (Name)

62

64

63−newtype Pre = Pre Id

64− deriving (IsString)

65−

66aname :: Id -> Name

65aname :: Id -> Name

67−aname = name . ref upperHead

66+aname = name . Text.unpack . upperHead . idToText

68

67

69−mname :: Id -> Id -> Name

68+mname :: Id -> Global -> Name

70−mname p k = aname (p <> k)

69+mname x y = name . Text.unpack $

70+ upperHead (idToText x) <> upperHead (global y)

71

72−dname, cname, fname, lname, pname :: Pre -> Name

72+dname, cname :: Id -> Name

73−dname = name . pre upperHead

73+dname = name . Text.unpack . upperHead . idToText

74−cname = name . pre (renameReserved . lowerHead)

74+cname = name . Text.unpack . renameReserved . lowerHead . idToText

75−fname = name . pre (Text.cons '_' . lowerHead)

76−lname = name . pre lowerHead

77−pname = name . pre (flip Text.snoc '_' . Text.cons 'p' . upperHead)

78

75

79−pre :: (Text -> Text) -> Pre -> String

76+bname :: Pre -> Text -> Name

80−pre f (Pre k) = ref f k

77+bname (Pre p) = name

78+ . Text.unpack

79+ . mappend (Text.toUpper p)

80+ . upperHead

81

82−ref :: (Text -> Text) -> Id -> String

82+fname, lname, pname :: Pre -> Local -> Name

83−ref f = Text.unpack . f . idToText

83+fname = pre (Text.cons '_' . lowerHead)

84+lname = pre lowerHead

85+pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead)

84

86

85−data Id

87+pre :: (Text -> Text) -> Pre -> Local -> Name

86− = Opaque [Text]

88+pre f (Pre p) = name . Text.unpack . f . mappend p . upperHead . local

87− | Direct Text

88− deriving (Eq, Show, Generic)

89

90−instance Semigroup Id where

90+newtype Global = Global { global :: Text }

91− a <> b = case (a, b) of

91+ deriving (Eq, Show, Generic, Hashable, FromJSON, ToJSON, IsString)

92− (Opaque xs, Opaque ys) -> Opaque (xs <> ys)

93− (Opaque xs, Direct y) -> Opaque (xs <> [y])

94− (Direct x, Opaque ys) -> Opaque (x : ys)

95− (Direct x, Direct y) -> Opaque [x, y]

96

92

97−instance IsString Id where

93+instance FromJSON a => FromJSON (Map Global a) where

98− fromString = idFromText . fromString

94+ parseJSON = fmap (fromMap Global) . parseJSON

95+

96+instance ToJSON a => ToJSON (Map Global a) where

97+ toJSON = toJSON . toMap global

98+

99+gid :: Format a (Global -> a)

100+gid = later (Build.fromText . global)

101+

102+newtype Local = Local { local :: Text }

103+ deriving (Eq, Show, Generic, Hashable, FromJSON, ToJSON, IsString)

104+

105+instance FromJSON a => FromJSON (Map Local a) where

106+ parseJSON = fmap (fromMap Local) . parseJSON

107+

108+instance ToJSON a => ToJSON (Map Local a) where

109+ toJSON = toJSON . toMap local

110+

111+lid :: Format a (Local -> a)

112+lid = later (Build.fromText . local)

113+

114+data Id

115+ = Free Global

116+ | Bound Global (NonEmpty Local)

117+ deriving (Eq, Show, Generic)

99

118

100instance Hashable Id

119instance Hashable Id

101

120

102−instance FromJSON Id where parseJSON = withText "id" (pure . idFromText)

121+instance IsString Id where

103−instance ToJSON Id where toJSON = toJSON . idToText

122+ fromString = Free . Global . fromString

104

123

105instance FromJSON a => FromJSON (Map Id a) where

124instance FromJSON a => FromJSON (Map Id a) where

106− parseJSON o = Map.fromList . map (first idFromText) . Map.toList

125+ parseJSON = fmap (fromMap (Free . Global)) . parseJSON

107− <$> parseJSON o

108

126

109instance ToJSON a => ToJSON (Map Id a) where

127instance ToJSON a => ToJSON (Map Id a) where

110− toJSON = toJSON . Map.fromList . map (first idToText) . Map.toList

128+ toJSON = toJSON . toMap idToText

111

129

112−idToText :: Id -> Text

130+newtype Pre = Pre Text

113−idToText = renameReserved . \case

131+ deriving (Show, Monoid)

114− Opaque xs -> mconcat (map upperHead xs)

115− Direct n -> n

116

132

117−idFromText :: Text -> Id

133+mkId :: Global -> [Local] -> Id

118−idFromText = Direct

134+mkId g = \case

135+ [] -> Free g

136+ x:xs -> Bound g (x :| xs)

137+

138+mkProp :: Id -> Local -> Id

139+mkProp n x =

140+ case n of

141+ Free g -> Bound g (x :| [])

142+ Bound g xs -> Bound g (NE.cons x xs)

143+

144+revProp :: Id -> Local

145+revProp = \case

146+ Free g -> Local (global g)

147+ Bound _ xs -> let x :| _ = NE.reverse xs in x

148+

149+idToText :: Id -> Text

150+idToText = renameReserved . upperHead . \case

151+ Free g -> global g

152+ Bound g ls -> mconcat (global g : map (upperHead . local) (NE.toList ls))

119

153

120fid :: Format a (Id -> a)

154fid :: Format a (Id -> a)

121fid = later (Build.fromText . idToText)

155fid = later (Build.fromText . idToText)

122

156

123−direct :: Id -> Id

157+fromMap :: (Eq a, Hashable a) => (Text -> a) -> Map Text b -> Map a b

124−direct (Direct x) = Direct x

158+fromMap f = Map.fromList . map (first f) . Map.toList

125−direct (Opaque xs) = Direct (last xs)

159+

160+toMap :: (a -> Text) -> Map a b -> Map Text b

161+toMap f = Map.fromList . map (first f) . Map.toList

gen/src/Main.hs−1

@@ -27,7 +27,6 @@ import Gen.AST

27import Gen.Formatting

28import Gen.IO

29import qualified Gen.JSON as JS

30−import Gen.Solve

31import qualified Gen.Tree as Tree

30import qualified Gen.Tree as Tree

32import Gen.Types hiding (info)

31import Gen.Types hiding (info)

33import Options.Applicative

32import Options.Applicative

gen/template/_include/prod.edenew file+28

@@ -0,0 +1,28 @@

1+{% if type.help %}

2+{{ type.help }}

3+{% endif %}

4+--

5+-- /See:/ '{{ type.ctor.name }}' smart constructor.

6+{{ type.decl }}

7+

8+{% if type.ctor.help %}

9+{{ type.ctor.help }}

10+{% endif %}

11+--

12+{% for lens in type.lenses %}

13+ {% if lens.first %}

14+-- Use one of the following lenses to modify other fields as desired:

15+ {% endif %}

16+--

17+-- * '{{ lens.value.name }}'

18+{% endfor %}

19+{{ type.ctor.sig }}

20+{{ type.ctor.decl }}

21+{% for lens in type.lenses %}

22+

23+ {% if lens.value.help %}

24+{{ lens.value.help }}

25+ {% endif %}

26+{{ lens.value.sig }}

27+{{ lens.value.decl }}

28+{% endfor %}

gen/template/_include/sum.edenew file+15

@@ -0,0 +1,15 @@

1+{% if type.help %}

2+{{ type.help }}

3+{% endif %}

4+data {{ type.name }}

5+ {% for branch in type.branches %}

6+ {% if branch.first %}={% else %}|{% endif %} {{ branch.value.name }}

7+ {% if branch.value.help == "" %}

8+ -- ^ @{{ branch.value.value }}@

9+ {% else %}

10+ -- ^ @{{ branch.value.value }}@ - {{ branch.value.help }}

11+ {% endif %}

12+ {% endfor %}

13+ deriving (Eq,Ord,Enum,Read,Show,Data,Typeable,Generic)

14+

15+instance Hashable {{ type.name }}

gen/template/_include/type.ededeleted−41

@@ -1,41 +0,0 @@

1−{% if type.help %}

2−{{ type.help }}

3−{% endif %}

4−{% case type.type %}

5−{% when "prod" %}

6−--

7−-- /See:/ '{{ type.ctor.name }}' smart constructor.

8−{{ type.decl }}

9−

10− {% if type.ctor.help %}

11−{{ type.ctor.help }}

12− {% endif %}

13−--

14− {% for lens in type.lenses %}

15− {% if lens.first %}

16−-- Use one of the following lenses to modify other fields as desired:

17− {% endif %}

18−--

19−-- * '{{ lens.value.name }}'

20− {% endfor %}

21−{{ type.ctor.sig }}

22−{{ type.ctor.decl }}

23− {% for lens in type.lenses %}

24−

25− {% if lens.value.help %}

26−{{ lens.value.help }}

27− {% endif %}

28−{{ lens.value.sig }}

29−{{ lens.value.decl }}

30− {% endfor %}

31−{% when "sum" %}

32−data {{ type.name }}

33− {% for ctor in type.ctors %}

34− {% if ctor.first %}={% else %}|{% endif %} {{ ctor.key }} -- ^ @{{ ctor.value }}@

35− {% endfor %}

36− deriving (Eq, Ord, Enum, Show, Read, Data, Typeable, Generic)

37−

38−instance Hashable {{ type.name }}

39−{% else %}

40− Error: Unrecognised type '{{ type.type }}'

41−{% endcase %}

gen/template/toc.ede+34−31

@@ -7,18 +7,18 @@ module {{ moduleName }}

7 (

8 -- * API Definition

9 {{ api }}

10− , {{ api | lowerHead }}

10+ {# , {{ api | lowerHead }} #}

11

12− -- * Resources

12+ {# -- * Resources #}

13− -- $resources

13+ {# -- $resources #}

14− {% for resource in resources %}

14+ {# {% for resource in resources %} #}

15

16− -- ** {{ resource.value.name }}

16+ {# -- ** {{ resource.value.name }} #}

17− , {{ resource.value.name }}

17+ {# , {{ resource.value.name }} #}

18− {% for method in resource.value.methods %}

18+ {# {% for method in resource.value.methods %} #}

19− , {{ method.key }}

19+ {# , {{ method.key }} #}

20− {% endfor %}

20+ {# {% endfor %} #}

21− {% endfor %}

21+ {# {% endfor %} #}

22

23 -- * Types

24 {% for schema in schemas %}

@@ -49,24 +49,27 @@ import {{ module.value }}

49TODO

50-}

51

52+type {{ api }} = ()

53+--

52−{{ api | lowerHead }} :: Proxy {{ api }}

54+-- {{ api | lowerHead }} :: Proxy {{ api }}

53−{{ api | lowerHead }} = Proxy

55+-- {{ api | lowerHead }} = Proxy

54−

56+--

55−type {{ api }} =

57+-- type {{ api }} =

56−{% for resource in resources %}

58+-- {% for resource in resources %}

57− {% if resource.first %} {% else %}:<|>{% endif %} {{ resource.value.name }}

59+-- {% if resource.first %} {% else %}:<|>{% endif %} {{ resource.value.name }}

58−{% endfor %}

60+-- {% endfor %}

59−{% for resource in resources %}

61+-- {% for resource in resources %}

60−

62+--

61−type {{ resource.value.name }} =

63+-- type {{ resource.value.name }} =

62− {% for method in resource.value.methods %}

64+-- {% for method in resource.value.methods %}

63− {% if !method.first %}:<|>{% else %} {% endif %} {{ method.key }}

65+-- {% if !method.first %}:<|>{% else %} {% endif %} {{ method.key }}

64− {% endfor %}

66+-- {% endfor %}

65− {% for method in resource.value.methods %}

67+-- {% for method in resource.value.methods %}

66−

68+--

67−type {{ method.key }} =

69+-- type {{ method.key }} =

68− {% for type in method.value %}

70+-- {% for type in method.value %}

69− {% if !type.first %}:>{% else %} {% endif %} {{ type.value }}

71+-- {% if !type.first %}:>{% else %} {% endif %} {{ type.value }}

70− {% endfor %}

72+-- {% endfor %}

71− {% endfor %}

73+-- {% endfor %}

72−{% endfor %}

74+-- {% endfor %}

75+--

gen/template/types.ede+14−1

@@ -1,3 +1,7 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+

1{% include "_include/license.ede" %}

5{% include "_include/license.ede" %}

2--

6--

3module {{ moduleName }}

7module {{ moduleName }}

@@ -31,5 +35,14 @@ import {{ import.value }}

31{{ name | lowerHead }} = error "{{ name }}"

35{{ name | lowerHead }} = error "{{ name }}"

32{% for schema in schemas %}

36{% for schema in schemas %}

33

37

38+ {% case schema.value.type %}

39+ {% when "prod" %}

40+ {% include "_include/prod.ede" with type = schema.value %}

41+ {% when "sum" %}

34− {% include "_include/type.ede" with type = schema.value %}

42+ {% include "_include/sum.ede" with type = schema.value %}

43+ {% else %}

44+Error: Unrecognised type:

45+

46+{{ schema.value | show }}

47+ {% endcase %}

35{% endfor %}

48{% endfor %}

stack.yaml+2−1

@@ -4,4 +4,5 @@ extra-deps: []

4packages:

5 - core

6 - gozen

7− - gozen-youtube

7+ - gozen-youtube-analytics

8+ - gozen-compute