diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,24 +1,34 @@ +0.4.0.0 +======= + +- Add pretty printing module. +- Parsers of different constructors are no longer exported by the parsing + module; instead only the parsers for their corresponding types are + exported. +- Rename record for field requiredness from `fieldRequiredNess` to + `fieldRequiredness`. + 0.3.0.0 ======= - Allow changing the underlying parser to any parser that implements the - `TokenParsing` class from `parsers` -- Add `thriftIDLParser` for standard use cases + `TokenParsing` class from `parsers`. +- Add `thriftIDLParser` for standard use cases. - Add `Language.Thrift.Parser.Trifecta` with a standard Trifecta-based - parser + parser. 0.2.0.0 ======= -- Track starting positions in source annotations -- Move docs to a separate field +- Track starting positions in source annotations. +- Move docs to a separate field. 0.1.0.1 ======= -- Allow `base` 4.9 +- Allow `base` 4.9. 0.1.0.0 ======= -- Initial release +- Initial release. diff --git a/Language/Thrift/Parser.hs b/Language/Thrift/Parser.hs --- a/Language/Thrift/Parser.hs +++ b/Language/Thrift/Parser.hs @@ -24,36 +24,21 @@ -- for example, you could define a string value for an int constant. -- module Language.Thrift.Parser - ( - - thriftIDL - - -- * Parser type - - , ThriftParser - , runThriftParser + ( thriftIDL - -- * Parser components + -- * Components , program , header , definition - , typeDefinition - , typedef - , enum - , enumDef - , senum - , struct - , union - , exception - , fieldRequiredness + , function , fieldType - , field - , constant , constantValue - , service - , function - , typeAnnotations + + -- * Parser + + , ThriftParser + , runThriftParser ) where import Control.Applicative @@ -176,9 +161,10 @@ ] sanitizeDocstring :: Text -> Text sanitizeDocstring = - Text.unlines . map (Text.dropWhile ignore) . Text.lines - where - ignore c = c == '*' || c == ' ' + Text.intercalate "\n" + . map (Text.dropWhile ignore) + . Text.lines + where ignore c = c == '*' || c == ' ' -- | Type of identifiers allowed by Thrift. @@ -234,7 +220,9 @@ -- > data Foo = Foo { bar :: Bar, doc :: Docstring, pos :: Delta } -- > -- > parseFoo = docstring $ Foo <$> parseBar -docstring :: Monad p => ThriftParser p n (T.Docstring -> n -> a) -> ThriftParser p n a +docstring + :: (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 p <*> pure s <*> pure annot @@ -368,13 +356,27 @@ constList :: (TokenParsing p, MonadPlus p) => ThriftParser p n [T.ConstValue] -constList = brackets $ commaSep (constantValue <* optionalSep) +constList = symbolic '[' *> loop [] + where + loop xs = choice [ + symbolic ']' *> return (reverse xs) + , (:) <$> (constantValue <* optionalSep) + <*> pure xs + >>= loop + ] constMap :: (TokenParsing p, MonadPlus p) => ThriftParser p n [(T.ConstValue, T.ConstValue)] -constMap = braces $ commaSep constantValuePair +constMap = symbolic '{' *> loop [] + where + loop xs = choice [ + symbolic '}' *> return (reverse xs) + , (:) <$> (constantValuePair <* optionalSep) + <*> pure xs + >>= loop + ] constantValuePair @@ -455,7 +457,7 @@ -- | Type annotations on entitites. -- --- > ("foo" = "bar", "baz" = "qux") +-- > (foo = "bar", baz = "qux") -- -- These do not usually affect code generation but allow for custom logic if -- writing your own code generator. diff --git a/Language/Thrift/Pretty.hs b/Language/Thrift/Pretty.hs new file mode 100644 --- /dev/null +++ b/Language/Thrift/Pretty.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +-- | +-- Module : Language.Thrift.Pretty +-- Copyright : (c) Abhinav Gupta 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- This module provides a pretty printer for Thrift IDLs. The pretty printer +-- prserves docstrings specified for types. +-- +-- The specifics of the printer can be configured using 'Config' objects. +-- +module Language.Thrift.Pretty + ( + prettyPrint + + -- * Components + + , program + , header + , definition + , function + , fieldType + , constantValue + + -- * Configuration + + , Config(..) + , defaultConfig + ) where + +#if __GLASGOW_HASKELL__ >= 709 +import Prelude hiding ((<$>)) +#endif + +import Data.Text (Text, unpack) +import Text.PrettyPrint.Leijen hiding (encloseSep, indent, text) + +import qualified Data.Text as Text +import qualified Language.Thrift.Types as T +import qualified Text.PrettyPrint.Leijen as PP + + +-- | Configuration for the pretty printer. +data Config = Config + { indentWidth :: Int + -- ^ Number of spaces to use for indentation. + } deriving (Show, Ord, Eq) + + +-- | Default pretty printing configuration. +defaultConfig :: Config +defaultConfig = Config 4 + + +-- | Top-level pretty printer for Thrift documents that uses the default +-- configuration ('defaultConfig') for pretty printing. +prettyPrint :: T.Program ann -> Doc +prettyPrint = program defaultConfig + + +-- | Pretty print a Thrift IDL. +program :: Config -> T.Program ann -> Doc +program c T.Program{..} = + vsep (map header programHeaders) <$> line <> + map (definition c) programDefinitions `sepBy` (line <> line) + + +-- | Print the headers for a program. +header :: T.Header -> Doc +header T.Include{..} = + text "include" <+> literal includePath +header 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 + [ text "const" + , fieldType c constType + , text constName + , text "=" + , constantValue c constValue + ] + +definition c T.TypeDefinition{typeDefinition = def, ..} = + typeDefinition c def <> typeAnnots c typeAnnotations + +definition c@Config{indentWidth} T.ServiceDefinition{..} = + serviceDocstring $$ + text "service" <+> text serviceName <> extends <+> + block indentWidth (line <> line) (map (function c) serviceFunctions) <> + typeAnnots c serviceAnnotations + where + extends = case serviceExtends of + Nothing -> empty + Just name -> space <> text "extends" <+> text name + + +-- | Pretty print a function definition. +-- +function :: Config -> T.Function ann -> Doc +function c@Config{indentWidth} T.Function{..} = functionDocstring $$ + oneway <> returnType <+> text functionName <> + encloseSep + indentWidth lparen rparen comma + (map (field c) functionParameters) <> + exceptions <> typeAnnots c functionAnnotations <> semi + where + exceptions = case functionExceptions of + Nothing -> empty + Just es -> space <> text "throws" <+> + encloseSep indentWidth lparen rparen comma (map (field c) es) + returnType = case functionReturnType of + Nothing -> text "void" + Just rt -> fieldType c rt + oneway = + if functionOneWay + then text "oneway" <> space + else empty + + +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 $$ + text "enum" <+> text enumName <+> + block indentWidth (comma <> line) (map (enumValue c) enumValues) + T.Struct{..} -> structDocstring $$ + text "struct" <+> text structName <+> + block indentWidth line (map (\f -> field c f <> semi) structFields) + T.Union{..} -> unionDocstring $$ + text "union" <+> text unionName <+> + block indentWidth line (map (\f -> field c f <> semi) unionFields) + T.Exception{..} -> exceptionDocstring $$ + text "exception" <+> text exceptionName <+> + block indentWidth line (map (\f -> field c f <> semi) exceptionFields) + T.Senum{..} -> senumDocstring $$ + text "senum" <+> text senumName <+> + encloseSep indentWidth lbrace rbrace comma (map literal senumValues) + + +field :: Config -> T.Field ann -> Doc +field c T.Field{fieldType = typ, ..} = fieldDocstring $$ + hcat [fid, req, fieldType c typ, space, text fieldName, def, annots] + where + fid = case fieldIdentifier of + Nothing -> empty + Just i -> integer i <> colon <> space + req = case fieldRequiredness of + Nothing -> empty + Just T.Optional -> text "optional " + Just T.Required -> text "required " + def = case fieldDefault of + Nothing -> empty + Just v -> space <> equals <+> constantValue c v + annots = typeAnnots c fieldAnnotations + + +enumValue :: Config -> T.EnumDef ann -> Doc +enumValue c T.EnumDef{..} = enumDefDocstring $$ + text enumDefName <> value <> typeAnnots c enumDefAnnotations + where + value = case enumDefValue of + Nothing -> empty + Just v -> space <> text "=" <+> integer v + + +-- | Pretty print a field type. +fieldType :: Config -> T.FieldType -> Doc +fieldType 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 + T.SListType anns -> text "slist" <> typeAnnots c anns + T.BoolType anns -> text "bool" <> typeAnnots c anns + T.ByteType anns -> text "byte" <> typeAnnots c anns + T.I16Type anns -> text "i16" <> typeAnnots c anns + T.I32Type anns -> text "i32" <> typeAnnots c anns + T.I64Type anns -> text "i64" <> typeAnnots c anns + T.DoubleType anns -> text "double" <> typeAnnots c anns + + T.MapType k v anns -> + text "map" <> angles (fieldType c k <> comma <+> fieldType c v) + <> typeAnnots c anns + T.SetType v anns -> + text "set" <> angles (fieldType c v) <> typeAnnots c anns + T.ListType v anns -> + text "list" <> angles (fieldType c v) <> typeAnnots c anns + + +-- | Pretty print a constant value. +constantValue :: Config -> T.ConstValue -> 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.ConstList 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 + + +typeAnnots :: Config -> [T.TypeAnnotation] -> Doc +typeAnnots _ [] = empty +typeAnnots Config{indentWidth} anns = + space <> encloseSep indentWidth lparen rparen comma (map typeAnnot anns) + + +typeAnnot :: T.TypeAnnotation -> Doc +typeAnnot T.TypeAnnotation{..} = + text typeAnnotationName <+> equals <+> literal typeAnnotationValue + + +literal :: Text -> Doc +literal = dquotes . text + -- TODO: escaping? + +text :: Text -> Doc +text = PP.text . unpack + + +($$) :: T.Docstring -> Doc -> Doc +($$) Nothing y = y +($$) (Just t) y = case Text.lines (Text.strip t) of + [] -> y + ls -> wrapComments ls <$> y + where + wrapComments ls = align . vsep + $ text "/**" + : map (\l -> text " *" <+> text l) ls + ++ [text " */"] + +infixr 1 $$ + + +block :: Int -> Doc -> [Doc] -> Doc +block indent s items = braces $ + nest indent (linebreak <> (items `sepBy` s)) <> linebreak + +sepBy :: [Doc] -> Doc -> Doc +sepBy [] _ = empty +sepBy [x] _ = x +sepBy (x:xs) s = x <> s <> sepBy xs s + +encloseSep :: Int -> Doc -> Doc -> Doc -> [Doc] -> Doc +encloseSep _ left right _ [] = left <> right +encloseSep _ left right _ [v] = left <> v <> right +encloseSep indent left right s vs = group $ + nest indent (left <$$> go vs) <$$> right + where go [x] = x + go (x:xs) = (x <> s) <$> go xs diff --git a/Language/Thrift/Types.hs b/Language/Thrift/Types.hs --- a/Language/Thrift/Types.hs +++ b/Language/Thrift/Types.hs @@ -201,7 +201,7 @@ -- -- While this is optional, it is recommended that Thrift files always -- contain specific field IDs. - , fieldRequiredNess :: Maybe FieldRequiredness + , fieldRequiredness :: Maybe FieldRequiredness -- ^ Whether this field is required or not. -- -- Behavior may differ between languages if requiredness is not specified. @@ -311,7 +311,7 @@ -- | Type annoations may be added in various places in the form, -- --- > ("foo" = "bar", "baz" = "qux") +-- > (foo = "bar", baz = "qux") -- -- These do not usually affect code generation but allow for custom logic if -- writing your own code generator. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,15 +1,19 @@ -`language-thrift` provides a parser 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 field, above which they were -added. +`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 +field, above which they were added. These are retained when the document is +sent through the pretty printer. The parser uses [`parsers`] to allow plugging in the underlying parser. A default [`trifecta`] based parser is provided. +The pretty printer uses [wl-pprint]. + Haddock-generated docs are available on [Hackage] and [here]. [Thrift IDL format]: http://thrift.apache.org/docs/idl [`parsers`]: http://hackage.haskell.org/package/parsers [`trifecta`]: http://hackage.haskell.org/package/trifecta + [wl-pprint]: http://hackage.haskell.org/package/wl-pprint [Hackage]: http://hackage.haskell.org/package/language-thrift [here]: http://abhinavg.net/language-thrift/ diff --git a/examples/reformatIDL.hs b/examples/reformatIDL.hs new file mode 100644 --- /dev/null +++ b/examples/reformatIDL.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +-- This program reads Thrift IDLs from stdin and writes their reformatted +-- versions back to stdout. +-- +-- 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 qualified Text.PrettyPrint.ANSI.Leijen as AnsiPP + +import Language.Thrift.Pretty (prettyPrint) +import Language.Thrift.Parser.Trifecta (thriftIDL) + +main :: IO () +main = do + result <- parseString thriftIDL (Directed "stdin" 0 0 0 0) <$> getContents + case result of + Success p -> putDoc (prettyPrint p) >> putStrLn "" + Failure doc -> + AnsiPP.displayIO stderr $ AnsiPP.renderPretty 0.8 80 doc diff --git a/language-thrift.cabal b/language-thrift.cabal --- a/language-thrift.cabal +++ b/language-thrift.cabal @@ -1,6 +1,6 @@ name : language-thrift -version : 0.3.0.0 -synopsis : Parser for the Thrift IDL format. +version : 0.4.0.0 +synopsis : Parser and pretty printer for the Thrift IDL format. homepage : https://github.com/abhinav/language-thrift license : BSD3 license-file : LICENSE @@ -10,7 +10,7 @@ build-type : Simple cabal-version : >=1.10 description : - This package provides a parser for the + This package provides a parser and pretty printer for the . extra-source-files: README.md @@ -20,12 +20,31 @@ library exposed-modules : Language.Thrift.Parser , Language.Thrift.Parser.Trifecta + , Language.Thrift.Pretty , Language.Thrift.Types - build-depends : base >= 4.7 && < 4.9 + build-depends : base >= 4.7 && < 4.9 , mtl - , text >= 1.2 - , parsers >= 0.12 && < 0.13 - , trifecta >= 1.5 && < 1.6 + , text >= 1.2 + , parsers >= 0.12 && < 0.13 + , 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 + build-depends : base + , hspec >= 2.0 + , hspec-discover >= 2.1 + , QuickCheck >= 2.5 + , text + , trifecta + , wl-pprint + + , language-thrift default-language : Haskell2010 source-repository head diff --git a/test/Language/Thrift/TypesSpec.hs b/test/Language/Thrift/TypesSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Thrift/TypesSpec.hs @@ -0,0 +1,283 @@ +{-# 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 + +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 qualified Data.Text as Text +import qualified Text.Trifecta as Tri + +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 + ] + +-- | newtype wrapper around const values so that we're not generating lists +-- and maps that go on forever. +newtype FiniteConstValue = + FiniteConstValue { getFiniteConstValue :: T.ConstValue } + + +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) + + +instance Arbitrary T.ConstValue where + arbitrary = getFiniteConstValue <$> arbitrary + + +spec :: Spec +spec = + describe "Can round trip" $ do + + prop "field types" $ + roundtrip PP.fieldType P.fieldType + + prop "constant values" $ + roundtrip PP.constantValue P.constantValue + + prop "functions" $ + roundtrip PP.function (Tri.whiteSpace *> P.function) + + prop "definitions" $ + roundtrip PP.definition (Tri.whiteSpace *> P.definition) + + prop "headers" $ + roundtrip (const PP.header) P.header + + prop "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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}