diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,12 @@ +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 +- Add `Language.Thrift.Parser.Trifecta` with a standard Trifecta-based + parser + 0.2.0.0 ======= diff --git a/Language/Thrift/Parser.hs b/Language/Thrift/Parser.hs --- a/Language/Thrift/Parser.hs +++ b/Language/Thrift/Parser.hs @@ -1,9 +1,40 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Language.Thrift.Parser +-- Copyright : (c) Abhinav Gupta 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- Provides a parser for Thrift IDLs. +-- +-- In addition to parsing the IDLs, the parser also keeps track of +-- Javadoc-style docstrings on defined items and makes their values available. +-- For example, +-- +-- > /** +-- > * Fetches an item. +-- > */ +-- > Item getItem() +-- +-- Note that the parser does not validate the Thrift file for correctness, so, +-- for example, you could define a string value for an int constant. +-- module Language.Thrift.Parser - ( ThriftParser + ( + + thriftIDL + + -- * Parser type + + , ThriftParser , runThriftParser + -- * Parser components + , program , header , definition @@ -27,23 +58,51 @@ import Control.Applicative import Control.Monad +import Control.Monad.Reader (ReaderT) import Control.Monad.State (StateT) +import Control.Monad.Trans (lift) import Data.Text (Text) +import Text.Parser.Char +import Text.Parser.Combinators +import Text.Parser.Token import Text.Parser.Token.Style (emptyIdents) -import Text.Trifecta -import Text.Trifecta.Delta (Delta) -import qualified Control.Monad.State as State -import qualified Data.Text as Text +import qualified Control.Monad.Reader as Reader +import qualified Control.Monad.State as State +import qualified Data.Text as Text import qualified Language.Thrift.Types as T +-- | Get a top level parser that is able to parse full Thrift documents. +-- +-- Entities defined in the IDL are annotated with @n@ values (determined by +-- executing @p n@ before the parser for the entity is executed). +-- +-- Usage with Trifecta to get entities tagged with location information (see +-- also, 'Language.Thrift.Parser.Trifecta.thriftIDL'): +-- +-- > Trifecta.parseFromFile (thriftIDL Trifecta.position) "service.thrift" +-- +-- Usage with Attoparsec without any annotations: +-- +-- > Attoparsec.parse (thriftIDL (return ())) document +-- +thriftIDL :: (MonadPlus p, TokenParsing p) => p n -> p (T.Program n) +thriftIDL getAnnot = runThriftParser getAnnot program + + +-- | Keeps track of the last docstring seen by the system so that we can +-- attach it to entities. newtype ParserState = ParserState { parserLastDocstring :: T.Docstring } deriving (Show, Ord, Eq) -newtype ThriftParser a = ThriftParser (StateT ParserState Parser a) +-- | The ThriftParser wraps another parser @p@ with some extra state. It also +-- 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) deriving ( Functor , Applicative @@ -52,21 +111,37 @@ , MonadPlus , Parsing , CharParsing - , DeltaParsing ) -lastDocstring :: ThriftParser T.Docstring +-- | Returns the last docstring recorded by the system and clears it from the +-- parser state. +lastDocstring :: Monad p => ThriftParser p n T.Docstring lastDocstring = ThriftParser $ do s <- State.gets parserLastDocstring State.put (ParserState Nothing) return s -runThriftParser :: ThriftParser a -> Parser a -runThriftParser (ThriftParser p) = State.evalStateT p (ParserState Nothing) +-- | Get an exeecutable parser from the given ThriftParser. +runThriftParser + :: (MonadPlus p, TokenParsing p) + => p n + -- ^ How to get annotations from the underlying parser. If this is not + -- something you need to use, make it @return ()@ and generated types will + -- be annotated with @()@. + -> ThriftParser p n a + -> p a +runThriftParser getAnnot (ThriftParser p) = + Reader.runReaderT (State.evalStateT p (ParserState Nothing)) getAnnot -instance TokenParsing ThriftParser where - someSpace = skipSome $ - readDocstring <|> skipComments <|> skipSpace + +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", + -- we clear the docstring out because it's most likely not attached to the + -- entity that follows. So for docstrings to be attached, there must be a + -- single newline between "*/" and the entity. + someSpace = skipSome $ readDocstring <|> skipComments <|> skipSpace where skipSpace = choice [ newline *> clearDocstring @@ -105,25 +180,39 @@ where ignore c = c == '*' || c == ' ' -idStyle :: IdentifierStyle ThriftParser -idStyle = (emptyIdents :: IdentifierStyle ThriftParser) + +-- | Type of identifiers allowed by Thrift. +idStyle + :: forall p n. (TokenParsing p, MonadPlus p) + => IdentifierStyle (ThriftParser p n) +idStyle = (emptyIdents :: IdentifierStyle (ThriftParser p n)) { _styleStart = letter <|> char '_' , _styleLetter = alphaNum <|> oneOf "_." } -reserved :: Text -> ThriftParser () + +-- | Constructor for reserved keywords. +reserved :: (TokenParsing p, MonadPlus p) => Text -> ThriftParser p n () reserved = reserveText idStyle -program :: ThriftParser (T.Program Delta) + +-- | 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 -literal :: ThriftParser Text + +-- | A string literal. @"hello"@ +literal :: (TokenParsing p, MonadPlus p) => ThriftParser p n Text literal = stringLiteral <|> stringLiteral' -identifier :: ThriftParser Text + +-- | An identifier in a Thrift file. +identifier :: (TokenParsing p, MonadPlus p) => ThriftParser p n Text identifier = ident idStyle -header :: ThriftParser T.Header + +-- | Headers defined for the IDL. +header :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.Header header = choice [ reserved "include" >> T.Include <$> literal , reserved "namespace" >> @@ -138,47 +227,93 @@ , reserved "csharp_namespace" >> T.Namespace "csharp" <$> identifier ] -docstring :: ThriftParser (T.Docstring -> Delta -> a) -> ThriftParser a + +-- | Convenience wrapper for parsers that expect a docstring and a location +-- 'Delta'. +-- +-- > 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 p = lastDocstring >>= \s -> do - startPosition <- position - p <*> pure s <*> pure startPosition + annot <- ThriftParser . lift $ Reader.ask >>= lift + p <*> pure s <*> pure annot -definition :: ThriftParser (T.Definition Delta) + +-- | A constant, type, or service definition. +definition :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n) definition = choice [constant, typeDefinition, service] -typeDefinition :: ThriftParser (T.Definition Delta) + +-- | 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 -typedef :: ThriftParser (T.Type Delta) + +-- | 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 = reserved "typedef" >> docstring (T.Typedef <$> fieldType <*> identifier) -enum :: ThriftParser (T.Type Delta) + +-- | Enums are sets of named integer values. +-- +-- > enum Role { +-- > User = 1, Admin +-- > } +enum :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n) enum = reserved "enum" >> docstring (T.Enum <$> identifier <*> braces (many enumDef)) -struct :: ThriftParser (T.Type Delta) + +-- | A @struct@. +-- +-- > struct User { +-- > 1: string name +-- > 2: Role role = Role.User; +-- > } +struct :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n) struct = reserved "struct" >> docstring (T.Struct <$> identifier <*> braces (many field)) -union :: ThriftParser (T.Type Delta) + +-- | A @union@ of types. +-- +-- > union Value { +-- > 1: string stringValue; +-- > 2: i32 intValue; +-- > } +union :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n) union = reserved "union" >> docstring (T.Union <$> identifier <*> braces (many field)) -exception :: ThriftParser (T.Type Delta) + +-- | An @exception@ that can be raised by service methods. +-- +-- > exception UserDoesNotExist { +-- > 1: optional string message +-- > 2: required string username +-- > } +exception :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n) exception = reserved "exception" >> docstring (T.Exception <$> identifier <*> braces (many field)) -fieldRequiredness :: ThriftParser T.FieldRequiredness + +-- | Whether a field is @required@ or @optional@. +fieldRequiredness + :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.FieldRequiredness fieldRequiredness = choice [ reserved "required" *> pure T.Required , reserved "optional" *> pure T.Optional ] -field :: ThriftParser (T.Field Delta) +-- | A struct field. +field :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Field n) field = docstring $ T.Field <$> optional (integer <* symbolic ':') @@ -189,10 +324,9 @@ <*> typeAnnotations <* optionalSep -equals :: ThriftParser () -equals = void $ symbolic '=' -enumDef :: ThriftParser (T.EnumDef Delta) +-- | A value defined inside an @enum@. +enumDef :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.EnumDef n) enumDef = docstring $ T.EnumDef <$> identifier @@ -200,11 +334,18 @@ <*> typeAnnotations <* optionalSep -senum :: ThriftParser (T.Type Delta) + +-- | 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 = reserved "senum" >> docstring (T.Senum <$> identifier <*> braces (many (literal <* optionalSep))) -constant :: ThriftParser (T.Definition Delta) + +-- | A 'const' definition. +-- +-- > const i32 code = 1; +constant :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n) constant = do reserved "const" docstring $ @@ -214,7 +355,9 @@ <*> constantValue <* optionalSep -constantValue :: ThriftParser T.ConstValue + +-- | A constant value literal. +constantValue :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.ConstValue constantValue = choice [ either T.ConstInt T.ConstFloat <$> integerOrDouble , T.ConstLiteral <$> literal @@ -223,25 +366,35 @@ , T.ConstMap <$> constMap ] -constList :: ThriftParser [T.ConstValue] + +constList :: (TokenParsing p, MonadPlus p) => ThriftParser p n [T.ConstValue] constList = brackets $ commaSep (constantValue <* optionalSep) -constMap :: ThriftParser [(T.ConstValue, T.ConstValue)] + +constMap + :: (TokenParsing p, MonadPlus p) + => ThriftParser p n [(T.ConstValue, T.ConstValue)] constMap = braces $ commaSep constantValuePair -constantValuePair :: ThriftParser (T.ConstValue, T.ConstValue) + +constantValuePair + :: (TokenParsing p, MonadPlus p) + => ThriftParser p n (T.ConstValue, T.ConstValue) constantValuePair = (,) <$> (constantValue <* colon) <*> (constantValue <* optionalSep) -fieldType :: ThriftParser T.FieldType + +-- | A reference to a built-in or defined field. +fieldType :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.FieldType fieldType = choice [ baseType , containerType , T.DefinedType <$> identifier ] -baseType :: ThriftParser T.FieldType + +baseType :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.FieldType baseType = choice [reserved s *> (v <$> typeAnnotations) | (s, v) <- bases] where @@ -257,7 +410,8 @@ , ("double", T.DoubleType) ] -containerType :: ThriftParser T.FieldType + +containerType :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.FieldType containerType = choice [mapType, setType, listType] <*> typeAnnotations where @@ -266,7 +420,13 @@ setType = reserved "set" >> angles (T.SetType <$> fieldType) listType = reserved "list" >> angles (T.ListType <$> fieldType) -service :: ThriftParser (T.Definition Delta) + +-- | A service. +-- +-- > service MyService { +-- > // ... +-- > } +service :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n) service = do reserved "service" docstring $ @@ -276,7 +436,12 @@ <*> braces (many function) <*> typeAnnotations -function :: ThriftParser (T.Function Delta) + +-- | A function defined inside a service. +-- +-- > Foo getFoo() throws (1: FooDoesNotExist doesNotExist); +-- > oneway void putBar(1: Bar bar); +function :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Function n) function = docstring $ T.Function <$> ((reserved "oneway" *> pure True) <|> pure False) @@ -287,14 +452,32 @@ <*> typeAnnotations <* optionalSep -typeAnnotations :: ThriftParser [T.TypeAnnotation] + +-- | Type annotations on entitites. +-- +-- > ("foo" = "bar", "baz" = "qux") +-- +-- These do not usually affect code generation but allow for custom logic if +-- writing your own code generator. +typeAnnotations + :: (TokenParsing p, MonadPlus p) + => ThriftParser p n [T.TypeAnnotation] typeAnnotations = parens (many typeAnnotation) <|> pure [] -typeAnnotation :: ThriftParser T.TypeAnnotation + +typeAnnotation + :: (TokenParsing p, MonadPlus p) + => ThriftParser p n T.TypeAnnotation typeAnnotation = T.TypeAnnotation <$> identifier <*> (equals *> literal <* optionalSep) -optionalSep :: ThriftParser () + +optionalSep :: (TokenParsing p, MonadPlus p) => ThriftParser p n () optionalSep = void $ optional (comma <|> semi) + + +equals :: (TokenParsing p, MonadPlus p) => ThriftParser p n () +equals = void $ symbolic '=' + diff --git a/Language/Thrift/Parser/Trifecta.hs b/Language/Thrift/Parser/Trifecta.hs new file mode 100644 --- /dev/null +++ b/Language/Thrift/Parser/Trifecta.hs @@ -0,0 +1,23 @@ +-- | +-- Module : Language.Thrift.Parser.Trifecta +-- Copyright : (c) Abhinav Gupta 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- Provides a parser for Thrift IDLs based on Trifecta. +-- +module Language.Thrift.Parser.Trifecta (thriftIDL) where + +import Text.Trifecta +import Text.Trifecta.Delta (Delta) + +import qualified Language.Thrift.Parser as P +import qualified Language.Thrift.Types as T + +-- | Parser for Thrift IDLs based on Trifecta. +-- +-- Use with 'parseFromFile', 'parseByteString' or friends. +thriftIDL :: Parser (T.Program Delta) +thriftIDL = P.thriftIDL position diff --git a/Language/Thrift/Types.hs b/Language/Thrift/Types.hs --- a/Language/Thrift/Types.hs +++ b/Language/Thrift/Types.hs @@ -1,5 +1,15 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +-- | +-- Module : Language.Thrift.Types +-- Copyright : (c) Abhinav Gupta 2015 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- This module defines types that compose a Thrift IDL file. +-- module Language.Thrift.Types ( Program(..) , Header(..) @@ -19,147 +29,304 @@ import Data.Text (Text) import GHC.Generics (Generic) +-- | 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) +-- | Headers for a program. data Header - = Include { includePath :: Text } - | Namespace { namespaceLanguage, namespaceName :: Text } + = -- | 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 - = ConstDefinition + = -- | 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 } - | TypeDefinition + | -- | A declared type. + TypeDefinition { typeDefinition :: Type srcAnnot + -- ^ Details of the type definition. , typeAnnotations :: [TypeAnnotation] + -- ^ Annotations added to the type. } - | ServiceDefinition + | -- | 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 } deriving (Show, Ord, Eq, Data, Typeable, Generic) +-- | Defines the various types that can be declared in Thrift. data Type srcAnnot - = Typedef + = -- | 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 } - | Enum + | -- | 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 } - | Struct + | -- | 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 } - | Union + | -- | 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 + | -- | Exception types. + -- + -- > exception UserDoesNotExist { + -- > 1: optional string message + -- > 2: required string username + -- > } + Exception { exceptionName :: Text , exceptionFields :: [Field srcAnnot] , exceptionDocstring :: Docstring , exceptionSrcAnnot :: srcAnnot } - | Senum + | -- | 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) -data FieldRequiredness = Required | Optional +-- | 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) +-- | 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 = 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] + -- ^ A literal list containing other constant values. @[42]@ | ConstMap [(ConstValue, ConstValue)] + -- ^ A literal list containing other constant values. + -- @{"hellO": 1, "world": 2}@ deriving (Show, Ord, Eq, Data, Typeable, Generic) +-- | A reference to a type. data FieldType = DefinedType Text + -- ^ A custom defined type referred to by name. - -- Base types | StringType [TypeAnnotation] + -- ^ @string@ and annotations. | BinaryType [TypeAnnotation] + -- ^ @binary@ and annotations. | SListType [TypeAnnotation] + -- ^ @slist@ and annotations. | BoolType [TypeAnnotation] + -- ^ @bool@ and annotations. | ByteType [TypeAnnotation] + -- ^ @byte@ and annotations. | I16Type [TypeAnnotation] + -- ^ @i16@ and annotations. | I32Type [TypeAnnotation] + -- ^ @i32@ and annotations. | I64Type [TypeAnnotation] + -- ^ @i64@ and annotations. | DoubleType [TypeAnnotation] + -- ^ @double@ and annotations. -- Container types | MapType FieldType FieldType [TypeAnnotation] + -- ^ @map\@ and annotations. | SetType FieldType [TypeAnnotation] + -- ^ @set\@ and annotations. | ListType FieldType [TypeAnnotation] + -- ^ @list\@ and annotations. deriving (Show, Ord, Eq, Data, Typeable, Generic) +-- | 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 + -- ^ Return type of the function, or @Nothing@ if it's @void@ or @oneway@. , functionName :: Text + -- ^ Name of the function. , functionParameters :: [Field srcAnnot] + -- ^ Parameters accepted by the function. , functionExceptions :: Maybe [Field srcAnnot] + -- ^ Exceptions raised by the function, if any. , functionAnnotations :: [TypeAnnotation] + -- ^ Annotations added to the function. , functionDocstring :: Docstring + -- ^ Documentation. , functionSrcAnnot :: srcAnnot } deriving (Show, Ord, Eq, Data, Typeable, Generic) +-- | Type annoations may be added in various places in the form, +-- +-- > ("foo" = "bar", "baz" = "qux") +-- +-- 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. } 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,13 +1,15 @@ -`language-thrift` provides a parser for the [Thrift IDL format][]. The parser -is written using [`trifecta`][] to provide helpful error messages when parsing -fails. The parser keeps track of Javadoc-style comments (`/** ... */`) and -associates them with the type, service, function, or field above which they -were added. +`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. -Documentation is sparse; most of the types are self-explanatory. -Haddock-generated docs are available on [Hackage][] and [here][]. +The parser uses [`parsers`] to allow plugging in the underlying parser. A +default [`trifecta`] based parser is provided. +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 [Hackage]: http://hackage.haskell.org/package/language-thrift [here]: http://abhinavg.net/language-thrift/ diff --git a/examples/generateHaskellTypes.hs b/examples/generateHaskellTypes.hs new file mode 100644 --- /dev/null +++ b/examples/generateHaskellTypes.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE OverloadedStrings #-} +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. + +import Prelude hiding ((<$>)) + +import Data.Char (toLower, toUpper) +import Data.Maybe (isNothing) +import Data.Text (Text, unpack) +import System.Exit (exitFailure) +import System.IO (stderr, stdout) + +import qualified Data.Text as Text +import qualified Text.PrettyPrint.ANSI.Leijen as AnsiPP +import Text.PrettyPrint.Leijen hiding (list, tupled) +import Text.Trifecta (Result (..), parseString) +import Text.Trifecta.Delta (Delta (Directed)) + +import Language.Thrift.Parser.Trifecta (thriftIDL) +import Language.Thrift.Types + +die :: String -> IO a +die s = putStrLn s >> exitFailure + +-- | '<$>' with the arguments flipped. +(<&>) :: Functor f => f a -> (a -> b) -> f b +(<&>) = flip fmap +infixl 1 <&> + +($$) :: Docstring -> Doc -> Doc +($$) Nothing y = y +($$) (Just t) y = case Text.lines t of + [] -> y + l:ls -> let docstring = align . vsep + $ (text "-- |" <+> text (unpack l)) + : map ((text "--" <+>) . text . unpack) ls + in align (docstring <$> y) +infixr 1 $$ + +list :: [Doc] -> Doc +list = encloseSep lbracket rbracket (text ", ") + +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) + where + 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 + +renderStructField :: Show a => Text -> Field a -> Doc +renderStructField structName (Field _ req ftype fname def _ docstring _) = hang 4 $ + docstring $$ + fieldName + hsep [ + text "::" + , (if isOptional + then text "Maybe" <> space + else empty) <> renderFieldType ftype + ] + where + isOptional + | isNothing req = False + | otherwise = r == Optional && isNothing def + where (Just r) = req + fieldName = text . unpack $ Text.concat [ + structName + , underscoresToCamelCase False fname + ] + +renderType :: Show a => Type a -> Doc +renderType = go + where + derivingClause = + text "deriving" <+> tupled (map text ["Show", "Ord", "Eq"]) + + 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 + 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 + +typeName :: Text -> Doc +typeName = mkName False + +generateOutput :: Show a => Program a -> IO () +generateOutput (Program _ definitions) = do + let doc = headers <$> empty <$> + vcat (map ((<$> empty) . genDef) definitions) + displayIO stdout $ renderPretty 0.8 80 doc + where + import_ m items = sep [ + text "import" + , text m + , maybe empty (tupled . map string) items + ] + + importQualified m s = sep [ + text "import qualified" + , text m + , text "as" + , text s + ] + + headers = vcat [ + import_ "Data.Map" (Just ["Map"]) + , import_ "Data.Set" (Just ["Set"]) + , import_ "Data.Text" (Just ["Text"]) + , import_ "Data.ByteString" (Just ["ByteString"]) + , import_ "Data.Word" (Just ["Word8", "Word16", "Word32", "Word64"]) + , 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 + +underscoresToCamelCase :: Bool -> Text -> Text +underscoresToCamelCase lowerFirst = + camelCase lowerFirst . Text.split (== '_') + +camelCase :: Bool -> [Text] -> Text +camelCase lowerFirst = + maybeLower . Text.concat . map (transformIndex toUpper 0) + where + maybeLower = if lowerFirst then transformIndex toLower 0 else id + +transformIndex :: (Char -> Char) -> Int -> Text -> Text +transformIndex f i s = Text.concat [ + Text.take i s + , Text.singleton $ f (s `Text.index` i) + , Text.drop (i + 1) s + ] + +main :: IO () +main = do + result <- getContents <&> parseString thriftIDL (Directed "stdin" 0 0 0 0) + case result of + Success p -> generateOutput p + Failure doc -> do + AnsiPP.displayIO stderr $ AnsiPP.renderPretty 0.8 80 doc + die "Parse Failed" diff --git a/language-thrift.cabal b/language-thrift.cabal --- a/language-thrift.cabal +++ b/language-thrift.cabal @@ -1,5 +1,5 @@ name : language-thrift -version : 0.2.0.0 +version : 0.3.0.0 synopsis : Parser for the Thrift IDL format. homepage : https://github.com/abhinav/language-thrift license : BSD3 @@ -15,10 +15,11 @@ extra-source-files: README.md CHANGES.md --- examples/*.hs TODO: Add examples + examples/*.hs library exposed-modules : Language.Thrift.Parser + , Language.Thrift.Parser.Trifecta , Language.Thrift.Types build-depends : base >= 4.7 && < 4.9 , mtl