git.iko.soy/gogol
on b3333d6 help sign in
gogol/gen/src/Gen/Syntax.hs
230 lines 7.1 kB history raw
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE TupleSections #-}
5{-# OPTIONS_GHC -fno-warn-orphans #-}
7-- Module : Gen.Syntax
8-- Copyright : (c) 2015 Brendan Hay
9-- License : Mozilla Public License, v. 2.0.
10-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
11-- Stability : provisional
12-- Portability : non-portable (GHC extensions)
14module Gen.Syntax where
16import Control.Lens hiding (iso, mapping, op, pre,
17 strict)
18import Data.Foldable (foldl', foldr')
19import Data.Hashable
20import qualified Data.HashMap.Strict as Map
21import Data.Maybe
22import Data.Semigroup ((<>))
23import Data.String
24import Data.Text (Text)
25import qualified Data.Text as Text
26import Data.Text.Manipulate
27import Gen.Orphans
28import Gen.Solve
29import Gen.Text
30import Gen.Types
31import Language.Haskell.Exts.Build
32import Language.Haskell.Exts.SrcLoc
33import Language.Haskell.Exts.Syntax hiding (Int, Lit)
35 -- type API = :<|> ...
36apiAlias :: Name -> [Name] -> Decl
37apiAlias n ls = TypeDecl noLoc n [] alias
38 where
39 alias = case map (TyCon . UnQual) ls of
40 [] -> unit_tycon
41 x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":<|>")) r) x xs
43-- type Method = :> ...
44verbDecl :: Service s r -> Local -> Local -> Method -> Decl
45verbDecl s p l m = TypeDecl noLoc (vname p l) [] alias
46 where
47 alias = case path ++ qry of
48 [] -> unit_tycon
49 x:xs -> foldl' (\l r -> TyInfix l (UnQual (sym ":>")) r) x xs
51-- Need to deal with interpolation?
53 path :: [Type]
54 path = map match
55 . filter (not . Text.null)
56 $ Text.split (== '/') (_svcServicePath s)
57 <> Text.split (== '/') (_mPath m)
58 where
59 match x
60 | Just (c, t) <- Text.uncons x
61 , c == '{'
62 , Just k <- Map.lookup (Local (Text.init t)) params
63 , _prmLocation k == Path
64 = TyApp (TyApp (tycon "Capture")
65 (sing (Text.init t)))
66 (literal (_prmLiteral k))
67 | otherwise = sing x
69 -- FIXME: order by _mParameterOrder
70 qry :: [Type]
71 qry = mapMaybe f (Map.toList params)
72 where
73 f (k, p) =
74 -- FIXME: types, many/repeated
75 let t = literal (_prmLiteral p)
76 n = sing (local k)
77 in case _prmLocation p of
78 Query -> Just $ TyApp (TyApp (tycon "QueryParam") n) t
79 Path -> Nothing
81 params = _svcParameters s <> _mParameters m
83 verb :: Type
84 verb = TyApp (TyApp meth typ) res
85 where
86 meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mMethod m)
87 typ = tycon "'[JSON]"
88 res = maybe (tycon "()") (tycon . Free) (_mResponse m)
90objDecl :: Id -> Pre -> Map Local Solved -> AST Decl
91objDecl n p rs = DataDecl noLoc arity [] d [] [conDecl d p rs] <$> derivings n
92 where
93 d = dname n
95 arity | Map.size rs == 1 = NewType
96 | otherwise = DataType
98conDecl :: Name -> Pre -> Map Local Solved -> QualConDecl
99conDecl n p rs = QualConDecl noLoc [] [] body
100 where
101 body = case Map.toList rs of
102 [] -> ConDecl n []
103 [x] -> RecDecl n [field internal x]
104 xs -> RecDecl n (map (field (strict . internal)) xs)
106 field f (l, v) = ([fname p l], f (_type v))
108ctorSig :: Id -> Map Local Solved -> Decl
109ctorSig n rs = TypeSig noLoc [cname n] ts
110 where
111 ts = foldr' TyFun (TyCon (UnQual (dname n))) ps
112 ps = parameters (Map.elems rs)
114ctorDecl :: Id -> Pre -> Map Local Solved -> Decl
115ctorDecl n p rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds
116 where
117 c = cname n
118 d = dname n
120 rhs | Map.null rs = var d
121 | otherwise = RecConstr (UnQual d) $
122 map (uncurry (fieldUpdate p)) (Map.toList rs)
124 ps = map (pname p) . Map.keys $ Map.filter (view required) rs
126fieldUpdate :: Pre -> Local -> Solved -> FieldUpdate
127fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
128 where
129 rhs | s ^. required = v
130 | Just x <- s ^. defaulted = def x (_schema s)
131 | Just x <- iso (_type s) = infixApp x "#" v
132 | otherwise = var (name "Nothing")
134 v = var (pname p l)
136 def x = \case
137 Enum {} -> var (bname (_prefix s) x)
138 Lit _ Bool -> lit (upperHead x)
139 Lit _ Text -> str x
140 Lit _ _ -> lit x
141 --- FIXME: lift to AST
142 s -> error $ "Unmatched fieldUpdate:\n" ++ show s
144 lit = var . name . Text.unpack
146lensSig :: Id -> Pre -> Local -> Solved -> Decl
147lensSig n p l s = TypeSig noLoc [lname p l] $
148 TyApp (TyApp (tycon "Lens'") (tycon n))
149 (external (_type s))
151lensDecl :: Pre -> Local -> Solved -> Decl
152lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds
153 where
154 f = fname p l
155 t = _type s
157 rhs = mapping t $
158 app (app (var "lens") (var f))
159 (paren (lamE noLoc [pvar "s", pvar "a"]
160 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))
162derivings :: Id -> AST [Deriving]
163derivings k = map ((,[]) . unqual . drop 1 . show) <$> derive k
165parameters :: [Solved] -> [Type]
166parameters = map (external . _type) . filter (view required)
168external, internal :: TType -> Type
169external = internal . \case
170 TMaybe t@TList {} -> t
171 t -> t
173internal = \case
174 TType r -> tycon r
175 TMaybe t -> TyApp (tycon "Maybe") (internal t)
176 TEither a b -> TyApp (TyApp (tycon "Either") (internal a)) (internal b)
177 TList t -> TyList (internal t)
178 TLit l -> literal l
180literal :: Lit -> Type
181literal = \case
182 Text -> tycon "Text"
183 Bool -> tycon "Bool"
184 Time -> tycon "UTCTime"
185 Date -> tycon "UTCTime"
186 Nat -> tycon "Natural"
187 Float -> tycon "Float"
188 Double -> tycon "Double"
189 Byte -> tycon "Word8"
190 UInt32 -> tycon "Word32"
191 UInt64 -> tycon "Word64"
192 Int32 -> tycon "Int32"
193 Int64 -> tycon "Int64"
195mapping :: TType -> Exp -> Exp
196mapping t e = infixE e "." (go t)
197 where
198 go = \case
199 TMaybe x@(TList {}) -> var "_Default" : go x
200 TMaybe x -> nest (go x)
201 x -> maybeToList (iso x)
203 nest [] = []
204 nest (x:xs) = [app (var "mapping") (infixE x "." xs)]
206iso :: TType -> Maybe Exp
207iso = \case
208 TList {} -> Just (var "_Coerce")
209 _ -> Nothing
211strict :: Type -> Type
212strict = TyBang BangedTy . \case
213 t@TyApp{} -> TyParen t
214 t -> t
216sing :: Text -> Type
217sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""
219tycon :: Id -> Type
220tycon = TyCon . unqual . Text.unpack . idToText
222unqual :: String -> QName
223unqual = UnQual . name
225infixE :: Exp -> QOp -> [Exp] -> Exp
226infixE l _ [] = l
227infixE l o (r:rs) = infixE (infixApp l o r) o rs
229str :: Text -> Exp
230str = strE . Text.unpack