language-thrift 0.4.0.0 → 0.5.0.0

raw patch · 15 files changed

+1386/−721 lines, 15 filesdep +lensdep +transformersdep −mtldep ~parsersPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, transformers

Dependencies removed: mtl

Dependency ranges changed: parsers

API changes (from Hackage documentation)

Files

• CHANGES.md +35/−0
• Language/Thrift/Parser.hs +154/−67
• Language/Thrift/Pretty.hs +90/−38
• Language/Thrift/Types.hs +492/−227
• README.md +3/−0
• examples/Setup.hs +2/−0
• examples/generateHaskellTypes.hs +151/−116
• examples/reformatIDL.hs +7/−6
• language-thrift.cabal +20/−9
• test/Language/Thrift/Arbitrary.hs +288/−0
• test/Language/Thrift/ParserSpec.hs +47/−0
• test/Language/Thrift/TypesSpec.hs +36/−257
• test/Main.hs +11/−0
• test/Spec.hs +1/−1
• test/TestUtils.hs +49/−0

@@ -1,3 +1,38 @@+0.5.0.0+=======++The AST representation has been overhauled to be more consistent and+accessible. As a result, this release contains a number of breaking changes:++-   Moved `Header` records into `Include` and `Namespace` types.+-   Moved `ConstDefinition` record into separate type, `Const`.+-   Moved `ServiceDefinition` record into separate type, `Service`.+-   Moved `Type` records into separate types: `Typedef`, `Enum`, `Struct`,+    `Union`, `Exception`, `Senum`.+-   Renamed `FieldType` to `TypeReference`.+-   Renamed parser and pretty printer for `TypeReference` to `typeReference`.+-   Renamed the following record fields: `constType` to `constValueType`,+    `typedefType` to `typedefTargetType`, `fieldType` to `fieldValueType`, and+    `fieldDefault` to `fieldDefaultValue`.+-   Hide `function` parser and pretty printer.+-   Moved type annotations for defined types into the records for the types+    themselves.++Other changes:++-   Added lenses and prisms for AST types where appropriate.+-   Parsing will fail if the end of the document is not reached when the parser+    stops. This fixes the bug where the parser would stop half way through a+    file when it saw a recoverable error.+-   Added source annotations to headers, type references (`DefinedType`) and+    constant value references (`ConstIdentifer`).+-   Added `i8` as an alias for `byte`.+-   Type annotations are now allowed to have no associated value.+-   Expose parsers and pretty printers for different headers and definitions.+-   Fixed a bug which would cause parsing to fail if a definition ended with a+    semicolon or a comma.+-   Drop dependency on mtl.+ 0.4.0.0 ======= 

@@ -29,10 +29,24 @@     -- * Components      , program+     , header+    , include+    , namespace+     , definition-    , function-    , fieldType+    , constant+    , typeDefinition+    , service++    , typedef+    , enum+    , struct+    , union+    , exception+    , senum++    , typeReference     , constantValue      -- * Parser@@ -43,17 +57,17 @@  import Control.Applicative import Control.Monad-import Control.Monad.Reader    (ReaderT)-import Control.Monad.State     (StateT)-import Control.Monad.Trans     (lift)+import Control.Monad.Trans.Reader    (ReaderT)+import Control.Monad.Trans.State     (StateT)+import Control.Monad.Trans.Class     (lift) import Data.Text               (Text) import Text.Parser.Char import Text.Parser.Combinators import Text.Parser.Token import Text.Parser.Token.Style (emptyIdents) -import qualified Control.Monad.Reader as Reader-import qualified Control.Monad.State  as State+import qualified Control.Monad.Trans.Reader as Reader+import qualified Control.Monad.Trans.State  as State import qualified Data.Text            as Text  import qualified Language.Thrift.Types as T@@ -87,7 +101,8 @@ -- allows injecting a configurable action @(p n)@ which produces annotations -- that will be attached to entities in the Thrift file. See 'thriftIDLParser' -- for an example.-newtype ThriftParser p n a = ThriftParser (StateT ParserState (ReaderT (p n) p) a)+newtype ThriftParser p n a =+        ThriftParser (StateT ParserState (ReaderT (p n) p) a)     deriving       ( Functor       , Applicative@@ -119,7 +134,8 @@     Reader.runReaderT (State.evalStateT p (ParserState Nothing)) getAnnot  -instance (TokenParsing p, MonadPlus p) => TokenParsing (ThriftParser p n) where+instance+  (TokenParsing p, MonadPlus p) => TokenParsing (ThriftParser p n) where     -- Docstring parsing works by cheating. We define docstrings as     -- whitespace, but we record it when we move over it. If we run into     -- another newline or other comments after seeing the docstring's "*/\n",@@ -184,7 +200,11 @@  -- | Top-level parser to parse complete Thrift documents. program :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Program n)-program = whiteSpace >> T.Program <$> many header <*> many definition+program = whiteSpace >>+    T.Program+        <$> many (header     <* optionalSep)+        <*> many (definition <* optionalSep)+        <*  eof   -- | A string literal. @"hello"@@@ -198,25 +218,63 @@   -- | Headers defined for the IDL.-header :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.Header-header = choice [-    reserved "include" >> T.Include <$> literal-  , reserved "namespace" >>-      T.Namespace <$> (text "*" <|> identifier) <*> identifier-  , reserved "cpp_namespace" >> T.Namespace "cpp" <$> identifier-  , reserved "php_namespace" >> T.Namespace "php" <$> identifier-  , reserved "py_module" >> T.Namespace "py" <$> identifier-  , reserved "perl_package" >> T.Namespace "perl" <$> identifier-  , reserved "ruby_namespace" >> T.Namespace "rb" <$> identifier-  , reserved "java_package" >> T.Namespace "java" <$> identifier-  , reserved "cocoa_package" >> T.Namespace "cocoa" <$> identifier-  , reserved "csharp_namespace" >> T.Namespace "csharp" <$> identifier+header :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Header n)+header = choice+  [ T.HeaderInclude   <$> include+  , T.HeaderNamespace <$> namespace   ] +-- | The IDL includes another Thrift file.+--+-- > include "common.thrift"+-- >+-- > typedef common.Foo Bar+--+include :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Include n)+include = reserved "include" >> withSrcAnnot (T.Include <$> literal) --- | Convenience wrapper for parsers that expect a docstring and a location--- 'Delta'.+-- | Namespace directives allows control of the namespace or package+-- name used by the generated code for certain languages. --+-- > namespace py my_service.generated+namespace :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Namespace n)+namespace = choice+  [ reserved "namespace" >>+    withSrcAnnot (T.Namespace <$> (text "*" <|> identifier) <*> identifier)+  , reserved "cpp_namespace" >>+    withSrcAnnot (T.Namespace "cpp" <$> identifier)+  , reserved "php_namespace" >>+    withSrcAnnot (T.Namespace "php" <$> identifier)+  , reserved "py_module" >>+    withSrcAnnot (T.Namespace "py" <$> identifier)+  , reserved "perl_package" >>+    withSrcAnnot (T.Namespace "perl" <$> identifier)+  , reserved "ruby_namespace" >>+    withSrcAnnot (T.Namespace "rb" <$> identifier)+  , reserved "java_package" >>+    withSrcAnnot (T.Namespace "java" <$> identifier)+  , reserved "cocoa_package" >>+    withSrcAnnot (T.Namespace "cocoa" <$> identifier)+  , reserved "csharp_namespace" >>+    withSrcAnnot (T.Namespace "csharp" <$> identifier)+  ]++-- | Retrieve the current source annotation.+getSrcAnnot :: Monad p => ThriftParser p n n+getSrcAnnot = ThriftParser . lift $ Reader.ask >>= lift++-- | Convenience wrapper for parsers expecting a source annotation.+--+-- The source annotation will be retrieved BEFORE the parser itself is+-- executed.+withSrcAnnot+    :: (Functor p, Monad p)+    => ThriftParser p n (n -> a) -> ThriftParser p n a+withSrcAnnot p = getSrcAnnot >>= \annot -> p <*> pure annot++-- | Convenience wrapper for parsers that expect a docstring and a+-- source annotation.+-- -- > data Foo = Foo { bar :: Bar, doc :: Docstring, pos :: Delta } -- > -- > parseFoo = docstring $ Foo <$> parseBar@@ -224,29 +282,38 @@     :: (Functor p, Monad p)     => ThriftParser p n (T.Docstring -> n -> a) -> ThriftParser p n a docstring p = lastDocstring >>= \s -> do-    annot <- ThriftParser . lift $ Reader.ask >>= lift+    annot <- getSrcAnnot     p <*> pure s <*> pure annot   -- | A constant, type, or service definition.-definition :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n)-definition = choice [constant, typeDefinition, service]+definition+    :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n)+definition = whiteSpace >> choice+    [ T.ConstDefinition   <$> constant+    , T.TypeDefinition    <$> typeDefinition+    , T.ServiceDefinition <$> service+    ]   -- | A type definition.-typeDefinition :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n)-typeDefinition =-  T.TypeDefinition-    <$> choice [typedef, enum, senum, struct, union, exception]-    <*> typeAnnotations+typeDefinition :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)+typeDefinition = choice+    [ T.TypedefType   <$> typedef+    , T.EnumType      <$> enum+    , T.SenumType     <$> senum+    , T.StructType    <$> struct+    , T.UnionType     <$> union+    , T.ExceptionType <$> exception+    ]   -- | A typedef is just an alias for another type. -- -- > typedef common.Foo Bar-typedef :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)+typedef :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Typedef n) typedef = reserved "typedef" >>-    docstring (T.Typedef <$> fieldType <*> identifier)+    docstring (T.Typedef <$> typeReference <*> identifier <*> typeAnnotations)   -- | Enums are sets of named integer values.@@ -254,9 +321,12 @@ -- > enum Role { -- >     User = 1, Admin -- > }-enum :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)+enum :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Enum n) enum = reserved "enum" >>-    docstring (T.Enum <$> identifier <*> braces (many enumDef))+    docstring (T.Enum+        <$> identifier+        <*> braces (many enumDef)+        <*> typeAnnotations)   -- | A @struct@.@@ -265,9 +335,12 @@ -- >     1: string name -- >     2: Role role = Role.User; -- > }-struct :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)+struct :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Struct n) struct = reserved "struct" >>-    docstring (T.Struct <$> identifier <*> braces (many field))+    docstring (T.Struct+        <$> identifier+        <*> braces (many field)+        <*> typeAnnotations)   -- | A @union@ of types.@@ -276,9 +349,12 @@ -- >     1: string stringValue; -- >     2: i32 intValue; -- > }-union :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)+union :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Union n) union = reserved "union" >>-    docstring (T.Union <$> identifier <*> braces (many field))+    docstring (T.Union+        <$> identifier+        <*> braces (many field)+        <*> typeAnnotations)   -- | An @exception@ that can be raised by service methods.@@ -287,9 +363,12 @@ -- >     1: optional string message -- >     2: required string username -- > }-exception :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)+exception :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Exception n) exception = reserved "exception" >>-     docstring (T.Exception <$> identifier <*> braces (many field))+     docstring (T.Exception+        <$> identifier+        <*> braces (many field)+        <*> typeAnnotations)   -- | Whether a field is @required@ or @optional@.@@ -306,7 +385,7 @@   T.Field     <$> optional (integer <* symbolic ':')     <*> optional fieldRequiredness-    <*> fieldType+    <*> typeReference     <*> identifier     <*> optional (equals *> constantValue)     <*> typeAnnotations@@ -325,37 +404,42 @@  -- | An string-only enum. These are a deprecated feature of Thrift and -- shouldn't be used.-senum :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)+senum :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Senum n) senum = reserved "senum" >> docstring-    (T.Senum <$> identifier <*> braces (many (literal <* optionalSep)))+    (T.Senum+        <$> identifier+        <*> braces (many (literal <* optionalSep))+        <*> typeAnnotations)   -- | A 'const' definition. -- -- > const i32 code = 1;-constant :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n)+constant :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Const n) constant = do   reserved "const"   docstring $-    T.ConstDefinition-        <$> fieldType+    T.Const+        <$> typeReference         <*> (identifier <* equals)         <*> constantValue         <*  optionalSep   -- | A constant value literal.-constantValue :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.ConstValue+constantValue+    :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.ConstValue n) constantValue = choice [     either T.ConstInt T.ConstFloat <$> integerOrDouble   , T.ConstLiteral <$> literal-  , T.ConstIdentifier <$> identifier+  , withSrcAnnot (T.ConstIdentifier <$> identifier)   , T.ConstList <$> constList   , T.ConstMap <$> constMap   ]  -constList :: (TokenParsing p, MonadPlus p) => ThriftParser p n [T.ConstValue]+constList+    :: (TokenParsing p, MonadPlus p) => ThriftParser p n [T.ConstValue n] constList = symbolic '[' *> loop []   where     loop xs = choice [@@ -368,7 +452,7 @@  constMap     :: (TokenParsing p, MonadPlus p)-    => ThriftParser p n [(T.ConstValue, T.ConstValue)]+    => ThriftParser p n [(T.ConstValue n, T.ConstValue n)] constMap = symbolic '{' *> loop []   where     loop xs = choice [@@ -381,22 +465,24 @@  constantValuePair     :: (TokenParsing p, MonadPlus p)-    => ThriftParser p n (T.ConstValue, T.ConstValue)+    => ThriftParser p n (T.ConstValue n, T.ConstValue n) constantValuePair =     (,) <$> (constantValue <* colon)         <*> (constantValue <* optionalSep)   -- | A reference to a built-in or defined field.-fieldType :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.FieldType-fieldType = choice [+typeReference+    :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.TypeReference n)+typeReference = choice [     baseType   , containerType-  , T.DefinedType <$> identifier+  , withSrcAnnot (T.DefinedType <$> identifier)   ]  -baseType :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.FieldType+baseType+    :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.TypeReference n) baseType =     choice [reserved s *> (v <$> typeAnnotations) | (s, v) <- bases]   where@@ -406,6 +492,7 @@       , ("slist", T.SListType)       , ("bool", T.BoolType)       , ("byte", T.ByteType)+      , ("i8", T.ByteType)       , ("i16", T.I16Type)       , ("i32", T.I32Type)       , ("i64", T.I64Type)@@ -413,14 +500,15 @@       ]  -containerType :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.FieldType+containerType+    :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.TypeReference n) containerType =     choice [mapType, setType, listType] <*> typeAnnotations   where     mapType = reserved "map" >>-        angles (T.MapType <$> (fieldType <* comma) <*> fieldType)-    setType = reserved "set" >> angles (T.SetType <$> fieldType)-    listType = reserved "list" >> angles (T.ListType <$> fieldType)+        angles (T.MapType <$> (typeReference <* comma) <*> typeReference)+    setType = reserved "set" >> angles (T.SetType <$> typeReference)+    listType = reserved "list" >> angles (T.ListType <$> typeReference)   -- | A service.@@ -428,11 +516,11 @@ -- > service MyService { -- >     // ... -- > }-service :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n)+service :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Service n) service = do   reserved "service"   docstring $-    T.ServiceDefinition+    T.Service         <$> identifier         <*> optional (reserved "extends" *> identifier)         <*> braces (many function)@@ -447,7 +535,7 @@ function = docstring $     T.Function         <$> ((reserved "oneway" *> pure True) <|> pure False)-        <*> ((reserved "void" *> pure Nothing) <|> Just <$> fieldType)+        <*> ((reserved "void" *> pure Nothing) <|> Just <$> typeReference)         <*> identifier         <*> parens (many field)         <*> optional (reserved "throws" *> parens (many field))@@ -473,7 +561,7 @@ typeAnnotation =     T.TypeAnnotation         <$> identifier-        <*> (equals *> literal <* optionalSep)+        <*> (optional (equals *> literal) <* optionalSep)   optionalSep :: (TokenParsing p, MonadPlus p) => ThriftParser p n ()@@ -482,4 +570,3 @@  equals :: (TokenParsing p, MonadPlus p) => ThriftParser p n () equals = void $ symbolic '='-

@@ -22,10 +22,24 @@     -- * Components      , program+     , header+    , include+    , namespace+     , definition-    , function-    , fieldType+    , constant+    , typeDefinition+    , service++    , typedef+    , enum+    , struct+    , union+    , exception+    , senum++    , typeReference     , constantValue      -- * Configuration@@ -72,27 +86,39 @@   -- | Print the headers for a program.-header :: T.Header -> Doc-header T.Include{..} =-    text "include" <+> literal includePath-header T.Namespace{..} = hsep+header :: T.Header ann -> Doc+header (T.HeaderInclude inc) = include inc+header (T.HeaderNamespace ns) = namespace ns+++include :: T.Include ann -> Doc+include T.Include{..} = text "include" <+> literal includePath+++namespace :: T.Namespace ann -> Doc+namespace T.Namespace{..} = hsep     [text "namespace", text namespaceLanguage, text namespaceName]   -- | Print a constant, type, or service definition. definition :: Config -> T.Definition ann -> Doc-definition c T.ConstDefinition{..} = constDocstring $$ hsep+definition c (T.ConstDefinition cd) = constant c cd+definition c (T.TypeDefinition def) = typeDefinition c def+definition c (T.ServiceDefinition s) = service c s+++constant :: Config -> T.Const ann -> Doc+constant c T.Const{..} = constDocstring $$ hsep     [ text "const"-    , fieldType c constType+    , typeReference c constValueType     , text constName     , text "="     , constantValue c constValue     ] -definition c T.TypeDefinition{typeDefinition = def, ..} =-    typeDefinition c def <> typeAnnots c typeAnnotations -definition c@Config{indentWidth} T.ServiceDefinition{..} =+service :: Config -> T.Service ann -> Doc+service c@Config{indentWidth} T.Service{..} =   serviceDocstring $$     text "service" <+> text serviceName <> extends <+>     block indentWidth (line <> line) (map (function c) serviceFunctions) <>@@ -119,7 +145,7 @@         encloseSep indentWidth lparen rparen comma (map (field c) es)     returnType = case functionReturnType of       Nothing -> text "void"-      Just rt -> fieldType c rt+      Just rt -> typeReference c rt     oneway =       if functionOneWay           then text "oneway" <> space@@ -127,29 +153,53 @@   typeDefinition :: Config -> T.Type ann -> Doc-typeDefinition c@Config{indentWidth} t = case t of-  T.Typedef{..} -> typedefDocstring $$-    text "typedef" <+> fieldType c typedefType <+> text typedefName-  T.Enum{..} -> enumDocstring $$+typeDefinition c td = case td of+  T.TypedefType   t -> c `typedef`   t+  T.EnumType      t -> c `enum`      t+  T.StructType    t -> c `struct`    t+  T.UnionType     t -> c `union`     t+  T.ExceptionType t -> c `exception` t+  T.SenumType     t -> c `senum`     t++typedef :: Config -> T.Typedef ann -> Doc+typedef c T.Typedef{..} = typedefDocstring $$+    text "typedef" <+> typeReference c typedefTargetType <+> text typedefName+    <> typeAnnots c typedefAnnotations++enum :: Config -> T.Enum ann -> Doc+enum c@Config{indentWidth} T.Enum{..} = enumDocstring $$     text "enum" <+> text enumName <+>       block indentWidth (comma <> line) (map (enumValue c) enumValues)-  T.Struct{..} -> structDocstring $$+    <> typeAnnots c enumAnnotations++struct :: Config -> T.Struct ann -> Doc+struct c@Config{indentWidth} T.Struct{..} = structDocstring $$     text "struct" <+> text structName <+>       block indentWidth line (map (\f -> field c f <> semi) structFields)-  T.Union{..} -> unionDocstring $$+    <> typeAnnots c structAnnotations++union :: Config -> T.Union ann -> Doc+union c@Config{indentWidth} T.Union{..} = unionDocstring $$     text "union" <+> text unionName <+>       block indentWidth line (map (\f -> field c f <> semi) unionFields)-  T.Exception{..} -> exceptionDocstring $$+    <> typeAnnots c unionAnnotations++exception :: Config -> T.Exception ann -> Doc+exception c@Config{indentWidth} T.Exception{..} = exceptionDocstring $$     text "exception" <+> text exceptionName <+>       block indentWidth line (map (\f -> field c f <> semi) exceptionFields)-  T.Senum{..} -> senumDocstring $$+    <> typeAnnots c exceptionAnnotations++senum :: Config -> T.Senum ann -> Doc+senum c@Config{indentWidth} T.Senum{..} = senumDocstring $$     text "senum" <+> text senumName <+>       encloseSep indentWidth lbrace rbrace comma (map literal senumValues)+    <> typeAnnots c senumAnnotations   field :: Config -> T.Field ann -> Doc-field c T.Field{fieldType = typ, ..} = fieldDocstring $$-    hcat [fid, req, fieldType c typ, space, text fieldName, def, annots]+field c T.Field{fieldValueType = typ, ..} = fieldDocstring $$+    hcat [fid, req, typeReference c typ, space, text fieldName, def, annots]   where     fid = case fieldIdentifier of       Nothing -> empty@@ -158,7 +208,7 @@       Nothing -> empty       Just T.Optional -> text "optional "       Just T.Required -> text "required "-    def = case fieldDefault of+    def = case fieldDefaultValue of       Nothing -> empty       Just v -> space <> equals <+> constantValue c v     annots = typeAnnots c fieldAnnotations@@ -174,9 +224,9 @@   -- | Pretty print a field type.-fieldType :: Config -> T.FieldType -> Doc-fieldType c ft = case ft of-  T.DefinedType t -> text t+typeReference :: Config -> T.TypeReference ann -> Doc+typeReference c ft = case ft of+  T.DefinedType t _ -> text t    T.StringType anns -> text "string" <> typeAnnots c anns   T.BinaryType anns -> text "binary" <> typeAnnots c anns@@ -189,29 +239,26 @@   T.DoubleType anns -> text "double" <> typeAnnots c anns    T.MapType k v anns ->-    text "map" <> angles (fieldType c k <> comma <+> fieldType c v)+    text "map" <> angles (typeReference c k <> comma <+> typeReference c v)                <> typeAnnots c anns   T.SetType v anns ->-    text "set" <> angles (fieldType c v) <> typeAnnots c anns+    text "set" <> angles (typeReference c v) <> typeAnnots c anns   T.ListType v anns ->-    text "list" <> angles (fieldType c v) <> typeAnnots c anns+    text "list" <> angles (typeReference c v) <> typeAnnots c anns   -- | Pretty print a constant value.-constantValue :: Config -> T.ConstValue -> Doc+constantValue :: Config -> T.ConstValue ann -> Doc constantValue c@Config{indentWidth} value = case value of   T.ConstInt i -> integer i   T.ConstFloat f -> double f   T.ConstLiteral l -> literal l-  T.ConstIdentifier i -> text i-+  T.ConstIdentifier i _ -> text i   T.ConstList vs ->-    encloseSep indentWidth lbracket rbracket comma $-        map (constantValue c) vs+    encloseSep indentWidth lbracket rbracket comma $ map (constantValue c) vs   T.ConstMap vs ->     encloseSep indentWidth lbrace rbrace comma $-      map (\(k, v) -> constantValue c k <> colon <+> constantValue c v)-          vs+      map (\(k, v) -> constantValue c k <> colon <+> constantValue c v) vs   typeAnnots :: Config -> [T.TypeAnnotation] -> Doc@@ -222,7 +269,11 @@  typeAnnot :: T.TypeAnnotation -> Doc typeAnnot T.TypeAnnotation{..} =-    text typeAnnotationName <+> equals <+> literal typeAnnotationValue+    text typeAnnotationName <> value+  where+    value = case typeAnnotationValue of+        Nothing -> empty+        Just v  -> space <> equals <+> literal v   literal :: Text -> Doc@@ -261,5 +312,6 @@ encloseSep _ left right _ [v] = left <> v <> right encloseSep indent left right s vs = group $     nest indent (left <$$> go vs) <$$> right-  where go [x] = x+  where go [] = empty+        go [x] = x         go (x:xs) = (x <> s) <$> go xs

@@ -1,5 +1,9 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE DeriveDataTypeable     #-}+{-# LANGUAGE DeriveGeneric          #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE TemplateHaskell        #-} -- | -- Module      :  Language.Thrift.Types -- Copyright   :  (c) Abhinav Gupta 2015@@ -10,254 +14,162 @@ -- -- This module defines types that compose a Thrift IDL file. --+-- Most of the types have an optional @srcAnnot@ parameter that represents a+-- parser-specific source annotation. With @trifecta@ this can hold the+-- 'Text.Trifecta.Delta.Delta'. If you do not have need of this, you can use+-- @()@ as the parameter.+-- module Language.Thrift.Types     ( Program(..)+     , Header(..)+    , _Include+    , _Namespace++    , Include(..)+    , Namespace(..)+     , Definition(..)+    , _Const+    , _Service+    , _Type++    , Const(..)+    , Service(..)+     , Type(..)+    , _Typedef+    , _Enum+    , _Struct+    , _Union+    , _Exception+    , _Senum++    , Typedef(..)+    , Enum(..)+    , Struct(..)+    , Union(..)+    , Exception(..)+    , Senum(..)+     , FieldRequiredness(..)+    , _Required+    , _Optional+     , Field(..)     , EnumDef(..)+     , ConstValue(..)-    , FieldType(..)+    , _ConstInt+    , _ConstFloat+    , _ConstLiteral+    , _ConstIdentifier+    , _ConstList+    , _ConstMap++    , TypeReference(..)+    , _DefinedType+    , _StringType+    , _BinaryType+    , _SListType+    , _BoolType+    , _ByteType+    , _I16Type+    , _I32Type+    , _I64Type+    , _DoubleType+    , _MapType+    , _SetType+    , _ListType+     , Function(..)     , TypeAnnotation(..)     , Docstring++    , HasAnnotations(..)+    , HasDefaultValue(..)+    , HasDefinitions(..)+    , HasDocstring(..)+    , HasExceptions(..)+    , HasExtends(..)+    , HasFields(..)+    , HasFunctions(..)+    , HasHeaders(..)+    , HasIdentifier(..)+    , HasLanguage(..)+    , HasName(..)+    , HasOneWay(..)+    , HasParameters(..)+    , HasPath(..)+    , HasRequiredness(..)+    , HasReturnType(..)+    , HasSrcAnnot(..)+    , HasTargetType(..)+    , HasValue(..)+    , HasValues(..)+    , HasValueType(..)     ) where  import Data.Data    (Data, Typeable) import Data.Text    (Text) import GHC.Generics (Generic)+import Prelude      hiding (Enum) --- | A program represents a single Thrift document.-data Program srcAnnot = Program-    { programHeaders     :: [Header]-    -- ^ Headers in a document define includes and namespaces.-    , programDefinitions :: [Definition srcAnnot]-    -- ^ Types and services defined in the document.-    }-    deriving (Show, Ord, Eq, Data, Typeable, Generic)+import qualified Control.Lens as L --- | Headers for a program.-data Header-    = -- | The IDL includes another Thrift file.-      ---      -- > include "common.thrift"-      -- >-      -- > typedef common.Foo Bar-      ---      Include-        { includePath :: Text-        -- ^ Path to the included file.-        }-    | -- | Namespace directives allows control of the namespace or package-      -- name used by the generated code for certain languages.-      ---      -- > namespace py my_service.generated-      Namespace-        { namespaceLanguage :: Text-        -- ^ The language for which the namespace is being specified. This may-        -- be @*@ to refer to all languages.-        , namespaceName     :: Text-        -- ^ Namespace or package path to use in the generated code for that-        -- language.-        }-  deriving (Show, Ord, Eq, Data, Typeable, Generic) --- | A definition either consists of new constants, new types, or new--- services.-data Definition srcAnnot-    = -- | A declared constant.-      ---      -- > const i32 code = 1;-      ConstDefinition-        { constType      :: FieldType-        -- ^ Type of the constant.-        , constName      :: Text-        -- ^ Name of the constant.-        , constValue     :: ConstValue-        -- ^ Value of the constant.-        , constDocstring :: Docstring-        -- ^ Documentation.-        , constSrcAnnot  :: srcAnnot-        }-    | -- | A declared type.-      TypeDefinition-        { typeDefinition  :: Type srcAnnot-        -- ^ Details of the type definition.-        , typeAnnotations :: [TypeAnnotation]-        -- ^ Annotations added to the type.-        }-    | -- | A service definition.-      ---      -- > service MyService {-      -- >     // ...-      -- > }-      ServiceDefinition-        { serviceName        :: Text-        -- ^ Name of the service.-        , serviceExtends     :: Maybe Text-        -- ^ Name of the service this service extends.-        , serviceFunctions   :: [Function srcAnnot]-        -- ^ All the functions defined for the service.-        , serviceAnnotations :: [TypeAnnotation]-        -- ^ Annotations added to the service.-        , serviceDocstring   :: Docstring-        -- ^ Documentation.-        , serviceSrcAnnot    :: srcAnnot-        }+-- | Type annoations may be added in various places in the form,+--+-- > (foo = "bar", baz, qux = "quux")+--+-- These do not usually affect code generation but allow for custom logic if+-- writing your own code generator.+data TypeAnnotation = TypeAnnotation+    { typeAnnotationName  :: Text+    -- ^ Name of the annotation.+    , typeAnnotationValue :: Maybe Text+    -- ^ Value for the annotation.+    }   deriving (Show, Ord, Eq, Data, Typeable, Generic) --- | Defines the various types that can be declared in Thrift.-data Type srcAnnot-    = -- | A typedef is just an alias for another type.-      ---      -- > typedef common.Foo Bar-      Typedef-        { typedefType      :: FieldType-        -- ^ The aliased type.-        , typedefName      :: Text-        -- ^ Name of the new type.-        , typedefDocstring :: Docstring-        -- ^ Documentation.-        , typedefSrcAnnot  :: srcAnnot-        }-    | -- | Enums are sets of named integer values.-      ---      -- > enum Role {-      -- >     User = 1, Admin = 2-      -- > }-      Enum-        { enumName      :: Text-        -- ^ Name of the enum type.-        , enumValues    :: [EnumDef srcAnnot]-        -- ^ Values defined in the enum.-        , enumDocstring :: Docstring-        -- ^ Documentation.-        , enumSrcAnnot  :: srcAnnot-        }-    | -- | A struct definition-      ---      -- > struct User {-      -- >     1: Role role = Role.User;-      -- > }-      Struct-        { structName      :: Text-        -- ^ Name of the struct.-        , structFields    :: [Field srcAnnot]-        -- ^ Fields defined in the struct.-        , structDocstring :: Docstring-        -- ^ Documentation.-        , structSrcAnnot  :: srcAnnot-        }-    | -- | A union of other types.-      ---      -- > union Value {-      -- >     1: string stringValue;-      -- >     2: i32 intValue;-      -- > }-      Union-        { unionName      :: Text-        -- ^ Name of the union.-        , unionFields    :: [Field srcAnnot]-        -- ^ Fields defined in the union.-        , unionDocstring :: Docstring-        -- ^ Documentation.-        , unionSrcAnnot  :: srcAnnot-        }-    | -- | Exception types.-      ---      -- > exception UserDoesNotExist {-      -- >     1: optional string message-      -- >     2: required string username-      -- > }-      Exception-        { exceptionName      :: Text-        , exceptionFields    :: [Field srcAnnot]-        , exceptionDocstring :: Docstring-        , exceptionSrcAnnot  :: srcAnnot-        }-    | -- | An string-only enum. These are a deprecated feature of Thrift and-      -- shouldn't be used.-      Senum-        { senumName      :: Text-        , senumValues    :: [Text]-        , senumDocstring :: Docstring-        -- ^ Documentation.-        , senumSrcAnnot  :: srcAnnot-        }-  deriving (Show, Ord, Eq, Data, Typeable, Generic)+L.makeFields ''TypeAnnotation --- | Whether a field is required or optional.-data FieldRequiredness-    = Required -- ^ The field is @required@.-    | Optional -- ^ The field is @optional@.-  deriving (Show, Ord, Eq, Data, Typeable, Generic) --- | A field inside a struct, exception, or function parameters list.-data Field srcAnnot = Field-    { fieldIdentifier   :: Maybe Integer-    -- ^ Position of the field.-    ---    -- While this is optional, it is recommended that Thrift files always-    -- contain specific field IDs.-    , fieldRequiredness :: Maybe FieldRequiredness-    -- ^ Whether this field is required or not.-    ---    -- Behavior may differ between languages if requiredness is not specified.-    -- Therefore it's recommended that requiredness for a field is always-    -- specified.-    , fieldType         :: FieldType-    -- ^ Type of value the field holds.-    , fieldName         :: Text-    -- ^ Name of the field.-    , fieldDefault      :: Maybe ConstValue-    -- ^ Default value of the field, if any.-    , fieldAnnotations  :: [TypeAnnotation]-    -- ^ Field annotations.-    , fieldDocstring    :: Docstring-    -- ^ Documentation.-    , fieldSrcAnnot     :: srcAnnot-    }-  deriving (Show, Ord, Eq, Data, Typeable, Generic)+-- | Docstrings are Javadoc-style comments attached various defined objects.+--+-- > /**+-- >  * Fetches an item.+-- >  */+-- > Item getItem()+type Docstring = Maybe Text --- | A named value inside an enum.-data EnumDef srcAnnot = EnumDef-    { enumDefName        :: Text-    -- ^ Name of the value.-    , enumDefValue       :: Maybe Integer-    -- ^ Value attached to the enum for that name.-    , enumDefAnnotations :: [TypeAnnotation]-    -- ^ Annotations added to this enum field.-    , enumDefDocstring   :: Docstring-    -- ^ Documentation-    , enumDefSrcAnnot    :: srcAnnot-    }-  deriving (Show, Ord, Eq, Data, Typeable, Generic)  -- | A constant literal value in the IDL. Only a few basic types, lists, and -- maps can be presented in Thrift files as literals. -- -- Constants are used for IDL-level constants and default values for fields.-data ConstValue+data ConstValue srcAnnot     = ConstInt Integer     -- ^ An integer. @42@     | ConstFloat Double     -- ^ A float. @4.2@     | ConstLiteral Text     -- ^ A literal string. @"hello"@-    | ConstIdentifier Text-    -- ^ A literal identifier. @hello@-    | ConstList [ConstValue]+    | ConstIdentifier Text srcAnnot+    -- ^ A reference to another constant. @Foo.bar@+    | ConstList [ConstValue srcAnnot]     -- ^ A literal list containing other constant values. @[42]@-    | ConstMap [(ConstValue, ConstValue)]+    | ConstMap [(ConstValue srcAnnot, ConstValue srcAnnot)]     -- ^ A literal list containing other constant values.     -- @{"hellO": 1, "world": 2}@   deriving (Show, Ord, Eq, Data, Typeable, Generic) +L.makePrisms ''ConstValue++ -- | A reference to a type.-data FieldType-    = DefinedType Text+data TypeReference srcAnnot+    = DefinedType Text srcAnnot     -- ^ A custom defined type referred to by name.      | StringType [TypeAnnotation]@@ -280,20 +192,64 @@     -- ^ @double@ and annotations.      -- Container types-    | MapType FieldType FieldType [TypeAnnotation]+    | MapType+        (TypeReference srcAnnot)+        (TypeReference srcAnnot)+        [TypeAnnotation]     -- ^ @map\<foo, bar\>@ and annotations.-    | SetType FieldType [TypeAnnotation]+    | SetType (TypeReference srcAnnot) [TypeAnnotation]     -- ^ @set\<baz\>@ and annotations.-    | ListType FieldType [TypeAnnotation]+    | ListType (TypeReference srcAnnot) [TypeAnnotation]     -- ^ @list\<qux\>@ and annotations.   deriving (Show, Ord, Eq, Data, Typeable, Generic) +L.makePrisms ''TypeReference+++-- | Whether a field is required or optional.+data FieldRequiredness+    = Required -- ^ The field is @required@.+    | Optional -- ^ The field is @optional@.+  deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makePrisms ''FieldRequiredness++-- | A field inside a struct, exception, or function parameters list.+data Field srcAnnot = Field+    { fieldIdentifier   :: Maybe Integer+    -- ^ Position of the field.+    --+    -- While this is optional, it is recommended that Thrift files always+    -- contain specific field IDs.+    , fieldRequiredness :: Maybe FieldRequiredness+    -- ^ Whether this field is required or not.+    --+    -- Behavior may differ between languages if requiredness is not specified.+    -- Therefore it's recommended that requiredness for a field is always+    -- specified.+    , fieldValueType    :: TypeReference srcAnnot+    -- ^ Type of value the field holds.+    , fieldName         :: Text+    -- ^ Name of the field.+    , fieldDefaultValue :: Maybe (ConstValue srcAnnot)+    -- ^ Default value of the field, if any.+    , fieldAnnotations  :: [TypeAnnotation]+    -- ^ Field annotations.+    , fieldDocstring    :: Docstring+    -- ^ Documentation.+    , fieldSrcAnnot     :: srcAnnot+    }+  deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makeFields ''Field++ -- | A function defined inside a service. data Function srcAnnot = Function     { functionOneWay      :: Bool     -- ^ Whether the function is @oneway@. If it's one way, it cannot receive     -- repsonses.-    , functionReturnType  :: Maybe FieldType+    , functionReturnType  :: Maybe (TypeReference srcAnnot)     -- ^ Return type of the function, or @Nothing@ if it's @void@ or @oneway@.     , functionName        :: Text     -- ^ Name of the function.@@ -309,24 +265,333 @@     }   deriving (Show, Ord, Eq, Data, Typeable, Generic) --- | Type annoations may be added in various places in the form,+L.makeFields ''Function+++-- | A service definition. ----- > (foo = "bar", baz = "qux")+-- > service MyService {+-- >     // ...+-- > }+data Service srcAnnot = Service+    { serviceName        :: Text+    -- ^ Name of the service.+    , serviceExtends     :: Maybe Text+    -- ^ Name of the service this service extends.+    , serviceFunctions   :: [Function srcAnnot]+    -- ^ All the functions defined for the service.+    , serviceAnnotations :: [TypeAnnotation]+    -- ^ Annotations added to the service.+    , serviceDocstring   :: Docstring+    -- ^ Documentation.+    , serviceSrcAnnot    :: srcAnnot+    }+  deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makeFields ''Service++-- | A declared constant. ----- These do not usually affect code generation but allow for custom logic if--- writing your own code generator.-data TypeAnnotation = TypeAnnotation-    { typeAnnotationName  :: Text-    -- ^ Name of the annotation.-    , typeAnnotationValue :: Text-    -- ^ Value for the annotation.+-- > const i32 code = 1;+data Const srcAnnot = Const+    { constValueType :: TypeReference srcAnnot+    -- ^ Type of the constant.+    , constName      :: Text+    -- ^ Name of the constant.+    , constValue     :: ConstValue srcAnnot+    -- ^ Value of the constant.+    , constDocstring :: Docstring+    -- ^ Documentation.+    , constSrcAnnot  :: srcAnnot     }   deriving (Show, Ord, Eq, Data, Typeable, Generic) --- | Docstrings are Javadoc-style comments attached various defined objects.+L.makeFields ''Const+++-- | A typedef is just an alias for another type. ----- > /**--- >  * Fetches an item.--- >  */--- > Item getItem()-type Docstring = Maybe Text+-- > typedef common.Foo Bar+data Typedef srcAnnot = Typedef+    { typedefTargetType  :: TypeReference srcAnnot+    -- ^ The aliased type.+    , typedefName        :: Text+    -- ^ Name of the new type.+    , typedefAnnotations :: [TypeAnnotation]+    -- ^ Annotations added to the typedef.+    , typedefDocstring   :: Docstring+    -- ^ Documentation.+    , typedefSrcAnnot    :: srcAnnot+    }+  deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makeFields ''Typedef+++-- | A named value inside an enum.+data EnumDef srcAnnot = EnumDef+    { enumDefName        :: Text+    -- ^ Name of the value.+    , enumDefValue       :: Maybe Integer+    -- ^ Value attached to the enum for that name.+    , enumDefAnnotations :: [TypeAnnotation]+    -- ^ Annotations added to this enum field.+    , enumDefDocstring   :: Docstring+    -- ^ Documentation+    , enumDefSrcAnnot    :: srcAnnot+    }+  deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makeFields ''EnumDef+++-- | Enums are sets of named integer values.+--+-- > enum Role {+-- >     User = 1, Admin = 2+-- > }+data Enum srcAnnot = Enum+    { enumName        :: Text+    -- ^ Name of the enum type.+    , enumValues      :: [EnumDef srcAnnot]+    -- ^ Values defined in the enum.+    , enumAnnotations :: [TypeAnnotation]+    -- ^ Annotations added to the enum.+    , enumDocstring   :: Docstring+    -- ^ Documentation.+    , enumSrcAnnot    :: srcAnnot+    }+  deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makeFields ''Enum+++-- | A struct definition+--+-- > struct User {+-- >     1: Role role = Role.User;+-- > }+data Struct srcAnnot = Struct+    { structName        :: Text+    -- ^ Name of the struct.+    , structFields      :: [Field srcAnnot]+    -- ^ Fields defined in the struct.+    , structAnnotations :: [TypeAnnotation]+    -- ^ Annotations added to the struct.+    , structDocstring   :: Docstring+    -- ^ Documentation.+    , structSrcAnnot    :: srcAnnot+    }+  deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makeFields ''Struct+++-- | A union of other types.+--+-- > union Value {+-- >     1: string stringValue;+-- >     2: i32 intValue;+-- > }+data Union srcAnnot = Union+    { unionName        :: Text+    -- ^ Name of the union.+    , unionFields      :: [Field srcAnnot]+    -- ^ Fields defined in the union.+    , unionAnnotations :: [TypeAnnotation]+    -- ^ Annotations added to the union.+    , unionDocstring   :: Docstring+    -- ^ Documentation.+    , unionSrcAnnot    :: srcAnnot+    }+  deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makeFields ''Union+++-- | Exception types.+--+-- > exception UserDoesNotExist {+-- >     1: optional string message+-- >     2: required string username+-- > }+data Exception srcAnnot = Exception+    { exceptionName        :: Text+    -- ^ Name of the exception.+    , exceptionFields      :: [Field srcAnnot]+    -- ^ Fields defined in the exception.+    , exceptionAnnotations :: [TypeAnnotation]+    -- ^ Annotations added to the exception.+    , exceptionDocstring   :: Docstring+    -- ^ Documentation.+    , exceptionSrcAnnot    :: srcAnnot+    }+  deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makeFields ''Exception+++-- | An string-only enum. These are a deprecated feature of Thrift and+-- shouldn't be used.+data Senum srcAnnot = Senum+    { senumName        :: Text+    , senumValues      :: [Text]+    , senumAnnotations :: [TypeAnnotation]+    -- ^ Annotations added to the senum.+    , senumDocstring   :: Docstring+    -- ^ Documentation.+    , senumSrcAnnot    :: srcAnnot+    }+  deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makeFields ''Senum+++-- | Defines the various types that can be declared in Thrift.+data Type srcAnnot+    = -- | @typedef@+      TypedefType (Typedef srcAnnot)+    | -- | @enum@+      EnumType (Enum srcAnnot)+    | -- | @struct@+      StructType (Struct srcAnnot)+    | -- | @union@+      UnionType (Union srcAnnot)+    | -- | @exception@+      ExceptionType (Exception srcAnnot)+    | -- | @senum@+      SenumType (Senum srcAnnot)+  deriving (Show, Ord, Eq, Data, Typeable, Generic)++_Typedef :: L.Prism' (Type ann) (Typedef ann)+_Typedef = L.prism' TypedefType $ \t ->+    case t of+        TypedefType a -> Just a+        _             -> Nothing++_Enum :: L.Prism' (Type ann) (Enum ann)+_Enum = L.prism' EnumType $ \t ->+    case t of+        EnumType a -> Just a+        _          -> Nothing++_Struct :: L.Prism' (Type ann) (Struct ann)+_Struct = L.prism' StructType $ \t ->+    case t of+        StructType a -> Just a+        _            -> Nothing++_Union :: L.Prism' (Type ann) (Union ann)+_Union = L.prism' UnionType $ \t ->+    case t of+        UnionType a -> Just a+        _           -> Nothing++_Exception :: L.Prism' (Type ann) (Exception ann)+_Exception = L.prism' ExceptionType $ \t ->+    case t of+        ExceptionType a -> Just a+        _               -> Nothing++_Senum :: L.Prism' (Type ann) (Senum ann)+_Senum = L.prism' SenumType $ \t ->+    case t of+        SenumType a -> Just a+        _           -> Nothing+++-- | A definition either consists of new constants, new types, or new+-- services.+data Definition srcAnnot+    = -- | A declared constant.+      ConstDefinition (Const srcAnnot)+    | -- | A custom type.+      TypeDefinition (Type srcAnnot)+    | -- | A service definition.+      ServiceDefinition (Service srcAnnot)+  deriving (Show, Ord, Eq, Data, Typeable, Generic)++_Const :: L.Prism' (Definition ann) (Const ann)+_Const = L.prism' ConstDefinition $ \def ->+    case def of+        ConstDefinition c -> Just c+        _                 -> Nothing++_Type :: L.Prism' (Definition ann) (Type ann)+_Type = L.prism' TypeDefinition $ \def ->+    case def of+        TypeDefinition c -> Just c+        _                 -> Nothing++_Service :: L.Prism' (Definition ann) (Service ann)+_Service = L.prism' ServiceDefinition $ \def ->+    case def of+        ServiceDefinition c -> Just c+        _                 -> Nothing+++-- | Namespace directives allows control of the namespace or package+-- name used by the generated code for certain languages.+--+-- > namespace py my_service.generated+data Namespace srcAnnot = Namespace+    { namespaceLanguage :: Text+    -- ^ The language for which the namespace is being specified. This may+    -- be @*@ to refer to all languages.+    , namespaceName     :: Text+    -- ^ Namespace or package path to use in the generated code for that+    -- language.+    , namespaceSrcAnnot :: srcAnnot+    }+    deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makeFields ''Namespace+++-- | The IDL includes another Thrift file.+--+-- > include "common.thrift"+-- >+-- > typedef common.Foo Bar+--+data Include srcAnnot = Include+    { includePath     :: Text+    -- ^ Path to the included file.+    , includeSrcAnnot :: srcAnnot+    }+    deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makeFields ''Include+++-- | Headers for a program.+data Header srcAnnot+    = -- | Request to include another Thrift file.+      HeaderInclude (Include srcAnnot)+    | -- | A @namespace@ specifier.+      HeaderNamespace (Namespace srcAnnot)+    deriving (Show, Ord, Eq, Data, Typeable, Generic)++_Include :: L.Prism' (Header ann) (Include ann)+_Include = L.prism' HeaderInclude $ \h ->+    case h of+        HeaderInclude inc -> Just inc+        _                 -> Nothing++_Namespace :: L.Prism' (Header ann) (Namespace ann)+_Namespace = L.prism' HeaderNamespace $ \h ->+    case h of+        HeaderNamespace ns -> Just ns+        _                  -> Nothing+++-- | A program represents a single Thrift document.+data Program srcAnnot = Program+    { programHeaders     :: [Header srcAnnot]+    -- ^ Headers in a document define includes and namespaces.+    , programDefinitions :: [Definition srcAnnot]+    -- ^ Types and services defined in the document.+    }+    deriving (Show, Ord, Eq, Data, Typeable, Generic)++L.makeFields ''Program

@@ -1,3 +1,5 @@+[![build-status]](https://travis-ci.org/abhinav/language-thrift)+ `language-thrift` provides a parser and pretty printer for the [Thrift IDL format]. In addition to parsing the IDL, it keeps track of Javadoc-style comments (`/** ... */`) and attaches them to the type, service, function, or@@ -11,6 +13,7 @@  Haddock-generated docs are available on [Hackage] and [here]. +  [build-status]: https://travis-ci.org/abhinav/language-thrift.svg?branch=master   [Thrift IDL format]: http://thrift.apache.org/docs/idl   [`parsers`]: http://hackage.haskell.org/package/parsers   [`trifecta`]: http://hackage.haskell.org/package/trifecta

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -1,14 +1,18 @@+{-# LANGUAGE CPP               #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-} module Main (main) where  -- This is a fairly simple code generator that uses language-thrift to parse -- IDL files and produces pretty printed Haskell code for all the types. -- -- For services, it just generates a simple GADT that defines the inputs and--- outputs for that service. Service inheritanec is not supported and--- service method exceptions are ignored.+-- outputs for that service. Service inheritance is not supported and service+-- method exceptions are ignored. +#if __GLASGOW_HASKELL__ >= 709 import Prelude hiding ((<$>))+#endif  import Data.Char   (toLower, toUpper) import Data.Maybe  (isNothing)@@ -23,8 +27,9 @@ import           Text.Trifecta.Delta          (Delta (Directed))  import Language.Thrift.Parser.Trifecta (thriftIDL)-import Language.Thrift.Types +import qualified Language.Thrift.Types as T+ die :: String -> IO a die s = putStrLn s >> exitFailure @@ -33,7 +38,7 @@ (<&>) = flip fmap infixl 1 <&> -($$) :: Docstring -> Doc -> Doc+($$) :: T.Docstring -> Doc -> Doc ($$) Nothing y = y ($$) (Just t) y = case Text.lines t of     [] -> y@@ -49,107 +54,167 @@ tupled :: [Doc] -> Doc tupled = encloseSep lparen rparen (text ", ") -renderConstValue :: ConstValue -> Doc-renderConstValue (ConstInt i) = integer i-renderConstValue (ConstFloat f) = double f-renderConstValue (ConstLiteral l) = dquotes $ text (unpack l) -- TODO escaping-renderConstValue (ConstIdentifier i) = text (unpack i)-renderConstValue (ConstList l) = list (map renderConstValue l)-renderConstValue (ConstMap m) = text "Map.fromList" <+> list (map renderConstTuple m)+renderConstValue :: T.ConstValue a -> Doc+renderConstValue (T.ConstInt i) = integer i+renderConstValue (T.ConstFloat f) = double f+renderConstValue (T.ConstLiteral l) = dquotes $ text (unpack l) -- TODO escaping+renderConstValue (T.ConstIdentifier i _) = text (unpack i)+renderConstValue (T.ConstList l) = list (map renderConstValue l)+renderConstValue (T.ConstMap m) = text "Map.fromList" <+> list (map renderConstTuple m)   where-    renderConstTuple (a, b) = tupled [-        renderConstValue a-      , renderConstValue b-      ]+    renderConstTuple (a, b) = tupled [renderConstValue a, renderConstValue b] -renderFieldType :: FieldType -> Doc-renderFieldType (DefinedType t) = text (unpack t)-renderFieldType (StringType _) = text "Text"-renderFieldType (BinaryType _) = text "ByteString"-renderFieldType (BoolType _) = text "Bool"-renderFieldType (ByteType _) = text "Word8"-renderFieldType (I16Type _) = text "Word16"-renderFieldType (I32Type _) = text "Word32"-renderFieldType (I64Type _) = text "Word64"-renderFieldType (DoubleType _) = text "Double"-renderFieldType (MapType k v _) =-    parens $ hsep [text "Map", renderFieldType k, renderFieldType v]-renderFieldType (SetType i _) = parens $ text "Set" <+> renderFieldType i-renderFieldType (ListType i _) = brackets $ renderFieldType i-renderFieldType t = error $ "Unsupported field type: " ++ show t+renderTypeReference :: Show a => T.TypeReference a -> Doc+renderTypeReference (T.DefinedType t _) = text (unpack t)+renderTypeReference (T.StringType _) = text "Text"+renderTypeReference (T.BinaryType _) = text "ByteString"+renderTypeReference (T.BoolType _) = text "Bool"+renderTypeReference (T.ByteType _) = text "Word8"+renderTypeReference (T.I16Type _) = text "Word16"+renderTypeReference (T.I32Type _) = text "Word32"+renderTypeReference (T.I64Type _) = text "Word64"+renderTypeReference (T.DoubleType _) = text "Double"+renderTypeReference (T.MapType k v _) =+    parens $ hsep [text "Map", renderTypeReference k, renderTypeReference v]+renderTypeReference (T.SetType i _) = parens $ text "Set" <+> renderTypeReference i+renderTypeReference (T.ListType i _) = brackets $ renderTypeReference i+renderTypeReference t = error $ "Unsupported field type: " ++ show t -renderStructField :: Show a => Text -> Field a -> Doc-renderStructField structName (Field _ req ftype fname def _ docstring _) = hang 4 $-    docstring $$-    fieldName </>-    hsep [-        text "::"+renderStructField :: Show a => Text -> T.Field a -> Doc+renderStructField structName T.Field{..} = hang 4 $+    fieldDocstring $$ name </> hsep+      [ text "::"       , (if isOptional             then text "Maybe" <> space-            else empty) <> renderFieldType ftype+            else empty)+        <> renderTypeReference fieldValueType       ]   where     isOptional-      | isNothing req = False-      | otherwise     = r == Optional && isNothing def-      where (Just r)  = req-    fieldName = text . unpack $ Text.concat [+      | isNothing fieldRequiredness = False+      | otherwise     = r == T.Optional && isNothing fieldDefaultValue+      where (Just r)  = fieldRequiredness+    name = text . unpack $ Text.concat [         structName-      , underscoresToCamelCase False fname+      , underscoresToCamelCase False fieldName       ] -renderType :: Show a => Type a -> Doc-renderType = go+renderTypedef :: Show a => T.Typedef a -> Doc+renderTypedef T.Typedef{..} = typedefDocstring $$ hsep+    [ text "type"+    , typeName typedefName+    , equals+    , renderTypeReference typedefTargetType+    ]++renderEnum :: T.Enum a -> Doc+renderEnum T.Enum{..} = enumDocstring $$+    text "data" <+> typeName enumName <>+    encloseSep (text " = ") empty (text " | ") (map renderDef enumValues)+    <$$> indent 4 derivingClause   where-    derivingClause =-        text "deriving" <+> tupled (map text ["Show", "Ord", "Eq"])+    renderDef T.EnumDef{..} = enumDefDocstring $$ typeName enumDefName -    go (Typedef fieldType name docstring _) = docstring $$-        hsep [text "type", typeName name, equals, renderFieldType fieldType]-    go (Enum name defs docstring _) = docstring $$-        text "data" <+> typeName name <>-        encloseSep (text " = ") empty (text " | ") (map renderDef defs)-        <$$> indent 4 derivingClause-      where-        renderDef (EnumDef e _ _ docstring _) = docstring $$ typeName e-    go (Exception name fields docstring a) = go (Struct name fields docstring a)-    go (Struct name fields docstring _) = docstring $$-        text "data" <+> typeName name </> equals <+> typeName name <$$>-        (if null fields-            then empty-            else indent 2 renderFields)-        </> derivingClause-      -- TODO prefix should be configurable using annotations-      where-        renderFields =-            encloseSep (text "{ ") (line <> text "}") (text ", ") $-            map (renderStructField structName) fields-        structName = underscoresToCamelCase True name-    go (Union name fields docstring _) =-        hang 4-          (docstring $$-              text "data" <+> typeName name <$>-              encloseSep (text "= ") empty (text " | ")-                         (map renderField fields))-        <$$> indent 4 derivingClause+renderStruct :: Show a => T.Struct a -> Doc+renderStruct T.Struct{..} = structDocstring $$+    text "data" <+> typeName structName </>+    equals <+> typeName structName <$$>+    (if null structFields+        then empty+        else indent 2 renderFields) </> derivingClause+  -- TODO prefix should be configurable using annotations+  where+    renderFields = encloseSep (text "{ ") (line <> text "}") (text ", ") $+        map (renderStructField $ underscoresToCamelCase True structName)+             structFields++renderException :: Show a => T.Exception a -> Doc+renderException T.Exception{..} = renderStruct T.Struct+    { T.structName = exceptionName+    , T.structFields = exceptionFields+    , T.structAnnotations = exceptionAnnotations+    , T.structDocstring = exceptionDocstring+    , T.structSrcAnnot = exceptionSrcAnnot+    }++renderUnion :: Show a => T.Union a -> Doc+renderUnion T.Union{..} =+    hang 4+      (unionDocstring $$+          text "data" <+> typeName unionName <$>+          encloseSep (text "= ") empty (text " | ")+                     (map renderField unionFields))+    <$$> indent 4 derivingClause+  where+    renderField (T.Field _ _ ftype fname _ _ docstring _) =+        docstring $$ fieldName </> renderTypeReference ftype       where-        structName = underscoresToCamelCase False name-        renderField (Field _ _ ftype fname _ _ docstring _) =-            docstring $$ fieldName </> renderFieldType ftype-          where-            fieldName = text . unpack $ Text.concat [-                structName-              , underscoresToCamelCase False fname-              ]-    go t = error $ "Unsupported type: " ++ show t+        fieldName = text . unpack $ Text.concat+          [ underscoresToCamelCase False unionName+          , underscoresToCamelCase False fname+          ] +derivingClause :: Doc+derivingClause =+    text "deriving" <+> tupled (map text ["Show", "Ord", "Eq"])++renderType :: Show a => T.Type a -> Doc+renderType (T.TypedefType   t) = renderTypedef t+renderType (T.EnumType      t) = renderEnum t+renderType (T.ExceptionType t) = renderException t+renderType (T.StructType    t) = renderStruct t+renderType (T.UnionType     t) = renderUnion t+renderType                  t  = error $ "Unsupported type: " ++ show t+ typeName :: Text -> Doc typeName = mkName False -generateOutput :: Show a => Program a -> IO ()-generateOutput (Program _ definitions) = do+renderConst :: Show a => T.Const a -> Doc+renderConst T.Const{..} = constDocstring $$+    sep [name, text "::", renderTypeReference constValueType] <$>+    sep [name, text "=", renderConstValue constValue]+  where+    name = mkName True constName+++renderFunction :: Show a => Text -> T.Function a -> Doc+renderFunction serviceName T.Function{functionOneWay = False, ..} =+      functionDocstring $$+          typeName functionName <+> text "::" <>+          (if null functionParameters+              then space+              else linebreak <> renderParams) <>+          typeName serviceName <+> returnType <> linebreak+  where+    returnType = case functionReturnType of+        Nothing -> text "()"+        Just t  -> renderTypeReference t++    renderParams = indent 2 $+        encloseSep (text "{ ") (line <> text "} -> ") (text ", ") $+        map (renderStructField structName) functionParameters+      where+        structName = underscoresToCamelCase True functionName+renderFunction _ f = error $ "Unsupported function: " ++ show f+++renderService :: Show a => T.Service a -> Doc+renderService T.Service{serviceExtends = Nothing, ..} = serviceDocstring $$+    text "data" <+> typeName serviceName <+> text "a where" <$$>+    indent 2 (vcat (map (renderFunction serviceName) serviceFunctions))+renderService s = error $ "Unsupported service: " ++ show s+++renderDefinition :: Show a => T.Definition a -> Doc+renderDefinition (T.ConstDefinition   c) = renderConst   c+renderDefinition (T.TypeDefinition    t) = renderType    t+renderDefinition (T.ServiceDefinition s) = renderService s+++generateOutput :: Show a => T.Program a -> IO ()+generateOutput (T.Program _ definitions) = do     let doc = headers <$> empty <$>-              vcat (map ((<$> empty) . genDef) definitions)+              vcat (map ((<$> empty) . renderDefinition) definitions)     displayIO stdout $ renderPretty 0.8 80 doc   where     import_ m items = sep [@@ -174,36 +239,6 @@       , text ""       , importQualified "Data.Map" "Map"       ]--    genDef :: Show a => Definition a -> Doc-    genDef (ConstDefinition fieldType name value docstring _) = docstring $$-        sep [fieldName name, text "::", renderFieldType fieldType] <$>-        sep [fieldName name, text "=", renderConstValue value]-    genDef (TypeDefinition typeDef _) = renderType typeDef-    genDef (ServiceDefinition sname Nothing funcs _ docstring _) = docstring $$-        text "data" <+> typeName sname <+> text "a where" <$$>-            indent 2 (vcat (map renderFunc funcs))-      where-        renderFunc (Function False rtype name params _ _ docstring _) =-          docstring $$-            typeName name <+> text "::" <>-            (if null params-              then space-              else linebreak <> renderParams name params) <>-            typeName sname <+> returnType-            <> linebreak-          where-            returnType = case rtype of-                Nothing -> text "()"-                Just t  -> renderFieldType t--        renderParams fname params = indent 2 $-            encloseSep (text "{ ") (line <> text "} -> ") (text ", ") $-                map (renderStructField structName) params-          where-            structName = underscoresToCamelCase True fname--    fieldName = mkName True  mkName :: Bool -> Text -> Doc mkName lowerFirst = text . unpack . underscoresToCamelCase lowerFirst

@@ -6,19 +6,20 @@ -- -- Docstrings in the IDL are preserved but COMMENTS WILL BE LOST. -import System.IO (stderr)-import           Text.Trifecta                (Result (..), parseString)-import           Text.Trifecta.Delta          (Delta (Directed))-import           Text.PrettyPrint.Leijen      (putDoc)+import System.IO               (stderr)+import Text.PrettyPrint.Leijen (putDoc)+import Text.Trifecta           (Result (..), parseString)+import Text.Trifecta.Delta     (Delta (Directed))  import qualified Text.PrettyPrint.ANSI.Leijen as AnsiPP -import Language.Thrift.Pretty (prettyPrint) import Language.Thrift.Parser.Trifecta (thriftIDL)+import Language.Thrift.Pretty          (prettyPrint)  main :: IO () main = do-    result <- parseString thriftIDL (Directed "stdin" 0 0 0 0) <$> getContents+    result <-+        parseString thriftIDL (Directed "stdin" 0 0 0 0) `fmap` getContents     case result of         Success p -> putDoc (prettyPrint p) >> putStrLn ""         Failure doc ->

@@ -1,5 +1,5 @@ name          : language-thrift-version       : 0.4.0.0+version       : 0.5.0.0 synopsis      : Parser and pretty printer for the Thrift IDL format. homepage      : https://github.com/abhinav/language-thrift license       : BSD3@@ -22,24 +22,35 @@                    , Language.Thrift.Parser.Trifecta                    , Language.Thrift.Pretty                    , Language.Thrift.Types-  build-depends    : base      >= 4.7  && < 4.9-                   , mtl-                   , text      >= 1.2-                   , parsers   >= 0.12 && < 0.13-                   , trifecta  >= 1.5  && < 1.6-                   , wl-pprint >= 1.1+  ghc-options      : -Wall+  build-depends    : base         >= 4.7  && < 4.9++                   , lens         >= 4.0  && < 5.0+                   , parsers      >= 0.12 && < 0.13+                   , text         >= 1.2+                   , transformers+                   , trifecta     >= 1.5  && < 1.6+                   , wl-pprint    >= 1.1   default-language : Haskell2010   test-suite spec   type           : exitcode-stdio-1.0   hs-source-dirs : test-  main-is        : Spec.hs-  other-modules  : Language.Thrift.TypesSpec+  main-is        : Main.hs+  ghc-options    : -Wall+  other-modules  : Language.Thrift.Arbitrary+                 , Language.Thrift.ParserSpec+                 , Language.Thrift.TypesSpec+                 , Spec+                 , TestUtils   build-depends  : base+                  , hspec          >= 2.0                  , hspec-discover >= 2.1                  , QuickCheck     >= 2.5++                 , parsers                  , text                  , trifecta                  , wl-pprint

@@ -0,0 +1,288 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric      #-}+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE OverloadedStrings  #-}+module Language.Thrift.Arbitrary () where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif++import Data.Text       (Text)+import Data.Typeable   (Typeable)+import GHC.Generics    (Generic)+import Test.QuickCheck++import qualified Data.Text as Text++import qualified Language.Thrift.Types as T++#ifdef MIN_VERSION_QuickCheck+#if !MIN_VERSION_QuickCheck(2, 8, 0)+scale :: (Int -> Int) -> Gen a -> Gen a+scale f g = sized (\n -> resize (f n) g)+#endif+#endif+++-- | Halve the maximum size of generated values.+--+-- Generally speaking, it's a good idea to use this for calls that will+-- recursively generate lists of things so that they terminate at some point.+halfSize :: Gen a -> Gen a+halfSize = scale (\n -> truncate (fromIntegral n / 2 :: Double))++------------------------------------------------------------------------------++instance Arbitrary Text where+    arbitrary = Text.pack <$> listOf1 (elements charset)+      where+        charset = ['a'..'z'] ++ ['A'..'Z']++    shrink t+        | Text.length t < 2 = []+        | otherwise =+               [xs]+            ++ [Text.cons x xs' | xs' <- shrink xs]+            ++ [Text.cons x' xs | x' <- shrink x]+          where+            Just (x, xs) = Text.uncons t++newtype Docstring = Docstring { getDocstring :: Maybe Text }++instance Arbitrary Docstring where+    arbitrary = Docstring <$> oneof [return Nothing, comment]+      where+        commentLine = Text.unwords <$> listOf arbitrary+        comment = do+            s <- Text.strip . Text.unlines <$> listOf1 (halfSize commentLine)+            if Text.null s+                then return Nothing+                else return (Just s)++    shrink (Docstring t) = Docstring <$> shrink t++------------------------------------------------------------------------------++instance Arbitrary (T.Program ()) where+    shrink = genericShrink+    arbitrary = T.Program <$> arbitrary <*> arbitrary++instance Arbitrary (T.Header ()) where+    shrink = genericShrink+    arbitrary = oneof+        [ T.HeaderInclude   <$> arbitrary+        , T.HeaderNamespace <$> arbitrary+        ]++instance Arbitrary (T.Include ()) where+    shrink = genericShrink+    arbitrary = T.Include <$> arbitrary <*> pure ()++instance Arbitrary (T.Namespace ()) where+    shrink = genericShrink+    arbitrary = T.Namespace <$> elements scopes <*> arbitrary <*> pure ()+      where+        scopes = ["py", "rb", "java", "hs", "cpp"]+++instance Arbitrary (T.Definition ()) where+    shrink = genericShrink+    arbitrary = oneof+        [ T.ConstDefinition   <$> arbitrary+        , T.TypeDefinition    <$> arbitrary+        , T.ServiceDefinition <$> arbitrary+        ]++instance Arbitrary (T.Const ()) where+    shrink = genericShrink+    arbitrary =+        T.Const+            <$> arbitrary+            <*> arbitrary+            <*> arbitrary+            <*> (getDocstring <$> arbitrary)+            <*> pure ()++instance Arbitrary (T.Service ()) where+    shrink = genericShrink+    arbitrary =+        T.Service+            <$> arbitrary+            <*> arbitrary+            <*> arbitrary+            <*> halfSize arbitrary+            <*> (getDocstring <$> arbitrary)+            <*> pure ()++instance Arbitrary (T.Function ()) where+    shrink = genericShrink+    arbitrary =+        T.Function+            <$> arbitrary+            <*> halfSize arbitrary+            <*> arbitrary+            <*> halfSize arbitrary+            <*> halfSize arbitrary+            <*> halfSize arbitrary+            <*> (getDocstring <$> arbitrary)+            <*> pure ()++instance Arbitrary (T.Type ()) where+    shrink = genericShrink+    arbitrary = oneof+        [ T.TypedefType   <$> arbitrary+        , T.EnumType      <$> arbitrary+        , T.StructType    <$> arbitrary+        , T.UnionType     <$> arbitrary+        , T.ExceptionType <$> arbitrary+        , T.SenumType     <$> arbitrary+        ]++instance Arbitrary (T.Typedef ()) where+    shrink = genericShrink+    arbitrary = T.Typedef+        <$> arbitrary+        <*> arbitrary+        <*> halfSize arbitrary+        <*> (getDocstring <$> arbitrary)+        <*> pure ()++instance Arbitrary (T.Enum ()) where+    shrink = genericShrink+    arbitrary = T.Enum+        <$> arbitrary+        <*> arbitrary+        <*> halfSize arbitrary+        <*> (getDocstring <$> arbitrary)+        <*> pure ()++instance Arbitrary (T.EnumDef ()) where+    shrink = genericShrink+    arbitrary =+        T.EnumDef+            <$> arbitrary+            <*> arbitrary+            <*> halfSize arbitrary+            <*> (getDocstring <$> arbitrary)+            <*> pure ()++instance Arbitrary (T.Struct ()) where+    shrink = genericShrink+    arbitrary = T.Struct+        <$> arbitrary+        <*> arbitrary+        <*> halfSize arbitrary+        <*> (getDocstring <$> arbitrary)+        <*> pure ()++instance Arbitrary (T.Union ()) where+    shrink = genericShrink+    arbitrary = T.Union+        <$> arbitrary+        <*> arbitrary+        <*> halfSize arbitrary+        <*> (getDocstring <$> arbitrary)+        <*> pure ()++instance Arbitrary (T.Exception ()) where+    shrink = genericShrink+    arbitrary = T.Exception+        <$> arbitrary+        <*> arbitrary+        <*> halfSize arbitrary+        <*> (getDocstring <$> arbitrary)+        <*> pure ()++instance Arbitrary (T.Senum ()) where+    shrink = genericShrink+    arbitrary = T.Senum+        <$> arbitrary+        <*> arbitrary+        <*> halfSize arbitrary+        <*> (getDocstring <$> arbitrary)+        <*> pure ()++instance Arbitrary (T.Field ()) where+    shrink = genericShrink+    arbitrary =+        T.Field+            <$> (fmap getPositive <$> arbitrary)+            <*> arbitrary+            <*> halfSize arbitrary+            <*> arbitrary+            <*> halfSize arbitrary+            <*> halfSize arbitrary+            <*> (getDocstring <$> arbitrary)+            <*> pure ()++instance Arbitrary (T.TypeReference ()) where+    shrink = genericShrink+    arbitrary = oneof+        [ T.DefinedType <$> arbitrary <*> pure ()++        , halfSize $ T.StringType  <$> arbitrary+        , halfSize $ T.BinaryType  <$> arbitrary+        , halfSize $ T.SListType   <$> arbitrary+        , halfSize $ T.BoolType    <$> arbitrary+        , halfSize $ T.ByteType    <$> arbitrary+        , halfSize $ T.I16Type     <$> arbitrary+        , halfSize $ T.I32Type     <$> arbitrary+        , halfSize $ T.I64Type     <$> arbitrary+        , halfSize $ T.DoubleType  <$> arbitrary+        , halfSize $ T.MapType     <$> arbitrary <*> arbitrary <*> arbitrary+        , halfSize $ T.SetType     <$> arbitrary <*> arbitrary+        , halfSize $ T.ListType    <$> arbitrary <*> arbitrary+        ]++instance Arbitrary (T.FieldRequiredness) where+    shrink = genericShrink+    arbitrary = elements [T.Required, T.Optional]++instance Arbitrary T.TypeAnnotation where+    shrink = genericShrink+    arbitrary = T.TypeAnnotation <$> arbitrary <*> arbitrary+++newtype BasicConstValue = BasicConstValue {+    getBasicConstValue :: T.ConstValue ()+  } deriving (Typeable, Generic)+++instance Arbitrary BasicConstValue where+    shrink = genericShrink+    arbitrary = BasicConstValue <$> oneof+        [ T.ConstFloat      <$> choose (0.0, 10000.0)+        , T.ConstInt        <$> arbitrary+        , T.ConstLiteral    <$> arbitrary+        , T.ConstIdentifier <$> arbitrary <*> pure ()+        ]++-- | newtype wrapper around const values so that we're not generating lists+-- and maps that go on forever.+newtype FiniteConstValue =+    FiniteConstValue { getFiniteConstValue :: T.ConstValue () }+  deriving (Typeable, Generic)++instance Arbitrary FiniteConstValue where+    shrink = genericShrink+    arbitrary = FiniteConstValue <$> oneof+        [ basicConsts+        , T.ConstList <$> constList+        , T.ConstMap  <$> constMap+        ]+      where+        basicConsts = getBasicConstValue <$> arbitrary+        constList+            = listOf $ halfSize $ getFiniteConstValue <$> arbitrary+        constMap+            = listOf $+                (,) <$> basicConsts+                    <*> halfSize (getFiniteConstValue <$> arbitrary)+++instance Arbitrary (T.ConstValue ()) where+    shrink = genericShrink+    arbitrary = getFiniteConstValue <$> arbitrary

@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+module Language.Thrift.ParserSpec (spec) where++#if __GLASGOW_HASKELL__ < 709+import Control.Applicative+#endif++import Test.Hspec+import Text.Parser.Combinators (eof)++import TestUtils++import qualified Language.Thrift.Parser as P+import qualified Language.Thrift.Types  as T++spec :: Spec+spec = describe "Parser" $ do++    it "can parse empty documents" $+        assertParses P.program (T.Program [] []) ""++    testParseFailure++testParseFailure :: Spec+testParseFailure = do++    it "cannot parse invalid documents" $+      parseFailureCases P.program+        [ "namespace foo"+        , "const i32 100 = \"foo\""+        , "include \"foo"+        , "enum { }"+        , "struct { }"+        , "service A extends B"+        , "service A extends {}"+        ]++    it "cannot parse invalid type references" $+      parseFailureCases (P.typeReference <* eof)+        [ "list<i32"+        , "set<string, string>"+        , "map<i64>"+        , "something_else<foo>"+        ]++parseFailureCases :: Show a => Parser a -> [String] -> Expectation+parseFailureCases p = mapM_ (p `shouldNotParse`)

@@ -1,283 +1,62 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP                 #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Language.Thrift.TypesSpec where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif+{-# LANGUAGE OverloadedStrings #-}+module Language.Thrift.TypesSpec (spec) where -import Control.Monad           (unless)-import Data.Text               (Text) import Test.Hspec import Test.Hspec.QuickCheck-import Test.QuickCheck import Text.PrettyPrint.Leijen (Doc)--import Text.Trifecta       (parseString)-import Text.Trifecta.Delta (Delta (..))+import Text.Parser.Token       (whiteSpace) -import qualified Data.Text     as Text-import qualified Text.Trifecta as Tri+import Language.Thrift.Arbitrary ()+import TestUtils  import qualified Language.Thrift.Parser as P import qualified Language.Thrift.Pretty as PP-import qualified Language.Thrift.Types  as T ---- | Halve the maximum size of generated values.------ Generally speaking, it's a good idea to use this for calls that will--- recursively generate lists of things so that they terminate at some point.-halfSize :: Gen a -> Gen a-halfSize = scale (\n -> truncate (fromIntegral n / 2 :: Double))--newtype Identifier = Identifier { getIdentifier :: Text }--instance Arbitrary Identifier where-    arbitrary = Identifier . Text.pack <$> listOf1 (elements charset)-      where-        charset = ['a'..'z'] ++ ['A'..'Z']--newtype Docstring = Docstring { getDocstring :: Maybe Text }--instance Arbitrary Docstring where-    arbitrary = Docstring <$> oneof [return Nothing, comment]-      where-        commentLine =-            Text.unwords <$> listOf (getIdentifier <$> arbitrary)-        comment = do-            s <- Text.strip . Text.unlines <$> listOf1 (halfSize commentLine)-            if Text.null s-                then return Nothing-                else return (Just s)---instance Arbitrary (T.Program ()) where-    arbitrary = T.Program <$> arbitrary <*> arbitrary---instance Arbitrary (T.Definition ()) where-    arbitrary = oneof [arbitraryConst, arbitraryType, arbitraryService]-      where-        arbitraryConst =-            T.ConstDefinition-                <$> arbitrary-                <*> (getIdentifier <$> arbitrary)-                <*> arbitrary-                <*> (getDocstring <$> arbitrary)-                <*> pure ()--        arbitraryType =-            T.TypeDefinition-                <$> arbitrary-                <*> arbitrary--        arbitraryService =-            T.ServiceDefinition-                <$> (getIdentifier <$> arbitrary)-                <*> (fmap getIdentifier <$> arbitrary)-                <*> arbitrary-                <*> arbitrary-                <*> (getDocstring <$> arbitrary)-                <*> pure ()---instance Arbitrary T.Header where-    arbitrary = oneof-        [ T.Include   <$> (getIdentifier <$> arbitrary)-        , T.Namespace <$> elements scopes-                      <*> (getIdentifier <$> arbitrary)-        ]-      where-        scopes = ["py", "rb", "java", "hs", "cpp"]---instance Arbitrary (T.Field ()) where-    arbitrary =-        T.Field-            <$> (fmap getPositive <$> arbitrary)-            <*> arbitrary-            <*> halfSize arbitrary-            <*> (getIdentifier <$> arbitrary)-            <*> halfSize arbitrary-            <*> arbitrary-            <*> (getDocstring <$> arbitrary)-            <*> pure ()---instance Arbitrary (T.Function ()) where-    arbitrary =-        T.Function-            <$> elements [True, False]-            <*> arbitrary-            <*> (getIdentifier <$> arbitrary)-            <*> arbitrary-            <*> arbitrary-            <*> arbitrary-            <*> (getDocstring <$> arbitrary)-            <*> pure ()---instance Arbitrary T.TypeAnnotation where-    arbitrary =-        T.TypeAnnotation-            <$> (getIdentifier <$> arbitrary)-            <*> (getIdentifier <$> arbitrary)---instance Arbitrary (T.EnumDef ()) where-    arbitrary =-        T.EnumDef-            <$> (getIdentifier <$> arbitrary)-            <*> arbitrary-            <*> arbitrary-            <*> (getDocstring <$> arbitrary)-            <*> pure ()---instance Arbitrary (T.Type ()) where-    arbitrary = oneof-        [ T.Typedef-            <$> arbitrary-            <*> (getIdentifier <$> arbitrary)-            <*> (getDocstring <$> arbitrary)-            <*> pure ()-        , T.Enum-            <$> (getIdentifier <$> arbitrary)-            <*> arbitrary-            <*> (getDocstring <$> arbitrary)-            <*> pure ()-        , T.Struct-            <$> (getIdentifier <$> arbitrary)-            <*> arbitrary-            <*> (getDocstring <$> arbitrary)-            <*> pure ()-        , T.Union-            <$> (getIdentifier <$> arbitrary)-            <*> arbitrary-            <*> (getDocstring <$> arbitrary)-            <*> pure ()-        , T.Exception-            <$> (getIdentifier <$> arbitrary)-            <*> arbitrary-            <*> (getDocstring <$> arbitrary)-            <*> pure ()-        , T.Senum-            <$> (getIdentifier <$> arbitrary)-            <*> (map getIdentifier <$> arbitrary)-            <*> (getDocstring <$> arbitrary)-            <*> pure ()-        ]---instance Arbitrary (T.FieldRequiredness) where-    arbitrary = elements [T.Required, T.Optional]--instance Arbitrary T.FieldType where-    arbitrary = oneof-        [ T.DefinedType . getIdentifier <$> arbitrary--        , T.StringType <$> arbitrary-        , T.BinaryType <$> arbitrary-        , T.SListType  <$> arbitrary-        , T.BoolType   <$> arbitrary-        , T.ByteType   <$> arbitrary-        , T.I16Type    <$> arbitrary-        , T.I32Type    <$> arbitrary-        , T.I64Type    <$> arbitrary-        , T.DoubleType <$> arbitrary--        , halfSize $-            T.MapType <$> arbitrary <*> arbitrary <*> arbitrary-        , halfSize $-            T.SetType  <$> arbitrary <*> arbitrary-        , halfSize $-            T.ListType <$> arbitrary <*> arbitrary-        ]---newtype BasicConstValue = BasicConstValue {-    getBasicConstValue :: T.ConstValue-  }---instance Arbitrary BasicConstValue where-    arbitrary = BasicConstValue <$> oneof-        [ T.ConstFloat                      <$> choose (0.0, 10000.0)-        , T.ConstInt                        <$> arbitrary-        , T.ConstLiteral    . getIdentifier <$> arbitrary-        , T.ConstIdentifier . getIdentifier <$> arbitrary-        ]+spec :: Spec+spec =+    describe "Parser and Printer" $ do --- | newtype wrapper around const values so that we're not generating lists--- and maps that go on forever.-newtype FiniteConstValue =-    FiniteConstValue { getFiniteConstValue :: T.ConstValue }+        prop "can round-trip type references" $+            roundtrip PP.typeReference P.typeReference +        prop "can round-trip constant values" $+            roundtrip PP.constantValue P.constantValue -instance Arbitrary FiniteConstValue where-    arbitrary = FiniteConstValue <$> oneof-        [ basicConsts-        , T.ConstList <$> constList-        , T.ConstMap  <$> constMap-        ]-      where-        basicConsts = getBasicConstValue <$> arbitrary-        constList-            = listOf $ halfSize $ getFiniteConstValue <$> arbitrary-        constMap-            = listOf $-                (,) <$> basicConsts-                    <*> halfSize (getFiniteConstValue <$> arbitrary)+        prop "can round-trip typedefs" $+            roundtrip PP.typedef (whiteSpace >> P.typedef) +        prop "can round-trip enums" $+            roundtrip PP.enum (whiteSpace >> P.enum) -instance Arbitrary T.ConstValue where-    arbitrary = getFiniteConstValue <$> arbitrary+        prop "can round-trip structs" $+            roundtrip PP.struct (whiteSpace >> P.struct) +        prop "can round-trip unions" $+            roundtrip PP.union (whiteSpace >> P.union) -spec :: Spec-spec =-    describe "Can round trip" $ do+        prop "can round-trip exceptions" $+            roundtrip PP.exception (whiteSpace >> P.exception) -        prop "field types" $-            roundtrip PP.fieldType P.fieldType+        prop "can round-trip senums" $+            roundtrip PP.senum (whiteSpace >> P.senum) -        prop "constant values" $-            roundtrip PP.constantValue P.constantValue+        prop "can round-trip services" $+            roundtrip PP.service (whiteSpace >> P.service) -        prop "functions" $-            roundtrip PP.function (Tri.whiteSpace *> P.function)+        prop "can round-trip constants" $+            roundtrip PP.constant (whiteSpace >> P.constant) -        prop "definitions" $-            roundtrip PP.definition (Tri.whiteSpace *> P.definition)+        prop "can round-trip includes" $+            roundtrip (const PP.include) (whiteSpace >> P.include) -        prop "headers" $-            roundtrip (const PP.header) P.header+        prop "can round-trip namespaces" $+            roundtrip (const PP.namespace) (whiteSpace >> P.namespace) -        prop "documents" $+        prop "can round-trip documents" $             roundtrip PP.program P.program   roundtrip-    :: (Show a, Eq a)-    => (PP.Config -> a -> Doc)-    -> P.ThriftParser Tri.Parser () a-    -> a-    -> IO ()-roundtrip printer parser value = do-  let pretty = show . printer (PP.Config 4)-      triParser = P.runThriftParser (return ()) parser-      result =-          parseString triParser (Directed "memory" 0 0 0 0) (pretty value)-  case result of-    Tri.Success parsed ->-      unless (parsed == value) $ expectationFailure $-        "expected: " ++ show value ++ "\n but got: " ++ show parsed ++-        "\n\n expected (pretty): " ++ pretty value ++-        "\n but got (pretty): " ++ pretty parsed-    Tri.Failure msg -> expectationFailure $-      "failed to parse "  ++ pretty value ++-      "\n with " ++ show msg+    :: (Show a, Eq a) => (PP.Config -> a -> Doc) -> Parser a -> a -> IO ()+roundtrip printer parser value =+    assertParses parser value (show $ printer (PP.Config 4) value)

@@ -0,0 +1,11 @@+module Main (main) where++import Test.Hspec.Runner++import qualified Spec++main :: IO ()+main =+    hspecWith+        defaultConfig { configQuickCheckMaxSize = Just 25 }+        Spec.spec

@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}+module TestUtils+    ( assertParses+    , shouldNotParse+    , Parser+    ) where++import Test.Hspec (expectationFailure, shouldBe)++import qualified Text.Trifecta       as T+import qualified Text.Trifecta.Delta as T++import qualified Language.Thrift.Parser as P++type Parser a = P.ThriftParser T.Parser () a++parse :: Parser a -> String -> T.Result a+parse parser = T.parseString trifectaParser (T.Directed "memory" 0 0 0 0)+  where+    trifectaParser = P.runThriftParser (return ()) parser++-- | @assertParses parser expected input@ will assert that running @parser@ on+-- @input@ will produce @expected@.+assertParses :: (Show a, Eq a) => Parser a -> a -> String -> IO ()+assertParses parser expected input =+    case parse parser input of+        T.Success got -> got `shouldBe` expected+        T.Failure msg -> expectationFailure $+            "failed to parse:\n" ++ indent 8 input +++            "\n\texpected: " ++ show expected +++            "\n\tgot (error): " ++ show msg++-- | @parser `shouldNotParse` input@ will assert that running @parser@ on+-- @input@ will fail.+shouldNotParse :: Show a => Parser a -> String -> IO ()+shouldNotParse parser input =+    case parse parser input of+        T.Success result -> expectationFailure $+            "expected parse failure for\n" ++ indent 8 input +++            "\n\tgot success: " ++ show result+        T.Failure _ -> return ()+++-- | Indent all lines in the string the given number of spaces.+indent :: Int -> String -> String+indent n = unlines . map go . lines+  where+    go l = if null l then l else space ++ l+    space = replicate n ' '