abee599 · gogol · git.iko.soy

git.iko.soy/gogol

on develop help sign in

Trimming unused imports and tidying up compilation warnings

abee599Brendan Hay11 years ago

gen/gozen-gen.cabal+2−2

compare with develop

unifiedsplit

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

29 , Gen.Text

30 , Gen.Tree

31 , Gen.Types

32+ , Gen.Types.Id

32 , Gen.Types.Map

33 , Gen.Types.Map

33 , Gen.Types.NS

34 , Gen.Types.NS

@@ -38,7 +39,6 @@ executable gozen-gen

38 aeson

39 aeson

39 , attoparsec

40 , attoparsec

40 , base == 4.8.*

41 , base == 4.8.*

41− , bifunctors

42 , bytestring

43 , directory-tree

44 , ede

@@ -48,9 +48,9 @@ executable gozen-gen

48 , haskell-src-exts

49 , hindent

50 , lens

51− , mmorph

52 , mtl

51 , mtl

53 , optparse-applicative

52 , optparse-applicative

53+ , parsec

54 , semigroups

55 , system-fileio

56 , system-filepath

gen/src/Gen/AST.hs+46−51

@@ -9,6 +9,7 @@

9{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RecordWildCards #-}

11{-# LANGUAGE TemplateHaskell #-}

12+{-# LANGUAGE ViewPatterns #-}

13-- Module : Gen.AST

14-- Module : Gen.AST

@@ -21,30 +22,17 @@ module Gen.AST where

22import Control.Applicative

23import Control.Applicative

23import Control.Error

24import Control.Error

24−import Control.Lens

25+import Control.Lens hiding (lens)

25import Control.Monad.Except

26import Control.Monad.Except

26−import Control.Monad.Morph

27import Control.Monad.State

28−import Data.Aeson hiding (String)

29−import Data.Aeson.TH

30−import qualified Data.Attoparsec.Text as A

31import Data.Char

28import Data.Char

32import Data.Function (on)

29import Data.Function (on)

33import qualified Data.HashMap.Strict as Map

30import qualified Data.HashMap.Strict as Map

34−import Data.List (groupBy, intersect, nub, sort)

31+import Data.List (groupBy)

35−import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

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

36−import qualified Data.List.NonEmpty as NE

37−import Data.Ord

38−import Data.Semigroup hiding (Sum)

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

39−import Data.Text (Text)

40−import qualified Data.Text as Text

41import qualified Data.Text.Lazy as LText

34import qualified Data.Text.Lazy as LText

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

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

43−import Data.Text.Manipulate

44−import Debug.Trace

45−import qualified Filesystem.Path.CurrentOS as Path

46−import Formatting

47−import Gen.Formatting

48import Gen.Solve

36import Gen.Solve

49import Gen.Syntax

37import Gen.Syntax

50import Gen.Text

38import Gen.Text

@@ -52,42 +40,43 @@ import Gen.Types

52import HIndent

40import HIndent

53import Language.Haskell.Exts.Pretty

41import Language.Haskell.Exts.Pretty

54import Prelude hiding (sum)

42import Prelude hiding (sum)

55−import Text.EDE (Template)

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

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

58−flatten :: Map Ref (Fix Schema) -> Map Ref (Schema Ref)

45+flatten :: Map Id (Fix Schema) -> Map Id (Schema Id)

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

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

60 where

47 where

61 -- unfold the properties.

48 -- unfold the properties.

62 prop p k (Fix f) = case f of

49 prop p k (Fix f) = case f of

63 Obj i ps -> do

50 Obj i ps -> do

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

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

65 res o

52 res o

67− Arr i e -> do

54+ Arr i (Fix e) -> do

68− e' <- prop (Just ref) "item" e

55+ e' <- prop (Just this) "item" (Fix (e & required .~ True))

69 res (Arr i e')

56 res (Arr i e')

71 Enum i vs ds -> res (Enum i vs ds)

58 Enum i vs ds -> res (Enum i vs ds)

72 Lit i l -> res (Lit i l)

59 Lit i l -> res (Lit i l)

73− Ref r -> pure r

60+ Ref _ r -> pure r

74− Any' -> res Any'

61+ Any i -> res (Any i)

76 where

63 where

77 res x = do

64 res x = do

78− m <- gets (Map.lookup ref)

65+ s <- gets (Map.lookup this)

79− case m of

66+ case s of

80− Nothing -> modify (Map.insert ref x) >> pure ref

67+ Nothing -> modify (Map.insert this x) >> pure this

81 -- FIXME:

68 -- FIXME:

82− Just e -> error $ "Already exists: " ++ show (ref, e, x)

69+ Just e -> error $ "Already exists: " ++ show (this, e, x)

84− ref = maybe k (<> k) p

71+ this = maybe k (<> k) p

86merge :: Versions -> [Service Data] -> [Library]

73merge :: Versions -> [Service Data] -> [Library]

87merge v = map go . groupBy (on (==) _svcLibrary)

74merge v = map go . groupBy (on (==) _svcLibrary)

88 where

75 where

89 go [x] = mk x

76 go [x] = mk x

90 go (x:xs) = (mk x) { _libServices = x :| xs }

77 go (x:xs) = (mk x) { _libServices = x :| xs }

78+ -- FIXME:

79+ go [] = error "Empty merge set!"

92 mk x = Library

81 mk x = Library

93 { _libName = _svcLibrary x

82 { _libName = _svcLibrary x

@@ -103,42 +92,32 @@ render s = runAST (Memo mempty mempty ss) $ do

103 where

92 where

104 ss = flatten (_svcSchemas s)

93 ss = flatten (_svcSchemas s)

105

106− go :: Ref -> Schema Ref -> AST (Maybe Data)

95+ go :: Id -> Schema Id -> AST (Maybe Data)

107 go k = \case

96 go k = \case

108 Arr {} -> pure Nothing

97 Arr {} -> pure Nothing

109 Ref {} -> pure Nothing

98 Ref {} -> pure Nothing

110− Any' {} -> pure Nothing

99+ Any {} -> pure Nothing

111 Lit {} -> pure Nothing

100 Lit {} -> pure Nothing

112 Enum {} -> Just <$> sum

101 Enum {} -> Just <$> sum

113 where

102 where

114 sum = Sum "sum help"

103 sum = Sum "sum help"

115 <$> pp Indent enumDecl

104 <$> pp Indent enumDecl

116

105

117− Obj _ rs -> Just <$> prod

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

118 where

107 where

119− prod = Prod

108+ prod ts = Prod

120− <$> (objDecl k rs >>= pp Indent)

109+ <$> (objDecl k ts >>= pp Indent)

121− <*> ctor

110+ <*> ctor ts

122− <*> traverse (uncurry lens) (Map.toList rs)

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

123

112

124− ctor = Fun' "ctor help"

113+ ctor ts = Fun' "ctor help"

125− <$> pp None ctorSig

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

126− <*> pp Indent ctorDecl

115+ <*> pp Indent (ctorDecl k ts)

127

116

128− lens n v = Fun' "lens help"

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

129 <$> pp None lensSig

118 <$> pp None lensSig

130 <*> pp Print lensDecl

119 <*> pp Print lensDecl

131

120

132− -- record declaration

133− -- smart constructor

134− -- signature

135− -- declaration

136− -- documentation

137− -- lenses per property

138− -- signature

139− -- declaration

140− -- documentation

141−

142data PP

121data PP

143 = Indent

122 = Indent

144 | Print

123 | Print

@@ -152,7 +131,7 @@ pp i x

152 where

131 where

153 result = hoistEither . bimap e Build.toLazyText

132 result = hoistEither . bimap e Build.toLazyText

154

133

155− e = flip mappend (", when formatting datatype: " <> p) . LText.pack

134+ e = flip mappend (", when formatting: " <> p) . LText.pack

156

135

157 p = LText.dropWhile isSpace

136 p = LText.dropWhile isSpace

158 . LText.pack

137 . LText.pack

@@ -170,3 +149,19 @@ pp i x

170 { layout = PPNoLayout

149 { layout = PPNoLayout

171 , spacing = False

150 , spacing = False

172 }

151 }

152+

153+-- FIXME: dirty hack to render smart ctor parameter comments.

154+comments :: Map Id Solved -> Rendered -> AST Rendered

155+comments (Map.toList -> rs) x = do

156+ let ks = filter (parameter . _schema . snd) rs

157+ ps = map (Just . fst) ks ++ repeat Nothing

158+ return

159+ . LText.replace " :: " "\n :: "

160+ . LText.intercalate "\n -> "

161+ . zipWith rel ps

162+ . map LText.strip

163+ $ LText.splitOn "->" x

164+ where

165+ rel Nothing t = t

166+ rel (Just k) t =

167+ t <> " -- ^ '" <> LText.fromStrict (idToText k) <> "'"

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

@@ -17,7 +17,7 @@ module Gen.Formatting

17import Control.Monad.Except

18import qualified Data.Text.Lazy as LText

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

20−import Formatting hiding (left, right)

20+import Formatting hiding (base, left, right)

21import Formatting.Internal (runFormat)

22import Formatting.Time hiding (fmt)

23import Gen.Types

gen/src/Gen/Solve.hs+41−48

@@ -21,40 +21,21 @@ module Gen.Solve where

22import Control.Applicative

23import Control.Error

24−import Control.Lens

24+import Control.Lens hiding (enum)

25import Control.Monad.Except

26−import Control.Monad.Morph

27import Control.Monad.State

26import Control.Monad.State

28−import qualified Data.Attoparsec.Text as A

27+import qualified Data.HashMap.Strict as Map

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)

28+import Data.List (intersect)

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

34−import qualified Data.List.NonEmpty as NE

35−import Data.Ord

36−import Data.Semigroup hiding (Sum)

29+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 Debug.Trace

43−import qualified Filesystem.Path.CurrentOS as Path

44−import Formatting

45import Gen.Formatting

30import Gen.Formatting

46−import Gen.Text

47import Gen.Types

31import Gen.Types

48−import HIndent

49−import Language.Haskell.Exts.Pretty

50−import Prelude hiding (sum)

32+import Prelude hiding (sum)

51−import Text.EDE (Template)

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

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

54-- behind a StateT interface.

35-- behind a StateT interface.

56data TType

37data TType

57− = TType Ref

38+ = TType Id

58 | TLit Lit

39 | TLit Lit

59 | TMaybe TType

40 | TMaybe TType

60 | TEither TType TType

41 | TEither TType TType

@@ -77,28 +58,37 @@ data Derive

77 deriving (Eq, Show)

58 deriving (Eq, Show)

79data Memo = Memo

60data Memo = Memo

80− { _typed :: Map Ref TType

61+ { _typed :: Map Id TType

81− , _derived :: Map Ref [Derive]

62+ , _derived :: Map Id [Derive]

82− , _schemas :: Map Ref (Schema Ref)

63+ , _schemas :: Map Id (Schema Id)

83 }

64 }

85makeLenses ''Memo

66makeLenses ''Memo

87type AST = ExceptT Error (State Memo)

68type AST = ExceptT Error (State Memo)

89−type Solved = (Schema Ref, TType, [Derive])

70+data Solved = Solved

71+ { _schema :: Schema Id

72+ , _type :: TType

73+ , _deriving :: [Derive]

74+ }

75+

76+instance HasInfo Solved where

77+ info = f . info

78+ where

79+ f = lens _schema (\s a -> s { _schema = a })

91runAST :: Memo -> AST a -> Either Error a

81runAST :: Memo -> AST a -> Either Error a

92runAST s m = evalState (runExceptT m) s

82runAST s m = evalState (runExceptT m) s

94−schema :: Ref -> AST (Schema Ref)

84+schema :: Id -> AST (Schema Id)

95schema k = do

85schema k = do

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

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

97 case m of

87 case m of

98− Nothing -> failure ("Missing Schema: " % fref) k

88+ Nothing -> failure ("Missing Schema: " % fid) k

99 Just v -> pure v

89 Just v -> pure v

100

101−memo :: Lens' Memo (Map Ref v) -> Ref -> (Schema Ref -> AST v) -> AST v

91+memo :: Lens' Memo (Map Id v) -> Id -> (Schema Id -> AST v) -> AST v

102memo l k f = do

92memo l k f = do

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

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

104 case m of

94 case m of

@@ -108,30 +98,33 @@ memo l k f = do

108 l %= Map.insert k x

98 l %= Map.insert k x

109 return x

99 return x

110

100

111−solve :: Ref -> AST Solved

101+solve :: Id -> AST Solved

112−solve k = (,,) <$> schema k <*> typeOf k <*> derive k

102+solve k = Solved <$> schema k <*> typeOf k <*> derive k

113

103

114−typeOf :: Ref -> AST TType

104+typeOf :: Id -> AST TType

115typeOf k = loc "typeOf" k $ memo typed k go

105typeOf k = loc "typeOf" k $ memo typed k go

116 where

106 where

117− go = \case

107+ go s = fmap may $ case s of

118 Obj {} -> pure (TType k)

108 Obj {} -> pure (TType k)

119− Arr _ r -> pure (TList (TType r))

109+ Arr _ r -> TList <$> typeOf r

120 Enum {} -> pure (TType k)

110 Enum {} -> pure (TType k)

121− Ref r -> typeOf r

111+ Ref _ r -> typeOf r

122− Any' -> pure (TEither (TLit Text) (TLit Long))

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

123 Lit _ l -> pure (TLit l)

113 Lit _ l -> pure (TLit l)

114+ where

115+ may | parameter s = id

116+ | otherwise = TMaybe

124

117

125−derive :: Ref -> AST [Derive]

118+derive :: Id -> AST [Derive]

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

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

127 where

120 where

128 go = \case

121 go = \case

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

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

130− Arr _ r -> pure [] -- mappend monoid . intersect base <$> derive r

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

131− Enum {} -> pure enum

124+ Enum {} -> pure enum

132− Ref r -> derive r

125+ Ref _ r -> derive r

133− Any' -> pure base

126+ Any _ -> pure base

134− Lit _ l -> pure $

127+ Lit _ l -> pure $

135 case l of

128 case l of

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

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

137 Bool -> base <> enum

130 Bool -> base <> enum

@@ -146,5 +139,5 @@ derive k = loc "derive" k $ memo derived k go

146 enum = [DOrd, DEnum]

139 enum = [DOrd, DEnum]

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

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

148

141

149−loc :: String -> Ref -> a -> a

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

150−loc n r = id -- trace (n ++ ": " ++ Text.unpack (refToText r))

143+loc _ _ = id -- trace (n ++ ": " ++ Text.unpack (refToText r))

gen/src/Gen/Syntax.hs+57−32

@@ -11,50 +11,64 @@

12module Gen.Syntax where

14+import Control.Lens hiding (strict)

15+import Data.Foldable (foldr')

14import qualified Data.HashMap.Strict as Map

16import qualified Data.HashMap.Strict as Map

15−import Data.Semigroup

16−import Data.String

17import Data.Text (Text)

18import qualified Data.Text as Text

19import Data.Text.Manipulate

20import Gen.Solve

21+import Gen.Text

21import Gen.Types

22import Gen.Types

22−import qualified Language.Haskell.Exts as Exts

23import Language.Haskell.Exts.Build

24import Language.Haskell.Exts.SrcLoc

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

27−objDecl :: Ref -> Map Ref Ref -> AST Decl

27+objDecl :: Id -> Map Id Solved -> AST Decl

28−objDecl r rs = do

29− con <- conDecl n rs

30− ds <- derivings r

31− return $! DataDecl noLoc arity [] n [] [con] ds

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

32 where

29 where

33− n = dname r

30+ d = dname r

35 arity | Map.size rs == 1 = NewType

32 arity | Map.size rs == 1 = NewType

36 | otherwise = DataType

33 | otherwise = DataType

38−conDecl :: Name -> Map Ref Ref -> AST QualConDecl

35+conDecl :: Name -> Map Id Solved -> QualConDecl

39−conDecl n rs = QualConDecl noLoc [] [] <$> body

36+conDecl n rs = QualConDecl noLoc [] [] body

40 where

37 where

41 body = case Map.toList rs of

38 body = case Map.toList rs of

42− [] -> pure (ConDecl n [])

39+ [] -> ConDecl n []

43− [x] -> RecDecl n . (:[]) <$> field internal x

40+ [x] -> RecDecl n [field internal x]

44− xs -> RecDecl n <$> traverse (field (strict . internal)) xs

41+ xs -> RecDecl n (map (field (strict . internal)) xs)

46− field f (k, v) = do

43+ field f (k, v) = ([fname k], f (_type v))

47− t <- typeOf v

48− return ([fname k], f t)

50−derivings :: Ref -> AST [Deriving]

45+ctorSig :: Id -> Map Id Solved -> Decl

51−derivings = fmap (map ((,[]) . unqual . drop 1 . show)) . derive

46+ctorSig r rs = TypeSig noLoc [c] ts

47+ where

48+ c = cname r

49+ d = dname r

50+

51+ ts = foldr' TyFun (TyCon (UnQual d)) ps

52+ ps = parameters (Map.elems rs)

53+

54+ctorDecl :: Id -> Map Id Solved -> Decl

55+ctorDecl r rs = sfun noLoc c ps (UnGuardedRhs rhs) noBinds

56+ where

57+ c = cname r

58+ d = dname r

59+

60+ rhs | Map.null rs = var d

61+ | otherwise = RecConstr (UnQual d) $

62+ map (uncurry fieldUpdate) (Map.toList rs)

53−ctorSig :: Decl

64+ ps = map pname . Map.keys $ Map.filter (view required) rs

54−ctorSig = emptyDecl

56−ctorDecl :: Decl

66+fieldUpdate :: Id -> Solved -> FieldUpdate

57−ctorDecl = emptyDecl

67+fieldUpdate r s = FieldUpdate (UnQual (fname r)) rhs

68+ where

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

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

71+ | otherwise = var (name "Nothing")

59lensSig :: Decl

73lensSig :: Decl

60lensSig = emptyDecl

74lensSig = emptyDecl

@@ -68,13 +82,20 @@ enumDecl = emptyDecl

68emptyDecl :: Decl

82emptyDecl :: Decl

69emptyDecl = DataDecl noLoc DataType [] (name "Empty") [] [] []

83emptyDecl = DataDecl noLoc DataType [] (name "Empty") [] [] []

85+derivings :: Id -> AST [Deriving]

86+derivings = fmap (map ((,[]) . unqual . drop 1 . show)) . derive

87+

88+parameters :: [Solved] -> [Type]

89+parameters = map (external . _type) . filter (view required)

90+

71−internal :: TType -> Type

91+external, internal :: TType -> Type

92+external = internal

72internal = go

93internal = go

73 where

94 where

74 go = \case

95 go = \case

75 TType r -> tycon r

96 TType r -> tycon r

76 TMaybe t -> TyApp (tycon "Maybe") (go t)

97 TMaybe t -> TyApp (tycon "Maybe") (go t)

77−-- TEither a b ->

98+ TEither a b -> TyApp (TyApp (tycon "Either") (go a)) (go b)

78 TList t -> TyList (go t)

99 TList t -> TyList (go t)

79 TLit l -> lit l

100 TLit l -> lit l

101

@@ -91,17 +112,21 @@ strict = TyBang BangedTy . \case

91 t@TyApp{} -> TyParen t

112 t@TyApp{} -> TyParen t

92 t -> t

113 t -> t

114

94−dname :: Ref -> Name

115+dname, cname, fname, lname, pname :: Id -> Name

95dname = name . ref upperHead

116dname = name . ref upperHead

117+cname = name . ref (renameReserved . lowerHead)

118+fname = name . ref (Text.cons '_' . lowerHead)

119+lname = name . ref lowerHead

120+pname = name . ref (flip Text.snoc '_' . Text.cons 'p' . upperHead)

121

97−fname :: Ref -> Name

98−fname = name . ref (Text.cons '_')

99−

100−tycon :: Ref -> Type

122+tycon :: Id -> Type

101tycon = TyCon . unqual . ref upperHead

123tycon = TyCon . unqual . ref upperHead

102

124

103−ref :: (Text -> Text) -> Ref -> String

125+ref :: (Text -> Text) -> Id -> String

104−ref f = Text.unpack . f . refToText

126+ref f = Text.unpack . f . idToText

105

127

106unqual :: String -> QName

128unqual :: String -> QName

107unqual = UnQual . name

129unqual = UnQual . name

130+

131+str :: Text -> Exp

132+str = strE . Text.unpack

gen/src/Gen/Text.hs+18−23

@@ -27,8 +27,8 @@ import qualified Data.Text as Text

27-- import Data.Text.ICU.Replace (Replace)

28-- import qualified Data.Text.ICU.Replace as RE

29import Data.Text.Manipulate

30−-- import Text.Parsec.Language (haskellDef)

30+import Text.Parsec.Language (haskellDef)

31−-- import Text.Parsec.Token (reservedNames)

31+import Text.Parsec.Token (reservedNames)

33-- asText :: (Text -> Text) -> String -> String

34-- asText f = Text.unpack . f . Text.pack

@@ -68,27 +68,22 @@ renameAbbrev = mconcat

68 . stripPrefix "Google "

69 . stripSuffix " API"

71−-- renameReserved :: Text -> Text

71+renameReserved :: Text -> Text

72−-- renameReserved x

72+renameReserved x

73−-- | x `Set.member` xs = x <> "'"

73+ | x `Set.member` xs = x <> "'"

74−-- | otherwise = x

74+ | otherwise = x

75−-- where

75+ where

76−-- xs = Set.fromList $

76+ xs = Set.fromList $

77−-- [ "head"

77+ [ "head"

78−-- , "tail"

78+ , "tail"

79−-- , "delete"

79+ , "delete"

80−-- , "filter"

80+ , "filter"

81−-- , "True"

82−-- , "False"

83−-- , "map"

81+ , "map"

84−-- , "object"

82+ , "object"

85−-- , "get"

83+ , "get"

86−-- , "group"

84+ , "group"

87−-- , "GT"

85+ , "error"

88−-- , "LT"

89−-- , "EQ"

90−-- , "Error"

91−-- ] ++ map Text.pack (reservedNames haskellDef)

86+ ] ++ map Text.pack (reservedNames haskellDef)

93-- camelAcronym :: Text -> Text

88-- camelAcronym :: Text -> Text

94-- camelAcronym x = replaceAll x xs

89-- camelAcronym x = replaceAll x xs

gen/src/Gen/Tree.hs+2−5

@@ -22,13 +22,10 @@ module Gen.Tree

22 ) where

24import Control.Error

25−import Control.Lens (each, (^.), (^..))

26import Control.Monad

25import Control.Monad

27import Control.Monad.Except

26import Control.Monad.Except

28import Data.Aeson hiding (json)

27import Data.Aeson hiding (json)

29import Data.Bifunctor

28import Data.Bifunctor

30−import Data.Functor.Identity

31−import qualified Data.HashMap.Strict as Map

32import qualified Data.List.NonEmpty as NE

29import qualified Data.List.NonEmpty as NE

33import Data.Monoid

30import Data.Monoid

34import Data.Text (Text)

31import Data.Text (Text)

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

99 lib :: Path

96 lib :: Path

100 lib = fromText (_libName l)

97 lib = fromText (_libName l)

101

102− mod :: NS -> [NS] -> Template -> DirTree (Either Error Touch)

99+ -- mod :: NS -> [NS] -> Template -> DirTree (Either Error Touch)

103− mod n is t = write . module' n is t . pure $ toJSON l

100+ -- mod n is t = write . module' n is t . pure $ toJSON l

104

101

105 file :: Path -> Template -> DirTree (Either Error Touch)

102 file :: Path -> Template -> DirTree (Either Error Touch)

106 file p t = write $ file' p t (pure env)

103 file p t = write $ file' p t (pure env)

gen/src/Gen/Types.hs+51−64

@@ -26,32 +26,29 @@ module Gen.Types

26 ( module Gen.Types

27 , module Gen.Types.Map

28 , module Gen.Types.NS

29+ , module Gen.Types.Id

29 ) where

30 ) where

31import Control.Applicative

32import Control.Applicative

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

32import Data.Aeson hiding (Bool, String)

34import Data.Aeson hiding (Bool, String)

33import Data.Aeson.TH

35import Data.Aeson.TH

34−import qualified Data.Attoparsec.Text as A

35−import Data.Bifunctor

36import Data.Char

37import Data.Function (on)

38−import Data.Hashable

39−import qualified Data.HashMap.Strict as Map

40−import Data.List (groupBy, nub, sort)

41−import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

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

42import qualified Data.List.NonEmpty as NE

39import qualified Data.List.NonEmpty as NE

40+import Data.Maybe

43import Data.Ord

41import Data.Ord

44−import Data.Semigroup hiding (Sum)

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

45−import Data.String

46import Data.Text (Text)

43import Data.Text (Text)

47import qualified Data.Text as Text

44import qualified Data.Text as Text

48import qualified Data.Text.Lazy as LText

45import qualified Data.Text.Lazy as LText

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

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

50−import Data.Text.Manipulate

51import qualified Data.Text.Read as Read

47import qualified Data.Text.Read as Read

52import qualified Filesystem.Path.CurrentOS as Path

48import qualified Filesystem.Path.CurrentOS as Path

53import Formatting

49import Formatting

54import Gen.Text

50import Gen.Text

51+import Gen.Types.Id

55import Gen.Types.Map

52import Gen.Types.Map

56import Gen.Types.NS

53import Gen.Types.NS

57import GHC.Generics

54import GHC.Generics

@@ -144,10 +141,10 @@ data Location

144deriveJSON (js "") ''Location

141deriveJSON (js "") ''Location

145

142

146data Info = Info

143data Info = Info

147− { _infoDescription :: Maybe Text

144+ { _description :: Maybe Text

148− , _infoDefault :: Maybe Text

145+ , _defaulted :: Maybe Text

149− , _infoRequired :: !Bool

146+ , _required :: !Bool

150− , _infoLocation :: Maybe Location

147+ , _location :: Maybe Location

151 } deriving (Eq, Show)

148 } deriving (Eq, Show)

152

149

153instance FromJSON Info where

150instance FromJSON Info where

@@ -159,6 +156,11 @@ instance FromJSON Info where

159

156

160deriveToJSON (js "_info") ''Info

157deriveToJSON (js "_info") ''Info

161

158

159+makeClassy ''Info

160+

161+parameter :: HasInfo a => a -> Bool

162+parameter s = s ^. required && isNothing (s ^. defaulted)

163+

162data Lit

164data Lit

163 = Text

165 = Text

164 | Bool

166 | Bool

@@ -170,7 +172,7 @@ data Lit

170

172

171instance FromJSON Lit where

173instance FromJSON Lit where

172 parseJSON = withObject "literal" $ \o -> do

174 parseJSON = withObject "literal" $ \o -> do

173− n <- min =<< (o .:? "minimum" .!= "0")

175+ n <- num =<< (o .:? "minimum" .!= "0")

174 (o .: "format" <|> o .: "type") >>= \case

176 (o .: "format" <|> o .: "type") >>= \case

175 -- Types

177 -- Types

176 "string" -> pure Text

178 "string" -> pure Text

@@ -182,7 +184,7 @@ instance FromJSON Lit where

182 e -> fail $

184 e -> fail $

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

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

184 where

186 where

185− min = either fail (pure . fst) . Read.decimal

187+ num = either fail (pure . fst) . Read.decimal

186

188

187 nat :: Int -> Lit -> Lit

189 nat :: Int -> Lit -> Lit

188 nat n | n > 0 = const Nat

190 nat n | n > 0 = const Nat

@@ -196,65 +198,50 @@ instance FromJSON Lit where

196

198

197deriveToJSON (js "") ''Lit

199deriveToJSON (js "") ''Lit

198

200

199−data Ref

200− = Opaque [Text]

201− | Direct Text

202− deriving (Eq, Show, Generic)

203−

204−instance Semigroup Ref where

205− a <> b = case (a, b) of

206− (Opaque xs, Opaque ys) -> Opaque (xs <> ys)

207− (Opaque xs, Direct y) -> Opaque (xs <> [y])

208− (Direct x, Opaque ys) -> Opaque (x : ys)

209− (Direct x, Direct y) -> Opaque [x, y]

210−

211−instance Hashable Ref

212−

213−instance IsString Ref where

214− fromString = Direct . fromString

215−

216−instance FromJSON Ref where parseJSON = withText "ref" (pure . Direct)

217−instance ToJSON Ref where toJSON = toJSON . refToText

218−

219−instance FromJSON a => FromJSON (Map Ref a) where

220− parseJSON = fmap (Map.fromList . map (first Direct) . Map.toList) . parseJSON

221−

222−instance ToJSON a => ToJSON (Map Ref a) where

223− toJSON = toJSON . Map.fromList . map (first refToText) . Map.toList

224−

225−refToText :: Ref -> Text

226−refToText = \case

227− Opaque xs -> mconcat (map upperHead xs)

228− Direct n -> n

229−

230−fref :: Format a (Ref -> a)

231−fref = later (Build.fromText . refToText)

232−

233data Schema a

201data Schema a

234− = Obj Info (Map Ref a)

202+ = Obj Info (Map Id a)

235 | Arr Info a

203 | Arr Info a

236 | Enum Info [Text] [Text]

204 | Enum Info [Text] [Text]

237 | Lit Info Lit

205 | Lit Info Lit

238− | Ref Ref

206+ | Ref Info Id

239− | Any' -- String or Number

207+ | Any Info -- String or Number

240 deriving (Eq, Show, Functor, Foldable, Traversable)

208 deriving (Eq, Show, Functor, Foldable, Traversable)

241

209

242instance FromJSON (Fix Schema) where

210instance FromJSON (Fix Schema) where

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

211+ parseJSON = withObject "schema" $ \o -> do

212+ i <- parseJSON (Object o)

213+ Fix <$> (ref i o <|> schema i o)

244 where

214 where

245− schema o = do

246− i <- parseJSON (Object o)

247− o .: "type" >>= \case

215+ schema i o = o .: "type" >>= \case

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

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

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

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

250− "any" -> pure Any'

218+ "any" -> pure (Any i)

251− _ -> enum i o <|> Lit i <$> parseJSON (Object o)

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

252

220

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

221+ enm i o = Enum i <$> o .: "enum" <*> o .: "enumDescriptions"

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

222+ ref i o = Ref i <$> o .: "$ref"

255

223

256deriveToJSON (js "") ''Schema

224deriveToJSON (js "") ''Schema

257

225

226+instance HasInfo (Schema a) where

227+ info = lens f (flip g)

228+ where

229+ f = \case

230+ Obj i _ -> i

231+ Arr i _ -> i

232+ Enum i _ _ -> i

233+ Lit i _ -> i

234+ Ref i _ -> i

235+ Any i -> i

236+

237+ g i = \case

238+ Obj _ p -> Obj i p

239+ Arr _ e -> Arr i e

240+ Enum _ v d -> Enum i v d

241+ Lit _ l -> Lit i l

242+ Ref _ r -> Ref i r

243+ Any {} -> Any i

244+

258data Param = Param Location -- (Fix Schema)

245data Param = Param Location -- (Fix Schema)

259

246

260instance FromJSON Param where

247instance FromJSON Param where

@@ -309,8 +296,8 @@ data Service a = Service

309 , _svcServicePath :: Text

296 , _svcServicePath :: Text

310 , _svcBatchPath :: Text

297 , _svcBatchPath :: Text

311 , _svcAuth :: Maybe Object

298 , _svcAuth :: Maybe Object

312− , _svcParameters :: Map Ref Param

299+ , _svcParameters :: Map Id Param

313− , _svcSchemas :: Map Ref a

300+ , _svcSchemas :: Map Id a

314 , _svcResources :: Object

301 , _svcResources :: Object

315 } deriving (Generic)

302 } deriving (Generic)

316

303

gen/src/Gen/Types/Id.hsnew file+79

@@ -0,0 +1,79 @@

1+{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE LambdaCase #-}

5+-- Module : Gen.Types.Id

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

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

9+-- Stability : provisional

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

11+

12+module Gen.Types.Id

13+ ( Id

14+ , idToText

15+ , idFromText

16+ , fid

17+ ) where

18+

19+import Control.Applicative

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

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

22+import Data.Aeson.TH

23+import qualified Data.Attoparsec.Text as A

24+import Data.Bifunctor

25+import Data.Char

26+import Data.Function (on)

27+import Data.Hashable

28+import qualified Data.HashMap.Strict as Map

29+import Data.Maybe

30+import Data.Ord

31+import Data.Semigroup hiding (Sum)

32+import Data.String

33+import Data.Text (Text)

34+import qualified Data.Text as Text

35+import qualified Data.Text.Lazy as LText

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

37+import Data.Text.Manipulate

38+import Formatting

39+import Gen.Text

40+import Gen.Types.Map

41+import GHC.Generics

42+

43+data Id

44+ = Opaque [Text]

45+ | Direct Text

46+ deriving (Eq, Show, Generic)

47+

48+instance Semigroup Id where

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

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

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

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

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

54+

55+instance IsString Id where

56+ fromString = idFromText . fromString

57+

58+instance Hashable Id

59+

60+instance FromJSON Id where parseJSON = withText "id" (pure . idFromText)

61+instance ToJSON Id where toJSON = toJSON . idToText

62+

63+instance FromJSON a => FromJSON (Map Id a) where

64+ parseJSON o = Map.fromList . map (first idFromText) . Map.toList

65+ <$> parseJSON o

66+

67+instance ToJSON a => ToJSON (Map Id a) where

68+ toJSON = toJSON . Map.fromList . map (first idToText) . Map.toList

69+

70+idToText :: Id -> Text

71+idToText = \case

72+ Opaque xs -> mconcat (map upperHead xs)

73+ Direct n -> n

74+

75+idFromText :: Text -> Id

76+idFromText = Direct . renameReserved

77+

78+fid :: Format a (Id -> a)

79+fid = later (Build.fromText . idToText)

gen/src/Main.hs+6−1

@@ -28,7 +28,7 @@ import Gen.Formatting

28import Gen.IO

29import qualified Gen.JSON as JS

30import qualified Gen.Tree as Tree

31−import Gen.Types

31+import Gen.Types hiding (info)

32import Options.Applicative

34data Opt = Opt

@@ -182,6 +182,11 @@ class HasName a where getName :: a -> Text

182instance HasName Spec where getName = _specName

183instance HasName Library where getName = _libName

184

185+counter :: (MonadIO m, HasName a)

186+ => Text

187+ -> [a]

188+ -> (a -> ExceptT Error m b)

189+ -> ExceptT Error m [b]

185counter k xs f = forM (zip [1..] xs) $ \(n, x) -> do

190counter k xs f = forM (zip [1..] xs) $ \(n, x) -> do

186 title ("[" % int % "/" % int % "] " % stext % ":" % stext)

191 title ("[" % int % "/" % int % "] " % stext % ":" % stext)

187 (n :: Int) i k (getName x)

192 (n :: Int) i k (getName x)