20e9832 · gogol · git.iko.soy

gen/annex/compute.json+1

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

11{

2+ "library": "gozen-compute"

23}

34

gen/gozen-gen.cabal+2

@@ -25,6 +25,7 @@ executable gozen-gen

2525 , Gen.Formatting

2626 , Gen.IO

2727 , Gen.JSON

28+ , Gen.Solve

2829 , Gen.Syntax

2930 , Gen.Text

3031 , Gen.Tree

@@ -50,6 +51,7 @@ executable gozen-gen

5051 , lens

5152 , mtl

5253 , optparse-applicative

54+ , pandoc

5355 , parsec

5456 , semigroups

5557 , system-fileio

gen/src/Gen/AST.hs+18−12

@@ -33,6 +33,7 @@ import Data.List.NonEmpty (NonEmpty (..))

3333import Data.Semigroup ((<>))

3434import qualified Data.Text.Lazy as LText

3535import qualified Data.Text.Lazy.Builder as Build

36+import Gen.Formatting

3637import Gen.Solve

3738import Gen.Syntax

3839import Gen.Text

@@ -94,29 +95,34 @@ render s = runAST (Memo mempty mempty ss) $ do

9495

9596 go :: Id -> Schema Id -> AST (Maybe Data)

9697 go k = \case

97− Arr {} -> pure Nothing

98− Ref {} -> pure Nothing

99− Any {} -> pure Nothing

100− Lit {} -> pure Nothing

101− Enum {} -> Just <$> sum

98+ Arr {} -> pure Nothing

99+ Ref {} -> pure Nothing

100+ Any {} -> pure Nothing

101+ Lit {} -> pure Nothing

102+ Enum i _ _ -> Just <$> sum

102103 where

103− sum = Sum "sum help"

104+ sum = Sum (dname k) (i ^. description)

104105 <$> pp Indent enumDecl

105106

106− Obj _ rs -> Just <$> (traverse solve rs >>= prod)

107+ Obj i rs -> Just <$> (traverse solve rs >>= prod)

107108 where

108− prod ts = Prod

109+ prod ts = Prod (dname k) (i ^. description)

109110 <$> (objDecl k ts >>= pp Indent)

110111 <*> ctor ts

111112 <*> traverse (uncurry lens) (Map.toList ts)

112113

113− ctor ts = Fun' "ctor help"

114+ ctor ts = Fun' (cname k) (Just help)

114115 <$> (pp None (ctorSig k ts) >>= comments ts)

115116 <*> pp Indent (ctorDecl k ts)

116117

117− lens _ _ = Fun' "lens help"

118− <$> pp None lensSig

119− <*> pp Print lensDecl

118+ lens n v = Fun' (lname n) (v ^. description)

119+ <$> pp None (lensSig k n v)

120+ <*> pp Print (lensDecl n v)

121+

122+ help = rawHelpText $

123+ sformat ("Creates a value of '" % fid %

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

125+ k

120126

121127data PP

122128 = Indent

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

@@ -26,6 +26,7 @@ import Control.Monad.Except

2626import Control.Monad.State

2727import qualified Data.HashMap.Strict as Map

2828import Data.List (intersect)

29+import Data.Maybe

2930import Data.Semigroup ((<>))

3031import Gen.Formatting

3132import Gen.Types

@@ -109,11 +110,12 @@ typeOf k = loc "typeOf" k $ memo typed k go

109110 Arr _ r -> TList <$> typeOf r

110111 Enum {} -> pure (TType k)

111112 Ref _ r -> typeOf r

112− Any {} -> pure (TEither (TLit Text) (TLit Long))

113+ Any {} -> pure (TEither (TLit Text) (TLit Int64))

113114 Lit _ l -> pure (TLit l)

114115 where

115− may | parameter s = id

116− | otherwise = TMaybe

116+ may | s ^. required = id

117+ | isJust (s ^. defaulted) = id

118+ | otherwise = TMaybe

117119

118120derive :: Id -> AST [Derive]

119121derive k = loc "derive" k $ memo derived k go

@@ -128,10 +130,9 @@ derive k = loc "derive" k $ memo derived k go

128130 case l of

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

130132 Bool -> base <> enum

131− Int -> base

132− Long -> base <> [DNum, DIntegral, DReal] <> enum

133− Nat -> base

134133 Time -> base

134+ Nat -> base

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

135136

136137 props ds x = intersect ds <$> derive x

137138

gen/src/Gen/Syntax.hs+62−13

@@ -2,6 +2,8 @@

22{-# LANGUAGE OverloadedStrings #-}

33{-# LANGUAGE TupleSections #-}

44

5+{-# OPTIONS_GHC -fno-warn-orphans #-}

6+

57-- Module : Gen.Syntax

79-- License : Mozilla Public License, v. 2.0.

@@ -11,9 +13,11 @@

1113

1214module Gen.Syntax where

1315

14−import Control.Lens hiding (strict)

16+import Control.Lens hiding (iso, mapping, op, strict)

1517import Data.Foldable (foldr')

1618import qualified Data.HashMap.Strict as Map

19+import Data.Maybe

20+import Data.String

1721import Data.Text (Text)

1822import qualified Data.Text as Text

1923import Data.Text.Manipulate

@@ -24,6 +28,12 @@ import Language.Haskell.Exts.Build

2428import Language.Haskell.Exts.SrcLoc

2529import Language.Haskell.Exts.Syntax hiding (Int)

2630

31+instance IsString Name where

32+ fromString = name

33+

34+instance IsString QOp where

35+ fromString = op . name

36+

2737objDecl :: Id -> Map Id Solved -> AST Decl

2838objDecl r rs = DataDecl noLoc arity [] d [] [conDecl d rs] <$> derivings r

2939 where

@@ -66,15 +76,29 @@ ctorDecl r rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds

6676fieldUpdate :: Id -> Solved -> FieldUpdate

6777fieldUpdate r s = FieldUpdate (UnQual (fname r)) rhs

6878 where

69− rhs | Just x <- s ^. defaulted = str x

70− | s ^. required = var (pname r)

79+ rhs | s ^. required = p

80+ | Just x <- s ^. defaulted = str x

81+ | Just v <- iso (_type s) = infixApp v "#" p

7182 | otherwise = var (name "Nothing")

7283

73−lensSig :: Decl

74−lensSig = emptyDecl

84+ p = var (pname r)

85+

86+lensSig :: Id -> Id -> Solved -> Decl

87+lensSig n r s = TypeSig noLoc [lname r] $

88+ TyApp (TyApp (tycon "Lens'") (tycon n))

89+ (external (_type s))

90+

91+lensDecl :: Id -> Solved -> Decl

92+lensDecl r s = sfun noLoc l [] (UnGuardedRhs rhs) noBinds

93+ where

94+ l = lname r

95+ f = fname r

96+ t = _type s

7597

76−lensDecl :: Decl

77−lensDecl = emptyDecl

98+ rhs = mapping t $

99+ app (app (var "lens") (var f))

100+ (paren (lamE noLoc [pvar "s", pvar "a"]

101+ (RecUpdate (var "s") [FieldUpdate (UnQual f) (var "a")])))

78102

79103enumDecl :: Decl

80104enumDecl = emptyDecl

@@ -100,12 +124,33 @@ internal = go

100124 TLit l -> lit l

101125

102126 lit = \case

103− Text -> tycon "Text"

104− Bool -> tycon "Bool"

105− Int -> tycon "Int"

106− Long -> tycon "Integer"

107− Nat -> tycon "Natural"

108− Time -> tycon "UTCTime"

127+ Text -> tycon "Text"

128+ Bool -> tycon "Bool"

129+ Time -> tycon "UTCTime"

130+ Nat -> tycon "Natural"

131+ Float -> tycon "Float"

132+ Double -> tycon "Double"

133+ Byte -> tycon "Word8"

134+ UInt32 -> tycon "Word32"

135+ UInt64 -> tycon "Word64"

136+ Int32 -> tycon "Int32"

137+ Int64 -> tycon "Int64"

138+

139+mapping :: TType -> Exp -> Exp

140+mapping t e = infixE e "." (go t)

141+ where

142+ go = \case

143+ TMaybe x@(TList {}) -> var "_Default" : go x

144+ TMaybe x -> nest (go x)

145+ x -> maybeToList (iso x)

146+

147+ nest [] = []

148+ nest (x:xs) = [app (var "mapping") (infixE x "." xs)]

149+

150+iso :: TType -> Maybe Exp

151+iso = \case

152+ TList {} -> Just (var "_Coerce")

153+ _ -> Nothing

109154

110155strict :: Type -> Type

111156strict = TyBang BangedTy . \case

@@ -128,5 +173,9 @@ ref f = Text.unpack . f . idToText

128173unqual :: String -> QName

129174unqual = UnQual . name

130175

176+infixE :: Exp -> QOp -> [Exp] -> Exp

177+infixE l _ [] = l

178+infixE l o (r:rs) = infixE (infixApp l o r) o rs

179+

131180str :: Text -> Exp

132181str = strE . Text.unpack

gen/src/Gen/Types.hs+53−30

@@ -24,36 +24,40 @@

2424

2525module Gen.Types

2626 ( module Gen.Types

27+ , module Gen.Types.Help

28+ , module Gen.Types.Id

2729 , module Gen.Types.Map

2830 , module Gen.Types.NS

29− , module Gen.Types.Id

3031 ) where

3132

3233import Control.Applicative

33−import Control.Lens hiding ((.=))

34−import Data.Aeson hiding (Bool, String)

34+import Control.Lens hiding ((.=))

35+import Data.Aeson hiding (Bool, String)

3536import Data.Aeson.TH

3637import Data.Char

37−import Data.Function (on)

38−import Data.List.NonEmpty (NonEmpty (..))

39−import qualified Data.List.NonEmpty as NE

38+import Data.Function (on)

39+import Data.List.NonEmpty (NonEmpty (..))

40+import qualified Data.List.NonEmpty as NE

4041import Data.Maybe

4142import Data.Ord

42−import Data.Semigroup ((<>))

43−import Data.Text (Text)

44−import qualified Data.Text as Text

45−import qualified Data.Text.Lazy as LText

46−import qualified Data.Text.Lazy.Builder as Build

47−import qualified Data.Text.Read as Read

48−import qualified Filesystem.Path.CurrentOS as Path

43+import Data.Semigroup ((<>))

44+import Data.Text (Text)

45+import qualified Data.Text as Text

46+import qualified Data.Text.Lazy as LText

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

48+import qualified Data.Text.Read as Read

49+import qualified Filesystem.Path.CurrentOS as Path

4950import Formatting

5051import Gen.Text

52+import Gen.Types.Help

5153import Gen.Types.Id

5254import Gen.Types.Map

5355import Gen.Types.NS

5456import GHC.Generics

5557import GHC.TypeLits

56−import Text.EDE (Template)

58+import Language.Haskell.Exts (Name)

59+import Language.Haskell.Exts.Pretty (Pretty, prettyPrint)

60+import Text.EDE (Template)

5761

5862default (Text)

5963

@@ -141,7 +145,7 @@ data Location

141145deriveJSON (js "") ''Location

142146

143147data Info = Info

144− { _description :: Maybe Text

148+ { _description :: Maybe Help

145149 , _defaulted :: Maybe Text

146150 , _required :: !Bool

147151 , _location :: Maybe Location

@@ -164,8 +168,13 @@ parameter s = s ^. required && isNothing (s ^. defaulted)

164168data Lit

165169 = Text

166170 | Bool

167− | Int

168− | Long

171+ | Float

172+ | Double

173+ | Byte

174+ | UInt32

175+ | UInt64

176+ | Int32

177+ | Int64

169178 | Nat

170179 | Time

171180 deriving (Eq, Show)

@@ -178,8 +187,13 @@ instance FromJSON Lit where

178187 "string" -> pure Text

179188 "boolean" -> pure Bool

180189 -- Formats

181− "uint64" -> pure (nat n Long)

182− "int32" -> pure (nat n Int)

190+ "float" -> pure Float

191+ "double" -> pure Double

192+ "byte" -> pure (nat n Byte)

193+ "uint32" -> pure (nat n UInt32)

194+ "uint64" -> pure (nat n UInt64)

195+ "int32" -> pure (nat n Int32)

196+ "int64" -> pure (nat n Int64)

183197 "date-time" -> pure Time

184198 e -> fail $

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

@@ -213,8 +227,8 @@ instance FromJSON (Fix Schema) where

213227 Fix <$> (ref i o <|> schema i o)

214228 where

215229 schema i o = o .: "type" >>= \case

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

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

230+ "object" -> Obj i <$> o .:? "properties" .!= mempty

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

218232 "any" -> pure (Any i)

219233 _ -> enm i o <|> Lit i <$> parseJSON (Object o)

220234

@@ -250,30 +264,39 @@ instance FromJSON Param where

250264

251265deriveToJSON (js "") ''Param

252266

253−data Fun = Fun' Text Rendered Rendered

267+data Syn a = Syn { syntax :: a }

268+

269+instance Pretty a => ToJSON (Syn a) where

270+ toJSON = toJSON . prettyPrint . syntax

271+

272+data Fun = Fun' Name (Maybe Help) Rendered Rendered

254273

255274instance ToJSON Fun where

256− toJSON (Fun' h s d) = object

257− [ "help" .= h

275+ toJSON (Fun' n h s d) = object

276+ [ "name" .= Syn n

277+ , "help" .= h

258278 , "sig" .= s

259279 , "decl" .= d

260280 ]

261281

262282data Data

263− = Sum Text Rendered

264− | Prod Rendered Fun [Fun]

283+ = Sum Name (Maybe Help) Rendered

284+ | Prod Name (Maybe Help) Rendered Fun [Fun]

265285

266286instance ToJSON Data where

267287 toJSON = \case

268− Sum h d -> object

269− [ "type" .= "sum"

288+ Sum n h d -> object

289+ [ "name" .= Syn n

290+ , "type" .= "sum"

270291 , "decl" .= d

271292 , "help" .= h

272293 ]

273294

274− Prod d c ls -> object

275− [ "type" .= "prod"

295+ Prod n h d c ls -> object

296+ [ "name" .= Syn n

297+ , "type" .= "prod"

276298 , "decl" .= d

299+ , "help" .= h

277300 , "ctor" .= c

278301 , "lenses" .= ls

279302 ]

gen/src/Gen/Types/Help.hsnew file+86

@@ -0,0 +1,86 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+

4+-- Module : Gen.Types.Help

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

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

8+-- Stability : provisional

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

10+

11+module Gen.Types.Help

12+ ( Help

13+ , Desc (..)

14+ , rawHelpText

15+ ) where

16+

17+import Data.Aeson

18+import Data.Char (isSpace)

19+import Data.String

20+import Data.Text (Text)

21+import qualified Data.Text as Text

22+import Text.Pandoc

23+import Text.Pandoc.Pretty

24+

25+data Help

26+ = Help [Help]

27+ | Pan Pandoc

28+ | Raw Text

29+ deriving (Eq)

30+

31+instance Monoid Help where

32+ mempty = Help []

33+ mappend x y =

34+ case (x, y) of

35+ (Help a, Help b) -> Help (a <> b)

36+ (Pan a, Pan b) -> Pan (a <> b)

37+ (Raw a, Raw b) -> Raw (a <> b)

38+ (Help a, b) -> Help (a <> [b])

39+ (a, Help b) -> Help (a : b)

40+ (a, b) -> Help [a, b]

41+

42+-- | Empty Show instance to avoid verbose debugging output.

43+instance Show Help where

44+ show = const mempty

45+

46+instance IsString Help where

47+ fromString = rawHelpText . fromString

48+

49+rawHelpText :: Text -> Help

50+rawHelpText = Raw

51+

52+instance FromJSON Help where

53+ parseJSON = withText "help" $

54+ either (fail . show) pure

55+ . fmap Pan

56+ . readHtml def

57+ . Text.unpack

58+

59+instance ToJSON Help where

60+ toJSON = toJSON

61+ . mappend "-- |"

62+ . Text.map f

63+ . Text.drop 2

64+ . wrap "-- "

65+ . flatten

66+ where

67+ f '@' = '\''

68+ f x = x

69+

70+data Desc = Desc !Int Help

71+

72+instance ToJSON Desc where

73+ toJSON (Desc n h) = toJSON . wrap (replicate n ' ') $ flatten h

74+

75+flatten :: Help -> String

76+flatten = \case

77+ Help xs -> foldMap flatten xs

78+ Pan d -> writeHaddock def d

79+ Raw t -> Text.unpack t

80+

81+wrap :: String -> String -> Text

82+wrap sep =

83+ Text.dropWhileEnd isSpace

84+ . render (Just 76)

85+ . prefixed sep

86+ . fromString

gen/template/_include/type.ede+18−2

@@ -1,18 +1,34 @@

1+{% if type.help %}

2+{{ type.help }}

3+{% endif %}

14{% case type.type %}

25{% when "prod" %}

6+--

7+-- /See:/ '{{ type.ctor.name }}' smart constructor.

38{{ type.decl }}

49

10+ {% if type.ctor.help %}

511{{ type.ctor.help }}

12+ {% endif %}

13+--

14+ {% for lens in type.lenses %}

15+ {% if lens.first %}

16+-- Use one of the following lenses to modify other fields as desired:

17+ {% endif %}

18+--

19+-- * '{{ lens.value.name }}'

20+ {% endfor %}

621{{ type.ctor.sig }}

722{{ type.ctor.decl }}

823 {% for lens in type.lenses %}

924

25+ {% if lens.value.help %}

1026{{ lens.value.help }}

27+ {% endif %}

1128{{ lens.value.sig }}

1229{{ lens.value.decl }}

13− {% endfor %}

30+ {% endfor %}

1431 {% when "sum" %}

15−{{ type.help }}

1632{{ type.decl }}

1733{% else %}

1834 Error: Unrecognised type '{{ type.type }}'

gen/template/toc.ede+27

@@ -5,6 +5,29 @@

55-- /See:/ <{{ documentationLink }} {{ title }} Reference>

66module {{ moduleName }}

77 (

8+ -- * API Definition

9+ {{ name }}

10+

11+ -- * Resources

12+ -- $resources

13+

14+ -- * Types

15+ {% for schema in schemas %}

16+ {% case schema.value.type %}

17+ {% when "prod" %}

18+

19+ -- ** {{ schema.value.name }}

20+ , {{ schema.value.name }}

21+ , {{ schema.value.ctor.name }}

22+ {% for lens in schema.value.lenses %}

23+ , {{ lens.value.name }}

24+ {% endfor %}

25+ {% when "sum" %}

26+

27+ -- ** {{ schema.value.name }}

28+ , {{ schema.value.name }} (..)

29+ {% endcase %}

30+ {% endfor %}

831 ) where

932

1033{% for module in exposedModules %}

@@ -12,3 +35,7 @@ module {{ moduleName }}

1235import {{ module.value }}

1336 {% endif %}

1437{% endfor %}

38+

39+{- $resources

40+TODO

41+-}

gen/template/types.ede+21−1

@@ -2,13 +2,33 @@

22--

33module {{ moduleName }}

44 (

5+ -- * API Definition

6+ {{ name }}

7+ {% for schema in schemas %}

8+ {% case schema.value.type %}

9+ {% when "prod" %}

10+

11+ -- * {{ schema.value.name }}

12+ , {{ schema.value.name }}

13+ , {{ schema.value.ctor.name }}

14+ {% for lens in schema.value.lenses %}

15+ , {{ lens.value.name }}

16+ {% endfor %}

17+ {% when "sum" %}

18+

19+ -- * {{ schema.value.name }}

20+ , {{ schema.value.name }} (..)

21+ {% endcase %}

22+ {% endfor %}

523 ) where

624

725{% for import in moduleImports %}

826import {{ import.value }}

927{% endfor %}

1028

29+{{ name }} :: a

30+{{ name }} = error "{{ name }}"

1131{% for schema in schemas %}

12− {% include "_include/type.ede" with type = schema.value %}

1332

33+ {% include "_include/type.ede" with type = schema.value %}

1434{% endfor %}