d59c635 · gogol · git.iko.soy

git.iko.soy/gogol

Adding AST traversals and flattening of fixpoint types

commitd59c635934f37c775bd151d4d728e623d5b0f9d0 authorBrendan Hay <brendan.g.hay@gmail.com> dateTue 22 Sep 2015, 20:55 (11 years ago) parent78639e1

4 files changed+254−37

compare with develop

unifiedsplit

gen/src/Gen/AST.hs+172 gen/src/Gen/Tree.hs+1−1 gen/src/Gen/Types.hs+79−35 gen/src/Main.hs+2−1

gen/src/Gen/AST.hsnew file+172

@@ -0,0 +1,172 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6+{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE LambdaCase #-}

8+{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE RankNTypes #-}

10+{-# LANGUAGE RecordWildCards #-}

11+{-# LANGUAGE TemplateHaskell #-}

12+

13+-- Module : Gen.AST

15+-- License : Mozilla Public License, v. 2.0.

16+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>

17+-- Stability : provisional

18+-- Portability : non-portable (GHC extensions)

19+

20+module Gen.AST where

21+

22+import Control.Applicative

23+import Control.Error

24+import Control.Lens

25+import Control.Monad.State

26+import Data.Aeson hiding (String)

27+import Data.Aeson.TH

28+import qualified Data.Attoparsec.Text as A

29+import Data.Char

30+import Data.Function (on)

31+import qualified Data.HashMap.Strict as Map

32+import Data.List (groupBy, intersect, nub, sort)

33+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

34+import qualified Data.List.NonEmpty as NE

35+import Data.Ord

36+import Data.Semigroup

37+import Data.Text (Text)

38+import qualified Data.Text as Text

39+import qualified Data.Text.Lazy as LText

40+import qualified Data.Text.Lazy.Builder as Build

41+import Data.Text.Manipulate

42+import qualified Filesystem.Path.CurrentOS as Path

43+import Formatting

44+import Gen.Formatting

45+import Gen.Text

46+import Gen.Types

47+import Text.EDE (Template)

48+

49+-- Just use hashmaps to lookup refs etc, and hide all the mutation

50+-- behind a StateT interface.

51+

52+data TType

53+ = TType Ref

54+ | TLit Lit

55+ | TMaybe TType

56+ | TEither TType TType

57+ | TList TType

58+

59+data Derive

60+ = DEq

61+ | DOrd

62+ | DRead

63+ | DShow

64+ | DEnum

65+ | DNum

66+ | DIntegral

67+ | DReal

68+ | DMonoid

69+ | DIsString

70+ | DData

71+ | DTypeable

72+ | DGeneric

73+ deriving (Eq)

74+

75+data Memo = Memo

76+ { _typed :: Map Ref TType

77+ , _derived :: Map Ref [Derive]

78+ , _schemas :: Map Ref (Schema Ref)

79+ }

80+

81+makeLenses ''Memo

82+

83+type AST = ExceptT Error (State Memo)

84+

85+schema :: Ref -> AST (Schema Ref)

86+schema k = do

87+ m <- gets (Map.lookup k . view schemas)

88+ case m of

89+ Nothing -> failure ("Missing Schema: " % ref) k

90+ Just v -> pure v

91+

92+memo :: Lens' Memo (Map Ref v) -> Ref -> (Schema Ref -> AST v) -> AST v

93+memo l k f = do

94+ m <- gets (Map.lookup k . view l)

95+ case m of

96+ Just x -> return x

97+ Nothing -> do

98+ x <- f =<< schema k

99+ l %= Map.insert k x

100+ return x

101+

102+typeOf :: Ref -> AST TType

103+typeOf k = memo typed k go

104+ where

105+ go = \case

106+ Obj {} -> pure (TType k)

107+ Arr _ r -> typeOf r

108+ Enum {} -> pure (TType k)

109+ Ref r -> typeOf r

110+ Any' -> pure (TEither (TLit String) (TLit Integer))

111+ Lit _ l -> pure (TLit l)

112+

113+derive :: Ref -> AST [Derive]

114+derive k = memo derived k go

115+ where

116+ go = \case

117+ Obj _ rs -> foldM props base (Map.keys rs)

118+ Arr _ r -> mappend monoid . intersect base <$> derive r

119+ Enum {} -> pure enum

120+ Ref r -> derive r

121+ Any' -> pure base

122+ Lit _ l -> pure $

123+ case l of

124+ String -> base <> [DOrd, DIsString]

125+ Boolean -> base <> enum

126+ Integer -> base <> [DNum, DIntegral, DReal] <> enum

127+

128+ props ds x = intersect ds <$> derive x

129+

130+ monoid = [DMonoid]

131+ enum = [DOrd, DEnum]

132+ base = [DEq, DRead, DShow, DData, DTypeable, DGeneric]

133+

134+-- mapM isn't lazy here and I don't care!

135+flatten :: Map Ref (Fix Schema) -> Map Ref (Schema Ref)

136+flatten m = execState (mapM_ (uncurry (prop Nothing)) (Map.toList m)) mempty

137+ where

138+ -- unfold the properties.

139+ prop p k (Fix f) = case f of

140+ Obj i ps -> do

141+ o <- Obj i <$> Map.traverseWithKey (prop (Just ref)) ps

142+ res o

143+

144+ Arr i e -> do

145+ e' <- prop Nothing ref e

146+ res (Arr i e')

147+

148+ Enum i vs ds -> res (Enum i vs ds)

149+ Lit i l -> res (Lit i l)

150+ Ref r -> res (Ref r) -- blow up if r == ref ?

151+ Any' -> res Any'

152+

153+ where

154+ res x = modify (Map.insert ref x) >> pure ref

155+

156+ ref = maybe k (<> k) p

157+

158+render :: Service (Schema Ref) -> Either Error (Service Data)

159+render s = undefined -- do

160+ -- rs <- traverse schema (_svcSchemas s)

161+ -- return $! s { _svcSchemas = rs }

162+ -- where

163+ -- schema :: Schema -> Either Error Data

164+ -- schema = \case

165+ -- Obj ->

166+ -- constructor [doc, sig, decl]

167+ -- decl

168+

169+ -- Arr -> Nothing

170+

171+

172+

gen/src/Gen/Tree.hs+1−1

@@ -86,7 +86,7 @@ populate d Templates{..} l = (encodeString d :/) . dir lib <$> layout

8686 , file "README.md" readmeTemplate

8787 ]

8888

89− service :: Service -> [DirTree (Either Error Touch)]

89+ service :: Service Data -> [DirTree (Either Error Touch)]

9090 service s =

9191 [ write $ module' (tocNS s) mempty tocTemplate (pure svc)

9292 , dir (fromText (svcAbbrev s))

gen/src/Gen/Types.hs+79−35

@@ -1,10 +1,16 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE KindSignatures #-}

4−{-# LANGUAGE LambdaCase #-}

5−{-# LANGUAGE OverloadedStrings #-}

6−{-# LANGUAGE RecordWildCards #-}

7−{-# LANGUAGE TemplateHaskell #-}

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveFoldable #-}

3+{-# LANGUAGE DeriveFunctor #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE DeriveTraversable #-}

6+{-# LANGUAGE FlexibleContexts #-}

7+{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9+{-# LANGUAGE KindSignatures #-}

10+{-# LANGUAGE LambdaCase #-}

11+{-# LANGUAGE OverloadedStrings #-}

12+{-# LANGUAGE RecordWildCards #-}

13+{-# LANGUAGE TemplateHaskell #-}

814

915-- Module : Gen.Types

@@ -22,8 +28,10 @@ import Control.Applicative

2228import Data.Aeson hiding (String)

2329import Data.Aeson.TH

2430import qualified Data.Attoparsec.Text as A

31+import Data.Bifunctor

2532import Data.Char

2633import Data.Function (on)

34+import Data.Hashable

2735import qualified Data.HashMap.Strict as Map

2836import Data.List (groupBy, nub, sort)

2937import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

@@ -43,6 +51,8 @@ import GHC.Generics

4351import GHC.TypeLits

4452import Text.EDE (Template)

4553

54+newtype Fix f = Fix (f (Fix f))

55+

4656type Map = Map.HashMap

4757type Error = LText.Text

4858type Rendered = LText.Text

@@ -128,6 +138,7 @@ deriveJSON (js "") ''Location

128138data Info = Info

129139 { _infoDescription :: Maybe Text

130140 , _infoDefault :: Maybe Text

141+ , _infoRequired :: Maybe Bool

131142 } deriving (Eq, Show)

132143

133144deriveJSON (js "_info") ''Info

@@ -135,50 +146,83 @@ deriveJSON (js "_info") ''Info

135146data Lit

136147 = String

137148 | Boolean

149+ | Integer

138150 deriving (Eq, Show)

139151

140152deriveToJSON (js "") ''Lit

141153

142−data Schema

143− = Obj Info (Map Text Schema)

144− | Arr Info Schema

154+data Ref

155+ = Opaque [Text]

156+ | Direct Text

157+ deriving (Eq, Show, Generic)

158+

159+instance Semigroup Ref where

160+ a <> b = case (a, b) of

161+ (Opaque xs, Opaque ys) -> Opaque (xs <> ys)

162+ (Opaque xs, Direct y) -> Opaque (xs <> [y])

163+ (Direct x, Opaque ys) -> Opaque (x : ys)

164+ (Direct x, Direct y) -> Opaque [x, y]

165+

166+instance Hashable Ref

167+

168+instance FromJSON Ref where parseJSON = withText "ref" (pure . Direct)

169+instance ToJSON Ref where toJSON = toJSON . refToText

170+

171+instance FromJSON a => FromJSON (Map Ref a) where

172+ parseJSON = fmap (Map.fromList . map (first Direct) . Map.toList) . parseJSON

173+

174+instance ToJSON a => ToJSON (Map Ref a) where

175+ toJSON = toJSON . Map.fromList . map (first refToText) . Map.toList

176+

177+refToText :: Ref -> Text

178+refToText = \case

179+ Opaque xs -> Text.intercalate "." xs

180+ Direct n -> n

181+

182+ref :: Format a (Ref -> a)

183+ref = later (Build.fromText . refToText)

184+

185+data Schema a

186+ = Obj Info (Map Ref a)

187+ | Arr Info a

145188 | Enum Info [Text] [Text]

146189 | Lit Info Lit

147− | Ref Text

190+ | Ref Ref

148191 | Any' -- String or Number

149− deriving (Eq, Show)

192+ deriving (Eq, Show, Functor, Foldable, Traversable)

150193

151−instance FromJSON Schema where

152− parseJSON = withObject "schema" $ \o -> schema o <|> ref o

194+instance FromJSON (Fix Schema) where

195+ parseJSON = withObject "schema" $ \o -> Fix <$> (schema o <|> ref o)

153196 where

154197 schema o = do

155198 i <- parseJSON (Object o)

156− t <- o .: "type" -- <|> fail ("Missing 'type' in " ++ show o)

157− case t of

199+ o .: "type" >>= \case

158200 "object" -> Obj i <$> o .: "properties"

159201 "array" -> Arr i <$> o .: "items"

160202 "string" -> enum i o <|> pure (Lit i String)

161203 "boolean" -> pure (Lit i Boolean)

162204 "any" -> pure Any'

163− _ -> fail $

164− "Unable to parse Schema from: '" ++ Text.unpack t ++ "'"

205+ e -> fail $

206+ "Unable to parse Schema from: '" ++ Text.unpack e ++ "'"

165207

166208 enum i o = Enum i <$> o .: "enum" <*> o .: "enumDescriptions"

167−

168− ref o = Ref <$> o .: "$ref"

209+ ref o = Ref <$> o .: "$ref"

169210

170211deriveToJSON (js "") ''Schema

171212

172−data Param = Param Location Schema

173− deriving (Eq, Show)

213+data Param a = Param Location a

214+ deriving (Eq, Show, Functor, Foldable, Traversable)

174215

175−instance FromJSON Param where

216+instance FromJSON a => FromJSON (Param a) where

176217 parseJSON = withObject "parameter" $ \o ->

177218 Param <$> o .: "location" <*> parseJSON (Object o)

178219

179220deriveToJSON (js "") ''Param

180221

181−data Service = Service

222+newtype Data = Data Rendered

223+ deriving (Eq, Show, ToJSON)

224+

225+data Service a = Service

182226 { _svcLibrary :: Text

183227 , _svcTitle :: Text

184228 , _svcName :: Text

@@ -196,39 +240,39 @@ data Service = Service

196240 , _svcServicePath :: Text

197241 , _svcBatchPath :: Text

198242 , _svcAuth :: Maybe Object

199− , _svcParameters :: Map Text Param

200− , _svcSchemas :: Map Text Schema

243+ , _svcParameters :: Map Text (Param a)

244+ , _svcSchemas :: Map Text a

201245 , _svcResources :: Object

202− } deriving (Show, Generic)

246+ } deriving (Generic)

203247

204248deriveFromJSON (js "_svc") ''Service

205249

206−instance ToJSON Service where

250+instance ToJSON (Service Data) where

207251 toJSON s = Object (x <> y)

208252 where

209253 Object x = genericToJSON (js "_svc") s

210254 Object y = object

211− [ "exposedModules" .= exposedModules s

255+ [ "exposedModules" .= exposedModules s

212256 ]

213257

214−svcAbbrev :: Service -> Text

258+svcAbbrev :: Service a -> Text

215259svcAbbrev = renameAbbrev . _svcTitle

216260

217−typeImports :: Service -> [NS]

261+typeImports :: Service a -> [NS]

218262typeImports _ = ["Network.Google.Prelude"]

219263

220−tocNS, typesNS :: Service -> NS

264+tocNS, typesNS :: Service a -> NS

221265tocNS s = NS ["Network", "Google", svcAbbrev s]

222266typesNS = (<> "Types") . tocNS

223267

224−exposedModules :: Service -> [NS]

268+exposedModules :: Service a -> [NS]

225269exposedModules s = [tocNS s, typesNS s]

226270

227271data Library = Library

228272 { _libName :: Text

229273 , _libTitle :: Text

230274 , _libVersions :: Versions

231− , _libServices :: NonEmpty Service

275+ , _libServices :: NonEmpty (Service Data)

232276 }

233277

234278instance ToJSON Library where

@@ -241,7 +285,7 @@ instance ToJSON Library where

241285 , "exposedModules" .= concatMap exposedModules (NE.toList _libServices)

242286 ]

243287

244−mergeLibraries :: Versions -> [Service] -> [Library]

288+mergeLibraries :: Versions -> [Service Data] -> [Library]

245289mergeLibraries v = map go . groupBy (on (==) _svcLibrary)

246290 where

247291 go [x] = mk x

gen/src/Main.hs+2−1

@@ -14,6 +14,7 @@

1414

1515module Main (main) where

1616

17+import Gen.AST

1718import Control.Error

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

1920import Control.Monad.State

@@ -158,7 +159,7 @@ main = do

158159

159160 return s

160161

161− let libs = mergeLibraries _optVersions svcs

162+ libs = mergeLibraries _optVersions <$> renderSchemas svcs

162163

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

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