git.iko.soy/gogol
on ce42607 help sign in
gogol/gen/src/Gen/Types.hs
371 lines 11 kB history raw
1{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DeriveFoldable #-}
3{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE DeriveTraversable #-}
6{-# LANGUAGE ExtendedDefaultRules #-}
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE FunctionalDependencies #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE KindSignatures #-}
12{-# LANGUAGE LambdaCase #-}
13{-# LANGUAGE MultiParamTypeClasses #-}
14{-# LANGUAGE OverloadedStrings #-}
15{-# LANGUAGE RankNTypes #-}
16{-# LANGUAGE RecordWildCards #-}
17{-# LANGUAGE TemplateHaskell #-}
18{-# LANGUAGE ViewPatterns #-}
20{-# OPTIONS_GHC -fno-warn-type-defaults #-}
22-- Module : Gen.Types
23-- Copyright : (c) 2015-2016 Brendan Hay
24-- License : Mozilla Public License, v. 2.0.
25-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>
26-- Stability : provisional
27-- Portability : non-portable (GHC extensions)
29module Gen.Types
30 ( module Gen.Types
31 , module Gen.Types.Help
32 , module Gen.Types.Id
33 , module Gen.Types.Map
34 , module Gen.Types.NS
35 , module Gen.Types.Schema
36 , module Gen.Types.Data
37 ) where
39import Control.Applicative
40import Control.Lens hiding ((.=))
41import Control.Monad.Except
42import Control.Monad.State.Strict
43import Data.Aeson hiding (Array, Bool, String)
44import qualified Data.Attoparsec.Text as A
45import Data.Bifunctor
46import Data.CaseInsensitive (CI)
47import qualified Data.CaseInsensitive as CI
48import Data.Function (on)
49import qualified Data.HashMap.Strict as Map
50import qualified Data.HashSet as Set
51import Data.List (sort)
52import Data.Maybe
53import Data.Ord
54import Data.Semigroup ((<>))
55import Data.String
56import Data.Text (Text)
57import qualified Data.Text as Text
58import qualified Data.Text.Lazy as LText
59import qualified Data.Text.Lazy.Builder as Build
60import Data.Text.Manipulate
61import qualified Filesystem.Path.CurrentOS as Path
62import Formatting
63import Gen.Orphans ()
64import Gen.Text
65import Gen.Types.Data
66import Gen.Types.Help
67import Gen.Types.Id
68import Gen.Types.Map
69import Gen.Types.NS
70import Gen.Types.Schema
71import GHC.TypeLits
72import Prelude hiding (Enum)
73import Text.EDE (Template)
75default (Integer)
77type Set = Set.HashSet
78type Error = LText.Text
79type Path = Path.FilePath
81newtype Version (v :: Symbol) = Version Text
82 deriving (Eq, Show)
84instance ToJSON (Version v) where
85 toJSON (Version v) = toJSON v
87fver :: Format a (Version v -> a)
88fver = later (\(Version v) -> Build.fromText v)
90type LibraryVer = Version "library"
91type ClientVer = Version "client"
92type CoreVer = Version "core"
94data Versions = Versions
95 { _libraryVersion :: LibraryVer
96 , _clientVersion :: ClientVer
97 , _coreVersion :: CoreVer
98 } deriving (Show)
100makeClassy ''Versions
102data Release
103 = Sandbox
104 | Alpha (Maybe Int) (Maybe Char)
105 | Beta (Maybe Int) (Maybe Char)
106 deriving (Eq, Ord, Show)
108data ModelVersion = ModelVersion Double (Maybe Release)
109 deriving (Eq, Show)
111instance Ord ModelVersion where
112 compare (ModelVersion an ar) (ModelVersion bn br) =
113 compare an bn <>
114 case (ar, br) of
115 (Nothing, _) -> GT
116 (_, Nothing) -> LT
117 (Just x, Just y) -> compare x y
119parseVersion :: Text -> Either String ModelVersion
120parseVersion x = first (mappend (Text.unpack x) . mappend " -> ") $
121 A.parseOnly (preface *> (empty' <|> version) <* A.endOfInput) x
122 where
123 empty' = ModelVersion 0 <$> (alpha <|> beta <|> exp')
124 version = ModelVersion
125 <$> number
126 <*> (alpha <|> beta <|> sandbox <|> pure Nothing)
128 preface = A.takeWhile (/= '_') *> void (A.char '_') <|> pure ()
129 number = A.takeWhile (/= 'v') *> A.char 'v' *> A.double
131 alpha = A.string "alpha"
132 *> (Alpha <$> optional A.decimal <*> optional A.letter)
133 <&> Just
135 beta = A.string "beta"
136 *> (Beta <$> optional A.decimal <*> optional A.letter)
137 <&> Just
139 sandbox = Just Sandbox <$ A.string "sandbox"
140 exp' = Just Sandbox <$ A.string "exp" <* A.decimal
142data Model = Model
143 { modelName :: Text
144 , modelPrefix :: Text
145 , modelVersion :: ModelVersion
146 , modelPath :: Path
147 }
149instance Eq Model where
150 (==) = on (==) modelPrefix
152instance Ord Model where
153 compare a b =
154 on compare modelPrefix a b
155 <> on compare (Down . modelVersion) a b
157modelFromPath :: Path -> Model
158modelFromPath x = Model n p v x
159 where
160 n = Text.init
161 . Text.intercalate "/"
162 . drop 1
163 . dropWhile (/= "model")
164 $ Text.split (== '/') p
166 p = toTextIgnore (Path.parent (Path.parent x))
167 v = either error id $ parseVersion (toTextIgnore (Path.dirname x))
169data Templates = Templates
170 { cabalTemplate :: Template
171 , tocTemplate :: Template
172 , readmeTemplate :: Template
173 , typesTemplate :: Template
174 , prodTemplate :: Template
175 , sumTemplate :: Template
176 , actionTemplate :: Template
177 }
179data Imports = Imports
180 { tocImports :: [NS]
181 , typeImports :: [NS]
182 , prodImports :: [NS]
183 , sumImports :: [NS]
184 , actionImports :: [NS]
185 }
187serviceImports :: HasService a b => a -> Imports
188serviceImports s = Imports
189 { tocImports = [preludeNS]
190 , typeImports = sort [preludeNS, prodNS s, sumNS s]
191 , prodImports = sort [preludeNS, sumNS s]
192 , sumImports = [preludeNS]
193 , actionImports = sort [preludeNS, typesNS s]
194 }
196tocNS, typesNS, prodNS, sumNS :: HasService a b => a -> NS
197tocNS = mappend "Network.Google" . mkNS . view sCanonicalName
198typesNS = (<> "Types") . tocNS
199prodNS = (<> "Product") . typesNS
200sumNS = (<> "Sum") . typesNS
202preludeNS :: NS
203preludeNS = "Network.Google.Prelude"
205resourceNS, methodNS :: NS
206resourceNS = "Network.Google.Resource"
207methodNS = "Network.Google.Method"
209exposedModules :: Library -> [NS]
210exposedModules l = sort $
211 tocNS l
212 : typesNS l
213 : map _actNamespace (_apiResources (_lAPI l))
214 ++ map _actNamespace (_apiMethods (_lAPI l))
216otherModules :: Library -> [NS]
217otherModules s = sort [prodNS s, sumNS s]
219toTextIgnore :: Path -> Text
220toTextIgnore = either id id . Path.toText
222data Library = Library
223 { _lVersions :: Versions
224 , _lService :: Service Global
225 , _lAPI :: API
226 , _lSchemas :: [Data]
227 }
229makeLenses ''Library
231instance HasVersions Library where
232 versions = lVersions
234instance HasDescription Library Global where
235 description = lService . description
237instance HasService Library Global where
238 service = lService
240instance ToJSON Library where
241 toJSON l = object
242 -- Library
243 [ "libraryName" .= (l ^. sLibrary)
244 , "libraryTitle" .= renameTitle (l ^. dTitle)
245 , "libraryDescription" .= Desc 4 (l ^. dDescription)
246 , "libraryVersion" .= (l ^. libraryVersion)
247 , "coreVersion" .= (l ^. coreVersion)
248 , "clientVersion" .= (l ^. clientVersion)
249 , "exposedModules" .= exposedModules l
250 , "otherModules" .= otherModules l
252 -- Service
253 , "id" .= (l ^. dId)
254 , "name" .= (l ^. dName)
255 , "version" .= (l ^. dVersion)
256 , "title" .= (l ^. dTitle)
257 , "description" .= (l ^. dDescription)
258 , "documentationLink" .= (l ^. dDocumentationLink)
259 , "labels" .= (l ^. dLabels)
260 , "features" .= (l ^. dFeatures)
261 , "scopes" .= (l ^. dAuth)
263 -- API
264 , "api" .= (l ^. lAPI)
266 -- Schemas
267 , "schemas" .= (l ^. lSchemas)
268 ]
270data TType
271 = TType Global
272 | TLit Lit
273 | TMaybe TType
274 | TList TType
275 | TMap TType TType
276 deriving (Eq, Show)
278data Derive
279 = DEq
280 | DOrd
281 | DRead
282 | DShow
283 | DEnum
284 | DNum
285 | DIntegral
286 | DReal
287 | DMonoid
288 | DIsString
289 | DData
290 | DTypeable
291 | DGeneric
292 deriving (Eq, Show)
294data Solved = Solved
295 { _additional :: Bool
296 , _unique :: Global
297 , _prefix :: Prefix
298 , _schema :: Schema Global
299 , _type :: TType
300 , _deriving :: [Derive]
301 } deriving (Show)
303instance HasInfo Solved where
304 info = f . info
305 where
306 f = lens _schema (\s a -> s { _schema = a })
308monoid :: Solved -> Bool
309monoid = elem DMonoid . _deriving
311setAdditional :: Solved -> Solved
312setAdditional s = setRequired $ s
313 { _additional = True
314 , _type = TMap (TLit Text) (_type s)
315 }
317type Seen = Map (CI Text) {- Prefix -} (Set (CI Text)) {- Inhabitants -}
319data Memo = Memo
320 { _context :: Service (Fix Schema)
321 , _typed :: Map Global TType
322 , _derived :: Map Global [Derive]
323 , _reserve :: Set Global
324 , _schemas :: Map Global (Schema Global)
325 , _prefixed :: Map Global Prefix
326 , _branches :: Seen
327 , _fields :: Seen
328 }
330initial :: Service (Fix Schema) -> Memo
331initial s = Memo s mempty mempty res core mempty mempty mempty
332 where
333 -- Top-level schema definitions with ids.
334 res = Set.fromList
335 . mapMaybe (view iId)
336 $ Map.elems (s ^. dSchemas)
337 -- Types available in Network.Google.Prelude.
338 core = Map.fromList
339 [ ("Body", SLit requiredInfo RqBody)
340 , ("Stream", SLit requiredInfo RsBody)
341 , ("JSONValue", SLit requiredInfo JSONValue)
342 ]
344makeLenses ''Memo
346instance HasService Memo (Fix Schema) where
347 service = context
349type AST = ExceptT Error (State Memo)
351reserveType :: Global -> AST Global
352reserveType g = do
353 p <- uses reserve (Set.member g)
354 pure $!
355 if p
356 then reference g "'"
357 else g
359reserveBranches :: AST ()
360reserveBranches = do
361 ss <- use schemas
362 let bs = Set.fromList $ map (CI.mk . global) (Map.keys ss)
363 branches %= Map.insertWith (<>) mempty bs
365reserveFields :: AST ()
366reserveFields = do
367 ss <- use schemas
368 forM_ (Map.keys ss) $ \(global -> k) -> do
369 let p:ps = splitWords k
370 s = mconcat ps
371 fields %= Map.insertWith (<>) (CI.mk p) (Set.singleton (CI.mk s))