git.iko.soy/gogol
on develop help sign in
End of prototype
commitf42c2ede7604a17b4393be37018ae240cae2c016 authorBrendan Hay <brendan.g.hay@gmail.com> dateMon 28 Sep 2015, 19:06 (11 years ago) parent2e33036
9 files changed+52−18
compare with develop
unifiedsplit
gen/src/Gen/AST.hs+9−6 gen/src/Gen/Solve.hs+6−1 gen/src/Gen/Syntax.hs+14−4 gen/src/Gen/Text.hs+4 gen/src/Gen/Tree.hs+1−1 gen/src/Gen/Types.hs+9−4 gen/src/Gen/Types/Help.hs+6 gen/template/_include/sum.ede+2−1 gen/template/cabal.ede+1−1
gen/src/Gen/AST.hs+9−6
@@ -44,9 +44,12 @@ import Language.Haskell.Exts.Pretty
4444import Prelude hiding (sum)
4545
4646runAST :: Parsed -> Either Error Printed
47−runAST svc = evalState (runExceptT (go svc)) initial
47+runAST svc = evalState (runExceptT go) initial
4848 where
49− go = flatten >=> solveAll >=> render
49+ go = do
50+ x <- flatten svc
51+ reserve x
52+ solveAll x >>= render
5053
5154render :: Typed -> AST Printed
5255render svc = do
@@ -55,7 +58,7 @@ render svc = do
5558
5659 let as = map actionTypeName (Map.elems (_apiActions y))
5760 f d = elem (dataName d) as
58− z = filter (not . f) (catMaybes x)
61+ z = trace (show as) $ filter (not . f) (catMaybes x)
5962
6063 return $! svc { _svcSchemas = z, _svcParameters = (), _svcApi = y }
6164 where
@@ -66,7 +69,8 @@ render svc = do
6669 Any {} -> pure Nothing
6770 Lit {} -> pure Nothing
6871 Enum i vs ds -> pure . Just $
69− Sum (dname _ident) (i ^. description) (zipWith branch vs (ds ++ repeat ""))
72+ Sum (dname _ident) (i ^. description) $
73+ zipWith branch vs (ds ++ repeat mempty)
7074 where
7175 branch v = Branch (bname _prefix v) v
7276
@@ -138,8 +142,7 @@ render svc = do
138142 d@Sum {} -> pure d
139143 Prod n' h r c ls _ ->
140144 Prod n' h r c ls . (:[]) <$> pp Print
141− (requestDecl (_ident s) (_prefix s) k un (fields (_schema s))
142− (fmap Free (_mResponse m)))
145+ (requestDecl (_ident s) (_prefix s) k un (fields (_schema s)) m)
143146
144147 fields = \case
145148 Obj _ rs -> Map.keys rs
gen/src/Gen/Solve.hs+6−1
@@ -60,6 +60,11 @@ makeLenses ''Memo
6060
6161type AST = ExceptT Error (State Memo)
6262
63+reserve :: Flattened -> AST ()
64+reserve svc = do
65+ let bs = Set.fromList $ map (CI.mk . idToText) (_svcSchemas svc)
66+ branches %= Map.insert mempty bs
67+
6368schema :: Id -> AST (Schema Id)
6469schema k = do
6570 m <- uses schemas (Map.lookup k)
@@ -128,7 +133,7 @@ prefix n = loc "prefix" n $ memo prefixed n typ
128133 _ -> pure mempty
129134
130135 branch vs = do
131− p <- uniq branches (acronymPrefixes n) $
136+ p <- uniq branches ("" : acronymPrefixes n) $
132137 Set.fromList (map CI.mk vs)
133138 pure (Pre p)
134139
gen/src/Gen/Syntax.hs+14−4
@@ -18,6 +18,7 @@ import Data.Foldable (find, foldl', foldr')
1818import Data.Hashable
1919import qualified Data.HashMap.Strict as Map
2020import Data.Maybe
21+import Data.Maybe
2122import Data.Semigroup ((<>))
2223import Data.String
2324import Data.Text (Text)
@@ -94,8 +95,8 @@ verbAlias n m = TypeDecl noLoc n [] alias
9495 typ = tycon "'[JSON]"
9596 res = maybe (tycon "()") (tycon . Free) (_mResponse m)
9697
97−requestDecl :: Id -> Pre -> Name -> Name -> [Local] -> Maybe Id -> Decl
98−requestDecl n p api url fs rq =
98+requestDecl :: Id -> Pre -> Name -> Name -> [Local] -> Method a -> Decl
99+requestDecl n p api url fs m =
99100 -- FIXME: associated Rs type
100101 InstDecl noLoc Nothing [] [] (unqual "GoogleRequest") [tycon n]
101102 [ response
@@ -104,7 +105,7 @@ requestDecl n p api url fs rq =
104105 ]
105106 where
106107 response = InsType noLoc (TyApp (tycon "Rs") (tycon n)) $
107− maybe unit_tycon tycon rq
108+ maybe unit_tycon tycon (Free <$> _mResponse m)
108109
109110 request = funD "request" $
110111 appFun (var "requestWithRoute") [var "defReq", var url]
@@ -123,7 +124,16 @@ requestDecl n p api url fs rq =
123124 ]
124125 ]
125126
126− rhs = UnGuardedRhs . appFun (var "go") $ map (var . fname p) fs
127+ rhs = UnGuardedRhs $ appFun (var "go") (map go fs)
128+ where
129+ go l | Just p <- Map.lookup l ps
130+ , _prmLocation p == Query
131+ , parameter p || isJust (p ^. defaulted)
132+ = app (var "Just") (v l)
133+ | otherwise = v l
134+
135+ ps = _mParameters m
136+ v = var . fname p
127137
128138 pats = [pvar "r", pvar "u", prec]
129139 prec = PRec (UnQual (dname n)) [PFieldWildcard]
gen/src/Gen/Text.hs+4
@@ -118,6 +118,9 @@ renameReserved x
118118 , "get"
119119 , "group"
120120 , "error"
121+ , "True"
122+ , "False"
123+ , "Error"
121124 ] ++ map Text.pack (reservedNames haskellDef)
122125
123126camelAcronym :: Text -> Text
@@ -192,6 +195,7 @@ upperAcronym x = Fold.foldl' (flip (uncurry RE.replaceAll)) x xs
192195 , ("Gt$", "GT")
193196 , ("Nat", "NAT")
194197 , ("Youtube", "YouTube")
198+ , ("Cnc", "CNC")
195199 ]
196200
197201acronyms :: [(String, String)]
gen/src/Gen/Tree.hs+1−1
@@ -81,7 +81,7 @@ populate d Templates{..} l = (encodeString d :/) . dir lib <$> layout
8181 ]
8282
8383 service s =
84− [ mod' (tocNS s) mempty tocTemplate (pure svc)
84+ [ mod' (tocNS s) (tocImports s) tocTemplate (pure svc)
8585 , mod' (typesNS s) (typeImports s) typesTemplate (pure svc)
8686 , mod' (prodNS s) (prodImports s) prodTemplate (pure svc)
8787 , mod' (sumNS s) (sumImports s) sumTemplate (pure svc)
gen/src/Gen/Types.hs+9−4
@@ -225,7 +225,7 @@ deriveToJSON (js "") ''Lit
225225data Schema a
226226 = Obj Info (Map Local a)
227227 | Arr Info a
228− | Enum Info [Text] [Text]
228+ | Enum Info [Text] [Help]
229229 | Lit Info Lit
230230 | Ref Info Global
231231 | Any Info -- String or Number
@@ -287,6 +287,9 @@ instance FromJSON a => FromJSON (Param a) where
287287 <*> parseJSON (Object o)
288288 <*> parseJSON (Object o)
289289
290+instance HasInfo (Param a) where
291+ info = lens _prmInfo (\s a -> s { _prmInfo = a })
292+
290293data TType
291294 = TType Id
292295 | TLit Lit
@@ -341,13 +344,13 @@ instance ToJSON Fun where
341344 , "decl" .= d
342345 ]
343346
344−data Branch = Branch Name Text Text
347+data Branch = Branch Name Text Help
345348
346349instance ToJSON Branch where
347350 toJSON (Branch n v h) = object
348351 [ "name" .= Syn n
349352 , "value" .= v
350− , "help" .= h
353+ , "help" .= Below 6 h
351354 ]
352355
353356data Data
@@ -521,7 +524,9 @@ svcURL = (<> "URL") . lowerHead . svcAbbrev
521524svcActions :: Service s p API -> [Action]
522525svcActions = Map.elems . _apiActions . _svcApi
523526
524−typeImports, prodImports, sumImports, actionImports :: Service s p r -> [NS]
527+tocImports, typeImports, prodImports, sumImports, actionImports
528+ :: Service s p r -> [NS]
529+tocImports _ = ["Network.Google.Prelude"]
525530typeImports s = sort ["Network.Google.Prelude", prodNS s, sumNS s]
526531prodImports s = sort ["Network.Google.Prelude", sumNS s]
527532sumImports _ = sort ["Network.Google.Prelude"]
gen/src/Gen/Types/Help.hs+6
@@ -11,6 +11,7 @@
1111module Gen.Types.Help
1212 ( Help
1313 , Desc (..)
14+ , Below (..)
1415 , rawHelpText
1516 ) where
1617
@@ -72,6 +73,11 @@ data Desc = Desc !Int Help
7273instance ToJSON Desc where
7374 toJSON (Desc n h) = toJSON . wrap (replicate n ' ') $ flatten h
7475
76+data Below = Below !Int Help
77+
78+instance ToJSON Below where
79+ toJSON (Below n h) = toJSON . wrap (replicate n ' ' <> "-- ") $ flatten h
80+
7581flatten :: Help -> String
7682flatten = \case
7783 Help xs -> foldMap flatten xs
gen/template/_include/sum.ede+2−1
@@ -7,7 +7,8 @@ data {{ type.name }}
77 {% if branch.value.help == "" %}
88 -- ^ @{{ branch.value.value }}@
99 {% else %}
10− -- ^ @{{ branch.value.value }}@ - {{ branch.value.help }}
10+ -- ^ @{{ branch.value.value }}@
11+{{ branch.value.help }}
1112 {% endif %}
1213 {% endfor %}
1314 deriving (Eq,Ord,Enum,Read,Show,Data,Typeable,Generic)
gen/template/cabal.ede+1−1
@@ -19,7 +19,7 @@ description:
1919{% endfor %}
2020 .
2121 /Warning:/ This is an experimental preview release which is still under
22− heavy development and not intended for public consumption, caveat emptor!
22+ heavy development and not intended for public use, caveat emptor!
2323
2424source-repository head
2525 type: git