git.iko.soy/gogol
on 73be2e4 help sign in
gogol/gen/src/Gen/Syntax.hs
191 lines 5.9 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 (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)
35apiTypes :: Service s r -> Id -> Method -> [Type]
36apiTypes s r m = map sing ps ++ qs ++ [end]
37 where
38 ps = filter (not . Text.null)
39 $ Text.split (== '/') (_svcServicePath s)
40 <> Text.split (== '/') (_mPath m)
42 -- FIXME: order by _mParameterOrder
43 qs = map param (Map.toList (_svcParameters s))
44 ++ map param (Map.toList (_mParameters m))
46 param (k, p) =
47 -- FIXME: types, many/repeated
48 let t = literal (_prmLiteral p)
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
54 end = TyApp (TyApp meth typ) res
56 meth = TyCon . unqual . Text.unpack $ Text.toTitle (_mMethod m)
57 typ = tycon "'[JSON]"
58 res = maybe (tycon "()") (tycon . Free) (_mResponse m)
60 -- method (titlecase) '[JSON] (responsetype)
62objDecl :: Id -> Pre -> Map Local Solved -> AST Decl
63objDecl n p rs = DataDecl noLoc arity [] d [] [conDecl d p rs] <$> derivings n
64 where
65 d = dname n
67 arity | Map.size rs == 1 = NewType
68 | otherwise = DataType
70conDecl :: Name -> Pre -> Map Local Solved -> QualConDecl
71conDecl n p rs = QualConDecl noLoc [] [] body
72 where
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)
78 field f (l, v) = ([fname p l], f (_type v))
80ctorSig :: Id -> Map Local Solved -> Decl
81ctorSig n rs = TypeSig noLoc [cname n] ts
82 where
83 ts = foldr' TyFun (TyCon (UnQual (dname n))) ps
84 ps = parameters (Map.elems rs)
86ctorDecl :: Id -> Pre -> Map Local Solved -> Decl
87ctorDecl n p rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds
88 where
89 c = cname n
90 d = dname n
92 rhs | Map.null rs = var d
93 | otherwise = RecConstr (UnQual d) $
94 map (uncurry (fieldUpdate p)) (Map.toList rs)
96 ps = map (pname p) . Map.keys $ Map.filter (view required) rs
98fieldUpdate :: Pre -> Local -> Solved -> FieldUpdate
99fieldUpdate p l s = FieldUpdate (UnQual (fname p l)) rhs
100 where
101 rhs | s ^. required = v
102 | Just x <- s ^. defaulted = str x
103 | Just x <- iso (_type s) = infixApp x "#" v
104 | otherwise = var (name "Nothing")
106 v = var (pname p l)
108lensSig :: Id -> Pre -> Local -> Solved -> Decl
109lensSig n p l s = TypeSig noLoc [lname p l] $
110 TyApp (TyApp (tycon "Lens'") (tycon n))
111 (external (_type s))
113lensDecl :: Pre -> Local -> Solved -> Decl
114lensDecl p l s = sfun noLoc (lname p l) [] (UnGuardedRhs rhs) noBinds
115 where
116 f = fname p l
117 t = _type s
119 rhs = mapping t $
120 app (app (var "lens") (var f))
121 (paren (lamE noLoc [pvar "s", pvar "a"]
122 (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))
124derivings :: Id -> AST [Deriving]
125derivings k = map ((,[]) . unqual . drop 1 . show) <$> derive k
127parameters :: [Solved] -> [Type]
128parameters = map (external . _type) . filter (view required)
130external, internal :: TType -> Type
131external = internal . \case
132 TMaybe t@TList {} -> t
133 t -> t
135internal = \case
136 TType r -> tycon r
137 TMaybe t -> TyApp (tycon "Maybe") (internal t)
138 TEither a b -> TyApp (TyApp (tycon "Either") (internal a)) (internal b)
139 TList t -> TyList (internal t)
140 TLit l -> literal l
142literal :: Lit -> Type
143literal = \case
144 Text -> tycon "Text"
145 Bool -> tycon "Bool"
146 Time -> tycon "UTCTime"
147 Nat -> tycon "Natural"
148 Float -> tycon "Float"
149 Double -> tycon "Double"
150 Byte -> tycon "Word8"
151 UInt32 -> tycon "Word32"
152 UInt64 -> tycon "Word64"
153 Int32 -> tycon "Int32"
154 Int64 -> tycon "Int64"
156mapping :: TType -> Exp -> Exp
157mapping t e = infixE e "." (go t)
158 where
159 go = \case
160 TMaybe x@(TList {}) -> var "_Default" : go x
161 TMaybe x -> nest (go x)
162 x -> maybeToList (iso x)
164 nest [] = []
165 nest (x:xs) = [app (var "mapping") (infixE x "." xs)]
167iso :: TType -> Maybe Exp
168iso = \case
169 TList {} -> Just (var "_Coerce")
170 _ -> Nothing
172strict :: Type -> Type
173strict = TyBang BangedTy . \case
174 t@TyApp{} -> TyParen t
175 t -> t
177sing :: Text -> Type
178sing = TyCon . unqual . Text.unpack . flip mappend "\"" . mappend "\""
180tycon :: Id -> Type
181tycon = TyCon . unqual . Text.unpack . idToText
183unqual :: String -> QName
184unqual = UnQual . name
186infixE :: Exp -> QOp -> [Exp] -> Exp
187infixE l _ [] = l
188infixE l o (r:rs) = infixE (infixApp l o r) o rs
190str :: Text -> Exp
191str = strE . Text.unpack