git.iko.soy/gogol
on develop help sign in
Ensuring enums and other schema types are parsed before literals
72a9840Brendan Hay
gen/src/Gen/AST/Flatten.hs+23−15
compare with develop
unifiedsplit
@@ -35,6 +35,7 @@ import qualified Data.Text as Text
35import qualified Data.Text.Lazy as LText
35import qualified Data.Text.Lazy as LText
36import qualified Data.Text.Lazy.Builder as Build
36import qualified Data.Text.Lazy.Builder as Build
37import Debug.Trace
37import Debug.Trace
38+import Debug.Trace
38import Gen.Formatting
39import Gen.Formatting
39import Gen.Types
40import Gen.Types
40import HIndent
41import HIndent
@@ -44,13 +45,17 @@ import Prelude hiding (sum)
44
45
45flatten :: Service (Fix Schema) -> AST (Service Global)
46flatten :: Service (Fix Schema) -> AST (Service Global)
46flatten s = do
47flatten s = do
47− ss <- Map.traverseWithKey globalSchema (s ^. dSchemas)
48+ _ <- Map.traverseWithKey globalSchema (s ^. dSchemas)
48− ps <- Map.traverseWithKey globalParam (s ^. dParameters)
49+ ps <- Map.traverseWithKey globalParam (s ^. dParameters)
50+
49− rs <- Map.traverseWithKey (resource ps) (s ^. dResources)
51+ rs <- Map.traverseWithKey (resource ps "Resource") (s ^. dResources)
50− ms <- traverse (method ps) (s ^. dMethods)
52+ ms <- traverse (method ps "Method") (s ^. dMethods)
53+
54+ -- The horror.
55+ ss <- use schemas
51
56
52 let d = (s ^. sDescription)
57 let d = (s ^. sDescription)
53− { _dSchemas = ss
58+ { _dSchemas = Map.fromList $ map (join (,)) (Map.keys ss)
54 , _dParameters = ps
59 , _dParameters = ps
55 , _dResources = rs
60 , _dResources = rs
56 , _dMethods = ms
61 , _dMethods = ms
@@ -80,13 +85,13 @@ schema g ml (Fix f) = go f >>= insert this
80 SObj i o -> SObj i <$> object o
85 SObj i o -> SObj i <$> object o
81
86
82 array (Arr e) =
87 array (Arr e) =
83− Arr <$> localSchema this "item" (setRequired e)
88+ Arr <$> localSchema this "" (setRequired e)
84
89
85 object (Obj aps ps) =
90 object (Obj aps ps) =
86 Obj Nothing <$> Map.traverseWithKey (localSchema this) ps
91 Obj Nothing <$> Map.traverseWithKey (localSchema this) ps
87
92
88globalParam :: Local -> Param (Fix Schema) -> AST (Param Global)
93globalParam :: Local -> Param (Fix Schema) -> AST (Param Global)
89−globalParam = localParam "param"
94+globalParam = localParam ""
90
95
91localParam :: Global -> Local -> Param (Fix Schema) -> AST (Param Global)
96localParam :: Global -> Local -> Param (Fix Schema) -> AST (Param Global)
92localParam g l p = do
97localParam g l p = do
@@ -94,28 +99,31 @@ localParam g l p = do
94 pure $! p { _pParam = x }
99 pure $! p { _pParam = x }
95
100
96resource :: Map Local (Param Global)
101resource :: Map Local (Param Global)
102+ -> Suffix
97 -> Global
103 -> Global
98 -> Resource (Fix Schema)
104 -> Resource (Fix Schema)
99 -> AST (Resource Global)
105 -> AST (Resource Global)
100−resource qs g r@Resource {..} = do
106+resource qs suf g r@Resource {..} = do
101− rs <- Map.traverseWithKey (\l -> resource qs (reference g l)) _rResources
107+ rs <- Map.traverseWithKey (\l -> resource qs suf (reference g l)) _rResources
102− ms <- traverse (method qs) _rMethods
108+ ms <- traverse (method qs suf) _rMethods
103 pure $! r
109 pure $! r
104 { _rResources = rs
110 { _rResources = rs
105 , _rMethods = ms
111 , _rMethods = ms
106 }
112 }
107
113
108method :: Map Local (Param Global)
114method :: Map Local (Param Global)
115+ -> Suffix
109 -> Method (Fix Schema)
116 -> Method (Fix Schema)
110 -> AST (Method Global)
117 -> AST (Method Global)
111−method qs m@Method {..} = do
118+method qs suf m@Method {..} = do
112 ps <- Map.traverseWithKey (localParam _mId) _mParameters
119 ps <- Map.traverseWithKey (localParam _mId) _mParameters
113 cn <- use sCanonicalName
120 cn <- use sCanonicalName
114− let (_, typ, _) = mname cn _mId
121+ let (_, typ, _) = mname cn suf _mId
122+ params = ps <> qs
115− void $ insert typ (fresh ps)
123+ void $ insert typ (fresh params)
116− pure $! m { _mParameters = ps }
124+ pure $! m { _mParameters = params }
117 where
125 where
118− fresh ps = SObj info' $ Obj Nothing (Map.map _pParam (ps <> qs))
126+ fresh ps = SObj info' $ Obj Nothing (Map.map _pParam ps)
119
127
120 info' = Info
128 info' = Info
121 { _iId = Nothing
129 { _iId = Nothing
gen/src/Gen/AST/Render.hs+22−20
@@ -55,13 +55,14 @@ import Prelude hiding (sum)
55render :: Service Solved -> AST (API, [Data])
55render :: Service Solved -> AST (API, [Data])
56render s = do
56render s = do
57 a <- renderAPI s
57 a <- renderAPI s
58− ds <- traverse renderSchema (Map.elems (s ^. dSchemas)) <&> catMaybes
59− pure (a, ds)
60
58
61− -- FIXME: filter out action/methods types
59+ let actions = map _actType (_apiResources a <> _apiMethods a)
62−-- let as = map actionTypeName (Map.elems (_apiActions y))
60+ valid = Map.keys . Map.filter (\v -> _unique v `notElem` actions)
63−-- f d = elem (dataName d) as
61+
64−-- z = trace (show as) $ filter (not . f) (catMaybes x)
62+ ss <- traverse getSolved $ valid (s ^. dSchemas)
63+ ds <- traverse renderSchema ss <&> catMaybes
64+
65+ pure (a, ds)
65
66
66renderSchema :: Solved -> AST (Maybe Data)
67renderSchema :: Solved -> AST (Maybe Data)
67renderSchema s = go (_schema s)
68renderSchema s = go (_schema s)
@@ -99,18 +100,18 @@ renderSchema s = go (_schema s)
99 "' with the minimum fields required to make a request.\n")
100 "' with the minimum fields required to make a request.\n")
100 k
101 k
101
102
102−renderMethod :: Service a -> Method Solved -> AST Action
103+renderMethod :: Service a -> NS -> Suffix -> Method Solved -> AST Action
103−renderMethod s m@Method {..} = do
104+renderMethod s root suf m@Method {..} = do
104 x@Solved {..} <- getSolved typ
105 x@Solved {..} <- getSolved typ
105 Just d <- renderSchema x
106 Just d <- renderSchema x
106
107
107 i <- pp Print $ requestDecl _unique _prefix alias url (props _schema) m
108 i <- pp Print $ requestDecl _unique _prefix alias url (props _schema) m
108
109
109− Action _mId (mkNS ns) _mDescription alias
110+ Action _mId _unique (root <> mkNS ns) _mDescription alias
110 <$> pp Print (verbAlias alias m)
111 <$> pp Print (verbAlias alias m)
111 <*> pure (insts [i] d)
112 <*> pure (insts [i] d)
112 where
113 where
113− (alias, typ, ns) = mname (_sCanonicalName s) _mId
114+ (alias, typ, ns) = mname (_sCanonicalName s) suf _mId
114
115
115 url = name (Text.unpack (urlName s))
116 url = name (Text.unpack (urlName s))
116
117
@@ -122,25 +123,26 @@ renderMethod s m@Method {..} = do
122 SObj _ (Obj _ ps) -> Map.keys ps
123 SObj _ (Obj _ ps) -> Map.keys ps
123 _ -> mempty
124 _ -> mempty
124
125
125−renderResource :: Service a -> Resource Solved -> AST [Action]
126+renderResource :: Service a -> NS -> Suffix -> Resource Solved -> AST [Action]
126−renderResource s Resource {..} =
127+renderResource s root suf Resource {..} =
127 liftA2 (<>)
128 liftA2 (<>)
128− (traverse (renderResource s) (Map.elems _rResources) <&> concat)
129+ (traverse (renderResource s root suf) (Map.elems _rResources) <&> concat)
129− (traverse (renderMethod s) _rMethods)
130+ (traverse (renderMethod s root suf) _rMethods)
130
131
131renderAPI :: Service Solved -> AST API
132renderAPI :: Service Solved -> AST API
132renderAPI s = do
133renderAPI s = do
134+ rs <- traverse (renderResource s resourceNS "Resource")
133− rs <- traverse (renderResource s) (Map.elems (s ^. dResources)) <&> concat
135+ (Map.elems (s ^. dResources)) <&> concat
136+
134− ms <- traverse (renderMethod s) (s ^. dMethods)
137+ ms <- traverse (renderMethod s methodNS "Method")
138+ (s ^. dMethods)
139+
135− d <- pp Print (apiAlias alias names)
140+ d <- pp Print $ apiAlias alias (map _actAliasName (rs <> ms))
136
141
137 API alias d rs ms <$> serviceURL
142 API alias d rs ms <$> serviceURL
138 where
143 where
139 alias = aname (_sCanonicalName s)
144 alias = aname (_sCanonicalName s)
140
145
141− names = map _mId (s ^. dMethods)
142− <> Map.keys (s ^. dResources)
143−
144 url = name (Text.unpack (urlName s))
146 url = name (Text.unpack (urlName s))
145
147
146 serviceURL = Fun' url (Just (rawHelpText h))
148 serviceURL = Fun' url (Just (rawHelpText h))
gen/src/Gen/AST/Solve.hs+2−2
@@ -83,14 +83,14 @@ getSchema g = do
83 Just x -> pure x
83 Just x -> pure x
84 Nothing -> throwError $
84 Nothing -> throwError $
85 format ("Missing Schema: " % gid % "\n" % shown)
85 format ("Missing Schema: " % gid % "\n" % shown)
86− g (map global (Map.keys ss))
86+ g (map dname (Map.keys ss))
87
87
88getType :: Global -> AST TType
88getType :: Global -> AST TType
89getType g = loc "getType" g $ memo typed g go
89getType g = loc "getType" g $ memo typed g go
90 where
90 where
91 go s = fmap (may s) $
91 go s = fmap (may s) $
92 case s of
92 case s of
93− SAny {} -> pure (TType "JSON")
93+ SAny {} -> pure (TType "JSONValue")
94 SRef _ r -> getType (ref r)
94 SRef _ r -> getType (ref r)
95 --- FIXME: add natural/numeric manipulations
95 --- FIXME: add natural/numeric manipulations
96 SLit _ l -> pure (TLit l)
96 SLit _ l -> pure (TLit l)
gen/src/Gen/Syntax.hs+48−48
@@ -32,7 +32,7 @@ import Language.Haskell.Exts.SrcLoc
32import Language.Haskell.Exts.Syntax hiding (Int, Lit)
32import Language.Haskell.Exts.Syntax hiding (Int, Lit)
33
33
34urlSig :: Name -> Decl
34urlSig :: Name -> Decl
35−urlSig n = TypeSig noLoc [n] (tycon "BaseUrl")
35+urlSig n = TypeSig noLoc [n] (TyCon "BaseUrl")
36
36
37urlDecl :: Name -> String -> Text -> Integer -> Decl
37urlDecl :: Name -> String -> Text -> Integer -> Decl
38urlDecl n s u p = sfun noLoc n [] (UnGuardedRhs rhs) noBinds
38urlDecl n s u p = sfun noLoc n [] (UnGuardedRhs rhs) noBinds
@@ -40,10 +40,10 @@ urlDecl n s u p = sfun noLoc n [] (UnGuardedRhs rhs) noBinds
40 rhs = appFun (var "BaseUrl") [var (name s), str u, intE p]
40 rhs = appFun (var "BaseUrl") [var (name s), str u, intE p]
41
41
42 -- type API = :<|> ...
42 -- type API = :<|> ...
43−apiAlias :: Name -> [Global] -> Decl
43+apiAlias :: Name -> [Name] -> Decl
44apiAlias n ls = TypeDecl noLoc n [] alias
44apiAlias n ls = TypeDecl noLoc n [] alias
45 where
45 where
46− alias = case map tycon ls of
46+ alias = case map (TyCon . UnQual) ls of
47 [] -> unit_tycon
47 [] -> unit_tycon
48 x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r) x xs
48 x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r) x xs
49
49
@@ -67,7 +67,7 @@ verbAlias n m = TypeDecl noLoc n [] alias
67 , c == '{'
67 , c == '{'
68 , Just k <- Map.lookup (toKey (Text.init t)) params
68 , Just k <- Map.lookup (toKey (Text.init t)) params
69 , _pLocation k == Path
69 , _pLocation k == Path
70− = TyApp (TyApp (tycon "Capture")
70+ = TyApp (TyApp (TyCon "Capture")
71 (sing (Text.init t)))
71 (sing (Text.init t)))
72 (terminalType (_type (_pParam k)))
72 (terminalType (_type (_pParam k)))
73 | otherwise = sing x
73 | otherwise = sing x
@@ -81,8 +81,8 @@ verbAlias n m = TypeDecl noLoc n [] alias
81 n = sing (local k)
81 n = sing (local k)
82 in case _pLocation x of
82 in case _pLocation x of
83 Query | x ^. iRepeated
83 Query | x ^. iRepeated
84− -> Just $ TyApp (TyApp (tycon "QueryParams") n) t
84+ -> Just $ TyApp (TyApp (TyCon "QueryParams") n) t
85− Query -> Just $ TyApp (TyApp (tycon "QueryParam") n) t
85+ Query -> Just $ TyApp (TyApp (TyCon "QueryParam") n) t
86 Path -> Nothing
86 Path -> Nothing
87
87
88 params = _mParameters m
88 params = _mParameters m
@@ -91,8 +91,8 @@ verbAlias n m = TypeDecl noLoc n [] alias
91 verb = TyApp (TyApp meth typ) res
91 verb = TyApp (TyApp meth typ) res
92 where
92 where
93 meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mHttpMethod m)
93 meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mHttpMethod m)
94− typ = tycon "'[JSON]"
94+ typ = TyCon "'[JSON]"
95− res = maybe (tycon "()") (tycon . ref) (_mResponse m)
95+ res = maybe (TyCon "()") (tycon . ref) (_mResponse m)
96
96
97requestDecl :: Global
97requestDecl :: Global
98 -> Prefix
98 -> Prefix
@@ -108,7 +108,7 @@ requestDecl n p api url fs m =
108 , requestWithRoute
108 , requestWithRoute
109 ]
109 ]
110 where
110 where
111− response = InsType noLoc (TyApp (tycon "Rs") (tycon n)) $
111+ response = InsType noLoc (TyApp (TyCon "Rs") (tycon n)) $
112 maybe unit_tycon (tycon . ref) (_mResponse m)
112 maybe unit_tycon (tycon . ref) (_mResponse m)
113
113
114 request = funD "request" $
114 request = funD "request" $
@@ -122,7 +122,7 @@ requestDecl n p api url fs m =
122 [ patBind noLoc (pvar "go") $
122 [ patBind noLoc (pvar "go") $
123 appFun (var "clientWithRoute") $
123 appFun (var "clientWithRoute") $
124 [ ExpTypeSig noLoc (var "Proxy") $
124 [ ExpTypeSig noLoc (var "Proxy") $
125− TyApp (tycon "Proxy") (TyCon (UnQual api))
125+ TyApp (TyCon "Proxy") (TyCon (UnQual api))
126 , var "r"
126 , var "r"
127 , var "u"
127 , var "u"
128 ]
128 ]
@@ -142,13 +142,13 @@ requestDecl n p api url fs m =
142 prec = PRec (UnQual (dname n)) [PFieldWildcard]
142 prec = PRec (UnQual (dname n)) [PFieldWildcard]
143
143
144jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]
144jsonDecls :: Global -> Prefix -> Map Local Solved -> [Decl]
145−jsonDecls n p (Map.toList -> rs) = [from, to]
145+jsonDecls g p (Map.toList -> rs) = [from, to]
146 where
146 where
147− from = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon n]
147+ from = InstDecl noLoc Nothing [] [] (unqual "FromJSON") [tycon g]
148 [ funD "parseJSON" $
148 [ funD "parseJSON" $
149− app (app (var "withObject") (str (global n))) $
149+ app (app (var "withObject") (dstr g)) $
150 lamE noLoc [pvar "o"] $
150 lamE noLoc [pvar "o"] $
151− ctorE n (map decode rs)
151+ ctorE g (map decode rs)
152 ]
152 ]
153
153
154 decode (l, s)
154 decode (l, s)
@@ -157,8 +157,8 @@ jsonDecls n p (Map.toList -> rs) = [from, to]
157 | monoid s = defJS l (var "mempty")
157 | monoid s = defJS l (var "mempty")
158 | otherwise = optJS l
158 | otherwise = optJS l
159
159
160− to = InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon n]
160+ to = InstDecl noLoc Nothing [] [] (unqual "ToJSON") [tycon g]
161− [ wildcardD "toJSON" n omit none (map encode rs)
161+ [ wildcardD "toJSON" g omit none (map encode rs)
162 ]
162 ]
163
163
164 omit = app (var "object")
164 omit = app (var "object")
@@ -171,7 +171,7 @@ jsonDecls n p (Map.toList -> rs) = [from, to]
171 | TMaybe {} <- _type s = infixApp (paren (app n o)) "<$>" a
171 | TMaybe {} <- _type s = infixApp (paren (app n o)) "<$>" a
172 | otherwise = app (var "Just") (infixApp n ".=" a)
172 | otherwise = app (var "Just") (infixApp n ".=" a)
173 where
173 where
174− n = str (local l)
174+ n = fstr l
175 a = var (fname p l)
175 a = var (fname p l)
176 o = var ".="
176 o = var ".="
177
177
@@ -191,13 +191,13 @@ wildcardD f n enc x = \case
191 prec = PRec (UnQual (dname n)) [PFieldWildcard]
191 prec = PRec (UnQual (dname n)) [PFieldWildcard]
192
192
193defJS :: Local -> Exp -> Exp
193defJS :: Local -> Exp -> Exp
194−defJS n x = infixApp (infixApp (var "o") ".:?" (str (local n))) ".!=" x
194+defJS n x = infixApp (infixApp (var "o") ".:?" (fstr n)) ".!=" x
195
195
196reqJS :: Local -> Exp
196reqJS :: Local -> Exp
197−reqJS = infixApp (var "o") ".:" . str . local
197+reqJS = infixApp (var "o") ".:" . fstr
198
198
199optJS :: Local -> Exp
199optJS :: Local -> Exp
200−optJS = infixApp (var "o") ".:?" . str . local
200+optJS = infixApp (var "o") ".:?" . fstr
201
201
202funD :: String -> Exp -> InstDecl
202funD :: String -> Exp -> InstDecl
203funD f = InsDecl . patBind noLoc (pvar (name f))
203funD f = InsDecl . patBind noLoc (pvar (name f))
@@ -263,7 +263,7 @@ fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
263
263
264lensSig :: Global -> Prefix -> Local -> Solved -> Decl
264lensSig :: Global -> Prefix -> Local -> Solved -> Decl
265lensSig n p l s = TypeSig noLoc [lname p l] $
265lensSig n p l s = TypeSig noLoc [lname p l] $
266− TyApp (TyApp (tycon "Lens'") (tycon n))
266+ TyApp (TyApp (TyCon "Lens'") (tycon n))
267 (externalType (_type s))
267 (externalType (_type s))
268
268
269lensDecl :: Prefix -> Local -> Solved -> Decl
269lensDecl :: Prefix -> Local -> Solved -> Decl
@@ -305,46 +305,46 @@ externalType :: TType -> Type
305externalType = \case
305externalType = \case
306 TType r -> tycon r
306 TType r -> tycon r
307 TMaybe t@TList {} -> externalType t
307 TMaybe t@TList {} -> externalType t
308− TMaybe t -> TyApp (tycon "Maybe") (externalType t)
308+ TMaybe t -> TyApp (TyCon "Maybe") (externalType t)
309 TList t -> TyList (externalType t)
309 TList t -> TyList (externalType t)
310 TLit l -> externalLit l
310 TLit l -> externalLit l
311
311
312internalType :: TType -> Type
312internalType :: TType -> Type
313internalType = \case
313internalType = \case
314 TType r -> tycon r
314 TType r -> tycon r
315− TMaybe t -> TyApp (tycon "Maybe") (internalType t)
315+ TMaybe t -> TyApp (TyCon "Maybe") (internalType t)
316 TList t -> TyList (internalType t)
316 TList t -> TyList (internalType t)
317 TLit l -> internalLit l
317 TLit l -> internalLit l
318
318
319externalLit :: Lit -> Type
319externalLit :: Lit -> Type
320externalLit = \case
320externalLit = \case
321− Text -> tycon "Text"
321+ Text -> TyCon "Text"
322− Bool -> tycon "Bool"
322+ Bool -> TyCon "Bool"
323− Time -> tycon "UTCTime"
323+ Time -> TyCon "UTCTime"
324− Date -> tycon "UTCTime"
324+ Date -> TyCon "UTCTime"
325− Nat -> tycon "Natural"
325+ Nat -> TyCon "Natural"
326− Float -> tycon "Float"
326+ Float -> TyCon "Float"
327− Double -> tycon "Double"
327+ Double -> TyCon "Double"
328− Byte -> tycon "Word8"
328+ Byte -> TyCon "Word8"
329− UInt32 -> tycon "Word32"
329+ UInt32 -> TyCon "Word32"
330− UInt64 -> tycon "Word64"
330+ UInt64 -> TyCon "Word64"
331− Int32 -> tycon "Int32"
331+ Int32 -> TyCon "Int32"
332− Int64 -> tycon "Int64"
332+ Int64 -> TyCon "Int64"
333
333
334internalLit :: Lit -> Type
334internalLit :: Lit -> Type
335internalLit = \case
335internalLit = \case
336− Text -> tycon "Text"
336+ Text -> TyCon "Text"
337− Bool -> tycon "Bool"
337+ Bool -> TyCon "Bool"
338− Time -> tycon "UTCTime"
338+ Time -> TyCon "UTCTime"
339− Date -> tycon "UTCTime"
339+ Date -> TyCon "UTCTime"
340− Nat -> tycon "Nat"
340+ Nat -> TyCon "Nat"
341− Float -> tycon "Float"
341+ Float -> TyCon "Float"
342− Double -> tycon "Double"
342+ Double -> TyCon "Double"
343− Byte -> tycon "Word8"
343+ Byte -> TyCon "Word8"
344− UInt32 -> tycon "Word32"
344+ UInt32 -> TyCon "Word32"
345− UInt64 -> tycon "Word64"
345+ UInt64 -> TyCon "Word64"
346− Int32 -> tycon "Int32"
346+ Int32 -> TyCon "Int32"
347− Int64 -> tycon "Int64"
347+ Int64 -> TyCon "Int64"
348
348
349mapping :: TType -> Exp -> Exp
349mapping :: TType -> Exp -> Exp
350mapping t e = infixE e "." (go t)
350mapping t e = infixE e "." (go t)
@@ -372,7 +372,7 @@ sing :: Text -> Type
372sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""
372sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""
373
373
374tycon :: Global -> Type
374tycon :: Global -> Type
375−tycon = TyCon . unqual . Text.unpack . global
375+tycon = TyCon . UnQual . dname
376
376
377unqual :: String -> QName
377unqual :: String -> QName
378unqual = UnQual . name
378unqual = UnQual . name
gen/src/Gen/Text.hs+1−1
@@ -173,7 +173,7 @@ upperAcronym x = Fold.foldl' (flip (uncurry RE.replaceAll)) x xs
173 , ("Raid", "RAID")
173 , ("Raid", "RAID")
174 , ("Ramdisk", "RAMDisk")
174 , ("Ramdisk", "RAMDisk")
175 , ("Sgd", "SGD")
175 , ("Sgd", "SGD")
176− , ("Sni", "SNI")
176+ , ("Sni([^p]|$)", "SNI$1")
177 , ("Ssh", "SSH")
177 , ("Ssh", "SSH")
178 , ("Ssl", "SSL")
178 , ("Ssl", "SSL")
179 , ("Svn", "SVN")
179 , ("Svn", "SVN")
gen/src/Gen/Tree.hs+3−2
@@ -87,11 +87,12 @@ populate d Templates {..} l = (encodeString d :/) . dir lib <$> layout
87 ++ map method (_apiMethods (l ^. lAPI))
87 ++ map method (_apiMethods (l ^. lAPI))
88 ]
88 ]
89 where
89 where
90+ -- FIXME: now redundant
90 resource a =
91 resource a =
91− mod' (resourceNS a) actionImports actionTemplate (action a)
92+ mod' (_actNamespace a) actionImports actionTemplate (action a)
92
93
93 method a =
94 method a =
94− mod' (methodNS a) actionImports actionTemplate (action a)
95+ mod' (_actNamespace a) actionImports actionTemplate (action a)
95
96
96 action a =
97 action a =
97 let Object o = object ["action" .= a]
98 let Object o = object ["action" .= a]
gen/src/Gen/Types.hs+6−2
@@ -165,12 +165,16 @@ sumNS = (<> "Sum") . typesNS
165preludeNS :: NS
165preludeNS :: NS
166preludeNS = "Network.Google.Prelude"
166preludeNS = "Network.Google.Prelude"
167
167
168+resourceNS, methodNS :: NS
169+resourceNS = "Network.Google.Resource"
170+methodNS = "Network.Google.Method"
171+
168exposedModules :: Library -> [NS]
172exposedModules :: Library -> [NS]
169exposedModules l = sort $
173exposedModules l = sort $
170 tocNS l
174 tocNS l
171 : typesNS l
175 : typesNS l
172− : map resourceNS (_apiResources (_lAPI l))
176+ : map _actNamespace (_apiResources (_lAPI l))
173− ++ map methodNS (_apiMethods (_lAPI l))
177+ ++ map _actNamespace (_apiMethods (_lAPI l))
174
178
175otherModules :: Library -> [NS]
179otherModules :: Library -> [NS]
176otherModules s = sort [prodNS s, sumNS s]
180otherModules s = sort [prodNS s, sumNS s]
gen/src/Gen/Types/Data.hs+1−11
@@ -119,6 +119,7 @@ dataName = \case
119
119
120data Action = Action
120data Action = Action
121 { _actId :: Global
121 { _actId :: Global
122+ , _actType :: Global
122 , _actNamespace :: NS
123 , _actNamespace :: NS
123 , _actHelp :: Maybe Help
124 , _actHelp :: Maybe Help
124 , _actAliasName :: Name
125 , _actAliasName :: Name
@@ -126,9 +127,6 @@ data Action = Action
126 , _actData :: Data
127 , _actData :: Data
127 }
128 }
128
129
129−actionTypeName :: Action -> Name
130−actionTypeName = dataName . _actData
131−
132instance ToJSON Action where
130instance ToJSON Action where
133 toJSON Action {..} = object
131 toJSON Action {..} = object
134 [ "id" .= _actId
132 [ "id" .= _actId
@@ -156,11 +154,3 @@ instance ToJSON API where
156 , "methods" .= sortOn _actId _apiMethods
154 , "methods" .= sortOn _actId _apiMethods
157 , "url" .= _apiURL
155 , "url" .= _apiURL
158 ]
156 ]
159−
160−-- apiResourceNames, apiMethodNames :: API -> [Name]
161−-- apiResourceNames = map (dataName . _actData) . _apiResources
162−-- apiMethodNames = map (dataName . _actData) . _apiMethods
163−
164−resourceNS, methodNS :: Action -> NS
165−resourceNS = mappend "Network.Google.Resource" . _actNamespace
166−methodNS = mappend "Network.Google.Method" . _actNamespace
gen/src/Gen/Types/Id.hs+19−8
@@ -13,8 +13,9 @@
13
13
14module Gen.Types.Id
14module Gen.Types.Id
15 (
15 (
16− -- * Property Prefixes
16+ -- * Properties
17 Prefix (..)
17 Prefix (..)
18+ , Suffix (..)
18
19
19 -- * Unique Identifiers
20 -- * Unique Identifiers
20 , Global
21 , Global
@@ -32,9 +33,11 @@ module Gen.Types.Id
32 , aname
33 , aname
33 , mname
34 , mname
34 , dname
35 , dname
36+ , dstr
35 , cname
37 , cname
36 , bname
38 , bname
37 , fname
39 , fname
40+ , fstr
38 , lname
41 , lname
39 , pname
42 , pname
40 ) where
43 ) where
@@ -74,11 +77,11 @@ import Language.Haskell.Exts.Syntax (Name)
74aname :: Text -> Name
77aname :: Text -> Name
75aname = name . Text.unpack . (<> "API") . upperHead . Text.replace "." ""
78aname = name . Text.unpack . (<> "API") . upperHead . Text.replace "." ""
76
79
77−mname :: Text -> Global -> (Name, Global, Text)
80+mname :: Text -> Suffix -> Global -> (Name, Global, Text)
78−mname abrv (Global g) =
81+mname abrv (Suffix suf) (Global g) =
79− ( aname (mconcat n) -- Action service type alias.
82+ ( name . Text.unpack $ mconcat n <> suf -- Action service type alias.
80− , Global (n <> ["'"]) -- Action data type.
83+ , Global (n <> ["'"]) -- Action data type.
81− , Text.intercalate "." ns -- Action namespace.
84+ , Text.intercalate "." ns -- Action namespace.
82 )
85 )
83 where
86 where
84 n = drop 1 (map (upperHead . upperAcronym) ns)
87 n = drop 1 (map (upperHead . upperAcronym) ns)
@@ -90,8 +93,8 @@ mname abrv (Global g) =
90 x:xs = g
93 x:xs = g
91
94
92dname, cname :: Global -> Name
95dname, cname :: Global -> Name
93−dname = name . Text.unpack . toPascal . global
96+dname = name . Text.unpack . upperHead . global
94−cname = name . Text.unpack . renameReserved . toCamel . global
97+cname = name . Text.unpack . renameReserved . lowerHead . global
95
98
96bname :: Prefix -> Text -> Name
99bname :: Prefix -> Text -> Name
97bname (Prefix p) = name
100bname (Prefix p) = name
@@ -104,9 +107,17 @@ fname = pre (Text.cons '_' . renameField)
104lname = pre renameField
107lname = pre renameField
105pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead . renameField)
108pname = pre (flip Text.snoc '_' . Text.cons 'p' . upperHead . renameField)
106
109
110+--dstr :: Global ->
111+dstr = strE . Text.unpack . toPascal . global
112+
113+fstr = strE . Text.unpack . local
114+
107pre :: (Text -> Text) -> Prefix -> Local -> Name
115pre :: (Text -> Text) -> Prefix -> Local -> Name
108pre f (Prefix p) = name . Text.unpack . f . mappend p . upperHead . local
116pre f (Prefix p) = name . Text.unpack . f . mappend p . upperHead . local
109
117
118+newtype Suffix = Suffix Text
119+ deriving (Show, IsString)
120+
110newtype Prefix = Prefix Text
121newtype Prefix = Prefix Text
111 deriving (Show, Monoid)
122 deriving (Show, Monoid)
112
123
gen/src/Gen/Types/Schema.hs+2−2
@@ -126,11 +126,11 @@ instance FromJSON (Fix Schema) where
126 parseJSON o = do
126 parseJSON o = do
127 i <- parseJSON o
127 i <- parseJSON o
128 s <- SRef i <$> parseJSON o
128 s <- SRef i <$> parseJSON o
129− <|> SAny i <$> parseJSON o
130− <|> SLit i <$> parseJSON o
131 <|> SEnm i <$> parseJSON o
129 <|> SEnm i <$> parseJSON o
132 <|> SArr i <$> parseJSON o
130 <|> SArr i <$> parseJSON o
133 <|> SObj i <$> parseJSON o
131 <|> SObj i <$> parseJSON o
132+ <|> SLit i <$> parseJSON o
133+ <|> SAny i <$> parseJSON o
134 pure (Fix s)
134 pure (Fix s)
135
135
136instance HasInfo (Schema a) where
136instance HasInfo (Schema a) where
gen/template/action.ede+1
@@ -1,6 +1,7 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE DeriveGeneric #-}
3{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeFamilies #-}
6{-# LANGUAGE TypeOperators #-}
7{-# LANGUAGE TypeOperators #-}