7ca7756 · gogol · git.iko.soy

git.iko.soy/gogol

Updating

commit7ca7756559e2e400393435e48887f58d456f8dbc authorBrendan Hay <brendan.g.hay@gmail.com> dateFri 25 Sep 2015, 20:10 (11 years ago) parent7e1714b

12 files changed+64−31

compare with develop

unifiedsplit

gen/annex/adexchangebuyer.json+1 gen/annex/adexchangeseller.json+1 gen/annex/admin/datatransfer.json+1 gen/annex/admin/directory.json+1 gen/annex/admin/email_migration.json+1 gen/annex/admin/reports.json+1 gen/src/Gen/AST.hs+16−6 gen/src/Gen/Solve.hs+8−6 gen/src/Gen/Syntax.hs+1 gen/src/Gen/Types.hs+10−3 gen/src/Gen/Types/Id.hs+2−3 gen/src/Main.hs+21−13

gen/annex/adexchangebuyer.json+1

@@ -1,3 +1,4 @@

11{

2+ "library": "adexchange-buyer"

23}

gen/annex/adexchangeseller.json+1

@@ -1,3 +1,4 @@

11{

2+ "library": "adexchange-seller"

23}

gen/annex/admin/datatransfer.json+1

@@ -1,3 +1,4 @@

11{

2+ "library": "admin"

23}

gen/annex/admin/directory.json+1

@@ -1,3 +1,4 @@

11{

2+ "library": "admin"

23}

gen/annex/admin/email_migration.json+1

@@ -1,3 +1,4 @@

11{

2+ "library": "admin"

23}

gen/annex/admin/reports.json+1

@@ -1,3 +1,4 @@

11{

2+ "library": "admin"

23}

gen/src/Gen/AST.hs+16−6

@@ -21,12 +21,12 @@

2121

2222module Gen.AST where

2323

24−import Data.Bifunctor

2524import Control.Applicative

2625import Control.Error

2726import Control.Lens hiding (lens)

2827import Control.Monad.Except

2928import Control.Monad.State.Strict

29+import Data.Bifunctor

3030import Data.Char

3131import Data.Function (on)

3232import qualified Data.HashMap.Strict as Map

@@ -41,6 +41,7 @@ import Gen.Syntax

4141import Gen.Text

4242import Gen.Types

4343import HIndent

44+import Language.Haskell.Exts (Name)

4445import Language.Haskell.Exts.Pretty

4546import Prelude hiding (sum)

4647

@@ -53,7 +54,7 @@ render :: Service (Schema Id) Resource -> AST (Service Data API)

5354render svc = do

5455 x <- kvTraverseMaybe typ (_svcSchemas svc)

5556 y <- Map.traverseWithKey api (_svcResources svc)

56− return $! svc { _svcSchemas = x, _svcResources = y }

57+ return $! svc { _svcSchemas = x, _svcResources = mempty }

5758 where

5859 typ :: Id -> Schema Id -> AST (Maybe Data)

5960 typ k = \case

@@ -89,11 +90,20 @@ render svc = do

8990 sformat ("Creates a value of '" % fid %

9091 "' with the minimum fields required to make a request.\n")

9192 k

93+

9294 api :: Id -> Resource -> AST API

93− api k (methods -> Map.toList -> ms) = do

94− let go (n, v) = fmap (mname k n,) . traverse (pp None) $ apiTypes svc k v

95− rs <- traverse go ms

96− return $! API (aname k) (Map.fromList rs)

95+ api k = fmap (API (aname k) . Map.fromList) . res k

96+ where

97+ res :: Id -> Resource -> AST [(Name, [Rendered])]

98+ res p = \case

99+ Parent rs -> traverse (parent p) (Map.toList rs) <&> concat

100+ Sub ms -> traverse (sub p) (Map.toList ms)

101+

102+ parent :: Id -> (Local, Resource) -> AST [(Name, [Rendered])]

103+ parent p (n, r) = res (mkProp p n) r

104+

105+ sub :: Id -> (Local, Method) -> AST (Name, [Rendered])

106+ sub p (n, m) = (mname p n,) <$> traverse (pp None) (apiTypes svc p m)

97107

98108flatten :: Service (Fix Schema) Resource -> Service (Schema Id) Resource

99109flatten svc = svc { _svcSchemas = execState run mempty }

gen/src/Gen/Solve.hs+8−6

@@ -36,14 +36,12 @@ import Data.Semigroup ((<>))

3636import Data.Text (Text)

3737import qualified Data.Text as Text

3838import Data.Text.Manipulate

39+import Debug.Trace

3940import Gen.Formatting

4041import Gen.Text

4142import Gen.Types

4243import Prelude hiding (sum)

4344

44−-- Just use hashmaps to lookup refs etc, and hide all the mutation

45−-- behind a StateT interface.

46−

4745data TType

4846 = TType Id

4947 | TLit Lit

@@ -118,7 +116,7 @@ solve :: Id -> AST Solved

118116solve k = Solved <$> prefix k <*> schema k <*> typeOf k <*> derive k

119117

120118typeOf :: Id -> AST TType

121−typeOf k = memo typed k go

119+typeOf k = loc "typeof" k $ memo typed k go

122120 where

123121 go s = fmap may $ case s of

124122 Obj {} -> pure (TType k)

@@ -133,7 +131,7 @@ typeOf k = memo typed k go

133131 | otherwise = TMaybe

134132

135133derive :: Id -> AST [Derive]

136−derive k = memo derived k go

134+derive k = loc "derive" k $ memo derived k go

137135 where

138136 go = \case

139137 Obj _ rs -> foldM props base (Map.elems rs)

@@ -146,6 +144,7 @@ derive k = memo derived k go

146144 Text -> base <> [DOrd, DIsString]

147145 Bool -> base <> enum

148146 Time -> base

147+ Date -> base

149148 Nat -> base

150149 _ -> base <> [DNum, DIntegral, DReal] <> enum

151150

@@ -156,7 +155,7 @@ derive k = memo derived k go

156155 base = [DEq, DRead, DShow, DData, DTypeable, DGeneric]

157156

158157prefix :: Id -> AST Pre

159−prefix n = memo prefixed n typ

158+prefix n = loc "prefix" n $ memo prefixed n typ

160159 where

161160 typ = \case

162161 Obj _ rs -> field rs

@@ -230,3 +229,6 @@ acronymPrefixes (idToText -> n) = map CI.mk (xs ++ map suffix ys)

230229

231230 -- SomeTestTType -> Som

232231 r6 = Text.take limit <$> listToMaybe (splitWords a)

232+

233+loc :: String -> Id -> a -> a

234+loc n r = trace (n ++ ": " ++ Text.unpack (idToText r))

gen/src/Gen/Syntax.hs+1

@@ -150,6 +150,7 @@ literal = \case

150150 Text -> tycon "Text"

151151 Bool -> tycon "Bool"

152152 Time -> tycon "UTCTime"

153+ Date -> tycon "UTCTime"

153154 Nat -> tycon "Natural"

154155 Float -> tycon "Float"

155156 Double -> tycon "Double"

gen/src/Gen/Types.hs+10−3

@@ -182,6 +182,7 @@ data Lit

182182 | Int32

183183 | Int64

184184 | Nat

185+ | Date

185186 | Time

186187 deriving (Eq, Show)

187188

@@ -200,6 +201,7 @@ instance FromJSON Lit where

200201 "uint64" -> pure (nat n UInt64)

201202 "int32" -> pure (nat n Int32)

202203 "int64" -> pure (nat n Int64)

204+ "date" -> pure Date

203205 "date-time" -> pure Time

204206 e -> fail $

205207 "Unable to parse Lit from " ++ Text.unpack e

@@ -350,7 +352,7 @@ instance FromJSON Method where

350352 <*> o .: "path"

351353 <*> o .: "httpMethod"

352354 <*> o .:? "description"

353− <*> o .: "parameters"

355+ <*> o .:? "parameters" .!= mempty

354356 <*> o .:? "parameterOrder" .!= mempty

355357 <*> o .:? "scopes" .!= mempty

356358 <*> ref o "request"

@@ -361,9 +363,14 @@ instance FromJSON Method where

361363

362364deriveToJSON (js "_m") ''Method

363365

364−newtype Resource = Resource { methods :: Map Global Method }

366+data Resource

367+ = Parent (Map Local Resource)

368+ | Sub (Map Local Method)

365369

366−deriveFromJSON (js "") ''Resource

370+instance FromJSON Resource where

371+ parseJSON = withObject "resource" $ \o ->

372+ Parent <$> o .: "resources"

373+ <|> Sub <$> o .: "methods"

367374

368375data Service s r = Service

369376 { _svcLibrary :: Text

gen/src/Gen/Types/Id.hs+2−3

@@ -65,9 +65,8 @@ import Language.Haskell.Exts.Syntax (Name)

6565aname :: Id -> Name

6666aname = name . Text.unpack . upperHead . idToText

6767

68−mname :: Id -> Global -> Name

69−mname x y = name . Text.unpack $

70− upperHead (idToText x) <> upperHead (global y)

68+mname :: Id -> Local -> Name

69+mname x y = aname $ mkProp x y

7170

7271dname, cname :: Id -> Name

7372dname = name . Text.unpack . upperHead . idToText

gen/src/Main.hs+21−13

@@ -18,6 +18,7 @@ import Control.Error

1818import Control.Lens hiding ((<.>))

1919import Control.Monad.State

2020import Data.List (nub, sort)

21+import Data.Maybe

2122import Data.String

2223import Data.Text (Text)

2324import qualified Data.Text as Text

@@ -148,19 +149,26 @@ main = do

148149 svcs <- counter "model" ss $ \Spec{..} -> do

149150 say ("Using version " % stext) _specVersion

150151

151− s <- sequence

152− [ JS.load (_optAnnexes </> fromText _specName <.> "json")

153− , JS.load _specPath

154− ] >>= hoistEither . JS.parse . JS.merge

155−

156− say ("Successfully parsed '" % stext % "' API definition.")

157− (_svcTitle s)

158−

159− done

160−

161− return s

162−

163− libs <- merge _optVersions <$> traverse (hoistEither . runAST) svcs

152+ let anx = _optAnnexes </> fromText _specName <.> "json"

153+ p <- isFile anx

154+ if not p

155+ then do

156+ say ("Skipping '" % stext % "' due to missing annex configuration.")

157+ _specName

158+ done *> return Nothing

159+ else do

160+ s <- sequence

161+ [ JS.load anx

162+ , JS.load _specPath

163+ ] >>= hoistEither . JS.parse . JS.merge

164+

165+ say ("Successfully parsed '" % stext % "' API definition.")

166+ (_svcTitle s)

167+

168+ done *> return (Just s)

169+

170+ libs <- merge _optVersions <$>

171+ traverse (hoistEither . runAST) (catMaybes svcs)

164172

165173 void . counter "library" libs $ \l -> do

166174 say ("Creating " % stext % " package.") (_libTitle l)