diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,12 +1,8 @@ -0.8.0.2 (2016-08-31) -==================== - -- Disallow reserved keywords from being used as identifier names. - -0.8.0.1 (2016-05-24) +0.9.0.0 (2016-05-15) ==================== -- Build with GHC 8. +- Deprecate the `Language.Thrift.Types` in favor of `Language.Thrift.AST`. +- Upgrade to `megaparsec` 5.0. 0.8.0.0 (2016-02-09) ==================== diff --git a/examples/generateHaskellTypes.hs b/examples/generateHaskellTypes.hs --- a/examples/generateHaskellTypes.hs +++ b/examples/generateHaskellTypes.hs @@ -26,7 +26,7 @@ import Language.Thrift.Parser (parse) -import qualified Language.Thrift.Types as T +import qualified Language.Thrift.AST as T die :: String -> IO a die s = hPutStrLn stderr s >> exitFailure diff --git a/language-thrift.cabal b/language-thrift.cabal --- a/language-thrift.cabal +++ b/language-thrift.cabal @@ -1,16 +1,16 @@ --- This file has been generated from package.yaml by hpack version 0.14.1. +-- This file has been generated from package.yaml by hpack version 0.13.0. -- -- see: https://github.com/sol/hpack name: language-thrift -version: 0.8.0.2 +version: 0.9.0.0 +bug-reports: https://github.com/abhinav/language-thrift/issues cabal-version: >= 1.10 build-type: Simple license: BSD3 license-file: LICENSE maintainer: Abhinav Gupta homepage: https://github.com/abhinav/language-thrift#readme -bug-reports: https://github.com/abhinav/language-thrift/issues synopsis: Parser and pretty printer for the Thrift IDL format. description: This package provides a parser and pretty printer for the . @@ -33,50 +33,43 @@ hs-source-dirs: src ghc-options: -Wall + build-depends: + base >= 4.7 && < 4.9, + ansi-wl-pprint >= 0.6 && < 0.7, + megaparsec >= 5.0 && < 6.0, + text >= 1.2, + scientific >= 0.3 && < 0.4, + transformers exposed-modules: + Language.Thrift.AST Language.Thrift.Parser Language.Thrift.Pretty Language.Thrift.Types other-modules: - Language.Thrift.Internal.Reserved - Language.Thrift.Internal.Types + Language.Thrift.Internal.AST + Language.Thrift.Internal.Lens Paths_language_thrift default-language: Haskell2010 - build-depends: - base >= 4.7 && < 5, - ansi-wl-pprint >= 0.6 && < 0.7, - containers >= 0.5 && < 0.6, - megaparsec >= 4.0 && < 5.0, - text >= 1.2, - transformers test-suite spec type: exitcode-stdio-1.0 main-is: Main.hs + hs-source-dirs: + test + ghc-options: -Wall build-depends: - base >= 4.7 && < 5, + base >= 4.7 && < 4.9, ansi-wl-pprint >= 0.6 && < 0.7, - containers >= 0.5 && < 0.6, - megaparsec >= 4.0 && < 5.0, + megaparsec >= 5.0 && < 6.0, text >= 1.2, - transformers, hspec >= 2.0, hspec-discover >= 2.1, language-thrift, QuickCheck >= 2.5 other-modules: - Language.Thrift.Internal.Reserved - Language.Thrift.Internal.Types - Language.Thrift.Parser - Language.Thrift.Pretty - Language.Thrift.Types Language.Thrift.Arbitrary + Language.Thrift.ASTSpec Language.Thrift.ParserSpec - Language.Thrift.TypesSpec Spec TestUtils default-language: Haskell2010 - hs-source-dirs: - src, - test - ghc-options: -Wall diff --git a/src/Language/Thrift/AST.hs b/src/Language/Thrift/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/Thrift/AST.hs @@ -0,0 +1,27 @@ +-- | +-- Module : Language.Thrift.AST +-- Copyright : (c) Abhinav Gupta 2016 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- This module defines types that compose a Thrift IDL file. +-- +-- Most of the types have an optional @srcAnnot@ parameter that represents a +-- source annotation. The parser produces types annotated with their position +-- in the Thrift file ('Text.Megaparsec.SourcePos'). When constructing the AST +-- by hand, you can use @()@. The types are @Functor@s so you can use 'fmap' +-- to change the annotation on all objects in a tree. +-- +-- Lenses for attributes of most types are provided for use with the `lens` +-- library. +-- +-- Types representing the AST all have 'Text.PrettyPrint.ANSI.Leijen.Pretty' +-- instances to go with them. +module Language.Thrift.AST + ( module Language.Thrift.Internal.AST + ) where + +import Language.Thrift.Internal.AST +import Language.Thrift.Pretty () diff --git a/src/Language/Thrift/Internal/AST.hs b/src/Language/Thrift/Internal/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/Thrift/Internal/AST.hs @@ -0,0 +1,781 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +module Language.Thrift.Internal.AST + ( + -- * AST + + Program(..) + , headers + , definitions + + , Header(..) + + , Include(..) + , path + + , Namespace(..) + , language + + , Definition(..) + + , Const(..) + , Service(..) + , functions + , extends + + , Type(..) + + , Typedef(..) + , targetType + + , Enum(..) + , Struct(..) + , Union(..) + , Exception(..) + , Senum(..) + + , FieldRequiredness(..) + + , Field(..) + , identifier + , requiredness + , defaultValue + + , EnumDef(..) + + , ConstValue(..) + + , TypeReference(..) + + , Function(..) + , oneWay + , returnType + , parameters + , exceptions + + , TypeAnnotation(..) + , Docstring + + -- * Typeclasses + + , HasAnnotations(..) + , HasDocstring(..) + , HasFields(..) + , HasName(..) + , HasSrcAnnot(..) + , HasValue(..) + , HasValues(..) + , HasValueType(..) + ) where + +import Data.Data (Data, Typeable) +import Data.Text (Text) +import GHC.Generics (Generic) +import Prelude hiding (Enum) + +import Language.Thrift.Internal.Lens + +class HasSrcAnnot t where + srcAnnot :: Lens (t a) a + +class HasName t where + name :: Lens t Text + +class HasValue s a | s -> a where + value :: Lens s a + +-- | 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) + +instance HasName TypeAnnotation where + name = lens typeAnnotationName (\s a -> s { typeAnnotationName = a }) + +instance HasValue TypeAnnotation (Maybe Text) where + value = lens typeAnnotationValue (\s a -> s { typeAnnotationValue = a }) + +class HasAnnotations t where + annotations :: Lens t [TypeAnnotation] + +-- | Docstrings are Javadoc-style comments attached various defined objects. +-- +-- > /** +-- > * Fetches an item. +-- > */ +-- > Item getItem() +type Docstring = Maybe Text + +class HasDocstring t where + docstring :: Lens t Docstring + +-- | 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 srcAnnot + = ConstInt Integer srcAnnot + -- ^ An integer. @42@ + | ConstFloat Double srcAnnot + -- ^ A float. @4.2@ + | ConstLiteral Text srcAnnot + -- ^ A literal string. @"hello"@ + | ConstIdentifier Text srcAnnot + -- ^ A reference to another constant. @Foo.bar@ + | ConstList [ConstValue srcAnnot] srcAnnot + -- ^ A literal list containing other constant values. @[42]@ + | ConstMap [(ConstValue srcAnnot, ConstValue srcAnnot)] srcAnnot + -- ^ A literal list containing other constant values. + -- @{"hellO": 1, "world": 2}@ + deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) + +instance HasSrcAnnot ConstValue where + srcAnnot = lens getter setter + where + getter (ConstInt _ a) = a + getter (ConstFloat _ a) = a + getter (ConstLiteral _ a) = a + getter (ConstIdentifier _ a) = a + getter (ConstList _ a) = a + getter (ConstMap _ a) = a + + setter (ConstInt x _) a = ConstInt x a + setter (ConstFloat x _) a = ConstFloat x a + setter (ConstLiteral x _) a = ConstLiteral x a + setter (ConstIdentifier x _) a = ConstIdentifier x a + setter (ConstList x _) a = ConstList x a + setter (ConstMap x _) a = ConstMap x a + +-- | A reference to a type. +data TypeReference srcAnnot + = DefinedType Text srcAnnot + -- ^ A custom defined type referred to by name. + + | StringType [TypeAnnotation] srcAnnot + -- ^ @string@ and annotations. + | BinaryType [TypeAnnotation] srcAnnot + -- ^ @binary@ and annotations. + | SListType [TypeAnnotation] srcAnnot + -- ^ @slist@ and annotations. + | BoolType [TypeAnnotation] srcAnnot + -- ^ @bool@ and annotations. + | ByteType [TypeAnnotation] srcAnnot + -- ^ @byte@ and annotations. + | I16Type [TypeAnnotation] srcAnnot + -- ^ @i16@ and annotations. + | I32Type [TypeAnnotation] srcAnnot + -- ^ @i32@ and annotations. + | I64Type [TypeAnnotation] srcAnnot + -- ^ @i64@ and annotations. + | DoubleType [TypeAnnotation] srcAnnot + -- ^ @double@ and annotations. + + -- Container types + | MapType + (TypeReference srcAnnot) + (TypeReference srcAnnot) + [TypeAnnotation] + srcAnnot + -- ^ @map\@ and annotations. + | SetType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot + -- ^ @set\@ and annotations. + | ListType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot + -- ^ @list\@ and annotations. + deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) + +instance HasSrcAnnot TypeReference where + srcAnnot = lens getter setter + where + getter (DefinedType _ a) = a + getter (StringType _ a) = a + getter (BinaryType _ a) = a + getter (SListType _ a) = a + getter (BoolType _ a) = a + getter (ByteType _ a) = a + getter (I16Type _ a) = a + getter (I32Type _ a) = a + getter (I64Type _ a) = a + getter (DoubleType _ a) = a + getter (MapType _ _ _ a) = a + getter (SetType _ _ a) = a + getter (ListType _ _ a) = a + + setter (DefinedType x _) a = DefinedType x a + setter (StringType x _) a = StringType x a + setter (BinaryType x _) a = BinaryType x a + setter (SListType x _) a = SListType x a + setter (BoolType x _) a = BoolType x a + setter (ByteType x _) a = ByteType x a + setter (I16Type x _) a = I16Type x a + setter (I32Type x _) a = I32Type x a + setter (I64Type x _) a = I64Type x a + setter (DoubleType x _) a = DoubleType x a + setter (MapType k v x _) a = MapType k v x a + setter (SetType t x _) a = SetType t x a + setter (ListType t x _) a = ListType t x a + +class HasValueType t where + valueType :: Lens (t a) (TypeReference a) + +-- | 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. + , 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, Functor) + +identifier :: Lens (Field a) (Maybe Integer) +identifier = lens fieldIdentifier (\s a -> s { fieldIdentifier = a }) + +requiredness :: Lens (Field a) (Maybe FieldRequiredness) +requiredness = lens fieldRequiredness (\s a -> s { fieldRequiredness = a }) + +defaultValue :: Lens (Field a) (Maybe (ConstValue a)) +defaultValue = lens fieldDefaultValue (\s a -> s { fieldDefaultValue = a }) + +instance HasName (Field a) where + name = lens fieldName (\s a -> s { fieldName = a }) + +instance HasValueType Field where + valueType = lens fieldValueType (\s a -> s { fieldValueType = a }) + +instance HasSrcAnnot Field where + srcAnnot = lens fieldSrcAnnot (\s a -> s { fieldSrcAnnot = a }) + +instance HasDocstring (Field a) where + docstring = lens fieldDocstring (\s a -> s { fieldDocstring = a }) + +instance HasAnnotations (Field a) where + annotations = lens fieldAnnotations (\s a -> s { fieldAnnotations = a }) + +class HasFields t where + fields :: Lens (t a) [Field a] + +-- | 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 (TypeReference srcAnnot) + -- ^ 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, Functor) + +oneWay :: Lens (Function a) Bool +oneWay = lens functionOneWay (\s a -> s { functionOneWay = a }) + +returnType :: Lens (Function a) (Maybe (TypeReference a)) +returnType = lens functionReturnType (\s a -> s { functionReturnType = a }) + +parameters :: Lens (Function a) [Field a] +parameters = lens functionParameters (\s a -> s { functionParameters = a }) + +exceptions :: Lens (Function a) (Maybe [Field a]) +exceptions = lens functionExceptions (\s a -> s { functionExceptions = a }) + +instance HasName (Function a) where + name = lens functionName (\s a -> s { functionName = a }) + +instance HasSrcAnnot Function where + srcAnnot = lens functionSrcAnnot (\s a -> s { functionSrcAnnot = a }) + +instance HasDocstring (Function a) where + docstring = lens functionDocstring (\s a -> s { functionDocstring = a }) + +instance HasAnnotations (Function a) where + annotations = lens functionAnnotations (\s a -> s { functionAnnotations = a }) + +-- | A service definition. +-- +-- > 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, Functor) + +functions :: Lens (Service a) [Function a] +functions = lens serviceFunctions (\s a -> s { serviceFunctions = a }) + +extends :: Lens (Service a) (Maybe Text) +extends = lens serviceExtends (\s a -> s { serviceExtends = a }) + +instance HasName (Service a) where + name = lens serviceName (\s a -> s { serviceName = a }) + +instance HasSrcAnnot Service where + srcAnnot = lens serviceSrcAnnot (\s a -> s { serviceSrcAnnot = a }) + +instance HasDocstring (Service a) where + docstring = lens serviceDocstring (\s a -> s { serviceDocstring = a }) + +instance HasAnnotations (Service a) where + annotations = lens serviceAnnotations (\s a -> s { serviceAnnotations = a }) + +-- | A declared constant. +-- +-- > 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, Functor) + +instance HasValue (Const a) (ConstValue a) where + value = lens constValue (\s a -> s { constValue = a }) + +instance HasName (Const a) where + name = lens constName (\s a -> s { constName = a }) + +instance HasSrcAnnot Const where + srcAnnot = lens constSrcAnnot (\s a -> s { constSrcAnnot = a }) + +instance HasValueType Const where + valueType = lens constValueType (\s a -> s { constValueType = a }) + +instance HasDocstring (Const a) where + docstring = lens constDocstring (\s a -> s { constDocstring = a }) + +-- | A typedef is just an alias for another type. +-- +-- > 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, Functor) + +targetType :: Lens (Typedef a) (TypeReference a) +targetType = lens typedefTargetType (\s a -> s { typedefTargetType = a }) + +instance HasName (Typedef a) where + name = lens typedefName (\s a -> s { typedefName = a }) + +instance HasSrcAnnot Typedef where + srcAnnot = lens typedefSrcAnnot (\s a -> s { typedefSrcAnnot = a }) + +instance HasDocstring (Typedef a) where + docstring = lens typedefDocstring (\s a -> s { typedefDocstring = a }) + +instance HasAnnotations (Typedef a) where + annotations = lens typedefAnnotations (\s a -> s { typedefAnnotations = a }) + +-- | 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, Functor) + +instance HasValue (EnumDef a) (Maybe Integer) where + value = lens enumDefValue (\s a -> s { enumDefValue = a }) + +instance HasName (EnumDef a) where + name = lens enumDefName (\s a -> s { enumDefName = a }) + +instance HasSrcAnnot EnumDef where + srcAnnot = lens enumDefSrcAnnot (\s a -> s { enumDefSrcAnnot = a }) + +instance HasDocstring (EnumDef a) where + docstring = lens enumDefDocstring (\s a -> s { enumDefDocstring = a }) + +instance HasAnnotations (EnumDef a) where + annotations = lens enumDefAnnotations (\s a -> s { enumDefAnnotations = a }) + +-- | 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, Functor) + +class HasValues s a | s -> a where + values :: Lens s a + +instance HasValues (Enum a) [EnumDef a] where + values = lens enumValues (\s a -> s { enumValues = a }) + +instance HasName (Enum a) where + name = lens enumName (\s a -> s { enumName = a }) + +instance HasSrcAnnot Enum where + srcAnnot = lens enumSrcAnnot (\s a -> s { enumSrcAnnot = a }) + +instance HasDocstring (Enum a) where + docstring = lens enumDocstring (\s a -> s { enumDocstring = a }) + +instance HasAnnotations (Enum a) where + annotations = lens enumAnnotations (\s a -> s { enumAnnotations = a }) + +-- | 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, Functor) + +instance HasName (Struct a) where + name = lens structName (\s a -> s { structName = a }) + +instance HasFields Struct where + fields = lens structFields (\s a -> s { structFields = a }) + +instance HasSrcAnnot Struct where + srcAnnot = lens structSrcAnnot (\s a -> s { structSrcAnnot = a }) + +instance HasDocstring (Struct a) where + docstring = lens structDocstring (\s a -> s { structDocstring = a }) + +instance HasAnnotations (Struct a) where + annotations = lens structAnnotations (\s a -> s { structAnnotations = a }) + +-- | 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, Functor) + +instance HasName (Union a) where + name = lens unionName (\s a -> s { unionName = a }) + +instance HasFields Union where + fields = lens unionFields (\s a -> s { unionFields = a }) + +instance HasSrcAnnot Union where + srcAnnot = lens unionSrcAnnot (\s a -> s { unionSrcAnnot = a }) + +instance HasDocstring (Union a) where + docstring = lens unionDocstring (\s a -> s { unionDocstring = a }) + +instance HasAnnotations (Union a) where + annotations = lens unionAnnotations (\s a -> s { unionAnnotations = a }) + +-- | 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, Functor) + +instance HasName (Exception a) where + name = lens exceptionName (\s a -> s { exceptionName = a }) + +instance HasFields Exception where + fields = lens exceptionFields (\s a -> s { exceptionFields = a }) + +instance HasSrcAnnot Exception where + srcAnnot = lens exceptionSrcAnnot (\s a -> s { exceptionSrcAnnot = a }) + +instance HasDocstring (Exception a) where + docstring = lens exceptionDocstring (\s a -> s { exceptionDocstring = a }) + +instance HasAnnotations (Exception a) where + annotations = lens exceptionAnnotations (\s a -> s { exceptionAnnotations = a }) + +-- | 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, Functor) + +instance HasValues (Senum a) [Text] where + values = lens senumValues (\s a -> s { senumValues = a }) + +instance HasName (Senum a) where + name = lens senumName (\s a -> s { senumName = a }) + +instance HasSrcAnnot Senum where + srcAnnot = lens senumSrcAnnot (\s a -> s { senumSrcAnnot = a }) + +instance HasDocstring (Senum a) where + docstring = lens senumDocstring (\s a -> s { senumDocstring = a }) + +instance HasAnnotations (Senum a) where + annotations = lens senumAnnotations (\s a -> s { senumAnnotations = a }) + +-- | 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, Functor) + +instance HasName (Type a) where + name = lens getter setter + where + getter (TypedefType t) = view name t + getter (EnumType t) = view name t + getter (StructType t) = view name t + getter (UnionType t) = view name t + getter (ExceptionType t) = view name t + getter (SenumType t) = view name t + + setter (TypedefType t) n = TypedefType $ set name n t + setter (EnumType t) n = EnumType $ set name n t + setter (StructType t) n = StructType $ set name n t + setter (UnionType t) n = UnionType $ set name n t + setter (ExceptionType t) n = ExceptionType $ set name n t + setter (SenumType t) n = SenumType $ set name n t + +instance HasSrcAnnot Type where + srcAnnot = lens getter setter + where + getter (TypedefType t) = view srcAnnot t + getter (EnumType t) = view srcAnnot t + getter (StructType t) = view srcAnnot t + getter (UnionType t) = view srcAnnot t + getter (ExceptionType t) = view srcAnnot t + getter (SenumType t) = view srcAnnot t + + setter (TypedefType t) a = TypedefType $ set srcAnnot a t + setter (EnumType t) a = EnumType $ set srcAnnot a t + setter (StructType t) a = StructType $ set srcAnnot a t + setter (UnionType t) a = UnionType $ set srcAnnot a t + setter (ExceptionType t) a = ExceptionType $ set srcAnnot a t + setter (SenumType t) a = SenumType $ set srcAnnot a t + +-- | 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, Functor) + +instance HasName (Definition a) where + name = lens getter setter + where + getter (ConstDefinition d) = view name d + getter (TypeDefinition d) = view name d + getter (ServiceDefinition d) = view name d + + setter (ConstDefinition d) n = ConstDefinition $ set name n d + setter (TypeDefinition d) n = TypeDefinition $ set name n d + setter (ServiceDefinition d) n = ServiceDefinition $ set name n d + +instance HasSrcAnnot Definition where + srcAnnot = lens getter setter + where + getter (ConstDefinition d) = view srcAnnot d + getter (TypeDefinition d) = view srcAnnot d + getter (ServiceDefinition d) = view srcAnnot d + + setter (ConstDefinition d) a = ConstDefinition $ set srcAnnot a d + setter (TypeDefinition d) a = TypeDefinition $ set srcAnnot a d + setter (ServiceDefinition d) a = ServiceDefinition $ set srcAnnot a d + + +-- | 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, Functor) + +language :: Lens (Namespace a) Text +language = lens namespaceLanguage (\s a -> s { namespaceLanguage = a }) + +instance HasName (Namespace a) where + name = lens namespaceName (\s a -> s { namespaceName = a }) + +instance HasSrcAnnot Namespace where + srcAnnot = lens namespaceSrcAnnot (\s a -> s { namespaceSrcAnnot = a }) + +-- | 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, Functor) + +path :: Lens (Include a) Text +path = lens includePath (\s a -> s { includePath = a }) + +instance HasSrcAnnot Include where + srcAnnot = lens includeSrcAnnot (\s a -> s { includeSrcAnnot = a }) + +-- | 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, Functor) + +-- | 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, Functor) + +headers :: Lens (Program a) [Header a] +headers = lens programHeaders (\s a -> s { programHeaders = a }) + +definitions :: Lens (Program a) [Definition a] +definitions = lens programDefinitions (\s a -> s { programDefinitions = a }) diff --git a/src/Language/Thrift/Internal/Lens.hs b/src/Language/Thrift/Internal/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Language/Thrift/Internal/Lens.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE RankNTypes #-} +-- | This module implements a minimal lens type. +module Language.Thrift.Internal.Lens + ( Lens + , lens + , set + , view + ) where + +import Data.Functor.Identity (Identity (..)) + +import qualified Control.Applicative as A + +type Lens s a = forall f. Functor f => (a -> f a) -> s -> f s + +lens :: (s -> a) -> (s -> a -> s) -> Lens s a +lens getter setter f s = setter s `fmap` f (getter s) + +set :: Lens s a -> a -> s -> s +set l a = runIdentity . l (\_ -> Identity a) + +view :: Lens s a -> s -> a +view l = A.getConst . l A.Const diff --git a/src/Language/Thrift/Internal/Reserved.hs b/src/Language/Thrift/Internal/Reserved.hs deleted file mode 100644 --- a/src/Language/Thrift/Internal/Reserved.hs +++ /dev/null @@ -1,59 +0,0 @@ --- | --- Module : Language.Thrift.Internal.Reserved --- Copyright : (c) Abhinav Gupta 2016 --- License : BSD3 --- --- Maintainer : Abhinav Gupta --- Stability : experimental --- --- This module provides information about reserved Thrift identifiers. -module Language.Thrift.Internal.Reserved - ( isReserved - ) where - -import Data.Set (Set) -import qualified Data.Set as Set - -isReserved :: String -> Bool -isReserved = (`Set.member` reservedKeywords) - -reservedKeywords :: Set String -reservedKeywords = Set.fromList - [ "include" - , "namespace" - , "cpp_namespace" - , "php_namespace" - , "py_module" - , "perl_package" - , "ruby_namespace" - , "java_package" - , "cocoa_package" - , "csharp_namespace" - , "typedef" - , "enum" - , "struct" - , "union" - , "exception" - , "required" - , "optional" - , "senum" - , "const" - , "string" - , "binary" - , "slist" - , "bool" - , "byte" - , "i8" - , "i16" - , "i32" - , "i64" - , "double" - , "map" - , "set" - , "list" - , "service" - , "extends" - , "oneway" - , "void" - , "throws" - ] diff --git a/src/Language/Thrift/Internal/Types.hs b/src/Language/Thrift/Internal/Types.hs deleted file mode 100644 --- a/src/Language/Thrift/Internal/Types.hs +++ /dev/null @@ -1,793 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -module Language.Thrift.Internal.Types - ( - -- * AST - - Program(..) - , headers - , definitions - - , Header(..) - - , Include(..) - , path - - , Namespace(..) - , language - - , Definition(..) - - , Const(..) - , Service(..) - , functions - , extends - - , Type(..) - - , Typedef(..) - , targetType - - , Enum(..) - , Struct(..) - , Union(..) - , Exception(..) - , Senum(..) - - , FieldRequiredness(..) - - , Field(..) - , identifier - , requiredness - , defaultValue - - , EnumDef(..) - - , ConstValue(..) - - , TypeReference(..) - - , Function(..) - , oneWay - , returnType - , parameters - , exceptions - - , TypeAnnotation(..) - , Docstring - - -- * Typeclasses - - , HasAnnotations(..) - , HasDocstring(..) - , HasFields(..) - , HasName(..) - , HasSrcAnnot(..) - , HasValue(..) - , HasValues(..) - , HasValueType(..) - ) where - -import Data.Data (Data, Typeable) -import Data.Functor.Identity (Identity (..)) -import Data.Text (Text) -import GHC.Generics (Generic) -import Prelude hiding (Enum) - -import qualified Control.Applicative as A - -type Lens s a = forall f. Functor f => (a -> f a) -> s -> f s - -lens :: (s -> a) -> (s -> a -> s) -> Lens s a -lens getter setter f s = setter s `fmap` f (getter s) - -set :: Lens s a -> a -> s -> s -set l a = runIdentity . l (\_ -> Identity a) - -view :: Lens s a -> s -> a -view l = A.getConst . l A.Const - -class HasSrcAnnot t where - srcAnnot :: Lens (t a) a - -class HasName t where - name :: Lens t Text - -class HasValue s a | s -> a where - value :: Lens s a - --- | 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) - -instance HasName TypeAnnotation where - name = lens typeAnnotationName (\s a -> s { typeAnnotationName = a }) - -instance HasValue TypeAnnotation (Maybe Text) where - value = lens typeAnnotationValue (\s a -> s { typeAnnotationValue = a }) - -class HasAnnotations t where - annotations :: Lens t [TypeAnnotation] - --- | Docstrings are Javadoc-style comments attached various defined objects. --- --- > /** --- > * Fetches an item. --- > */ --- > Item getItem() -type Docstring = Maybe Text - -class HasDocstring t where - docstring :: Lens t Docstring - --- | 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 srcAnnot - = ConstInt Integer srcAnnot - -- ^ An integer. @42@ - | ConstFloat Double srcAnnot - -- ^ A float. @4.2@ - | ConstLiteral Text srcAnnot - -- ^ A literal string. @"hello"@ - | ConstIdentifier Text srcAnnot - -- ^ A reference to another constant. @Foo.bar@ - | ConstList [ConstValue srcAnnot] srcAnnot - -- ^ A literal list containing other constant values. @[42]@ - | ConstMap [(ConstValue srcAnnot, ConstValue srcAnnot)] srcAnnot - -- ^ A literal list containing other constant values. - -- @{"hellO": 1, "world": 2}@ - deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) - -instance HasSrcAnnot ConstValue where - srcAnnot = lens getter setter - where - getter (ConstInt _ a) = a - getter (ConstFloat _ a) = a - getter (ConstLiteral _ a) = a - getter (ConstIdentifier _ a) = a - getter (ConstList _ a) = a - getter (ConstMap _ a) = a - - setter (ConstInt x _) a = ConstInt x a - setter (ConstFloat x _) a = ConstFloat x a - setter (ConstLiteral x _) a = ConstLiteral x a - setter (ConstIdentifier x _) a = ConstIdentifier x a - setter (ConstList x _) a = ConstList x a - setter (ConstMap x _) a = ConstMap x a - --- | A reference to a type. -data TypeReference srcAnnot - = DefinedType Text srcAnnot - -- ^ A custom defined type referred to by name. - - | StringType [TypeAnnotation] srcAnnot - -- ^ @string@ and annotations. - | BinaryType [TypeAnnotation] srcAnnot - -- ^ @binary@ and annotations. - | SListType [TypeAnnotation] srcAnnot - -- ^ @slist@ and annotations. - | BoolType [TypeAnnotation] srcAnnot - -- ^ @bool@ and annotations. - | ByteType [TypeAnnotation] srcAnnot - -- ^ @byte@ and annotations. - | I16Type [TypeAnnotation] srcAnnot - -- ^ @i16@ and annotations. - | I32Type [TypeAnnotation] srcAnnot - -- ^ @i32@ and annotations. - | I64Type [TypeAnnotation] srcAnnot - -- ^ @i64@ and annotations. - | DoubleType [TypeAnnotation] srcAnnot - -- ^ @double@ and annotations. - - -- Container types - | MapType - (TypeReference srcAnnot) - (TypeReference srcAnnot) - [TypeAnnotation] - srcAnnot - -- ^ @map\@ and annotations. - | SetType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot - -- ^ @set\@ and annotations. - | ListType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot - -- ^ @list\@ and annotations. - deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) - -instance HasSrcAnnot TypeReference where - srcAnnot = lens getter setter - where - getter (DefinedType _ a) = a - getter (StringType _ a) = a - getter (BinaryType _ a) = a - getter (SListType _ a) = a - getter (BoolType _ a) = a - getter (ByteType _ a) = a - getter (I16Type _ a) = a - getter (I32Type _ a) = a - getter (I64Type _ a) = a - getter (DoubleType _ a) = a - getter (MapType _ _ _ a) = a - getter (SetType _ _ a) = a - getter (ListType _ _ a) = a - - setter (DefinedType x _) a = DefinedType x a - setter (StringType x _) a = StringType x a - setter (BinaryType x _) a = BinaryType x a - setter (SListType x _) a = SListType x a - setter (BoolType x _) a = BoolType x a - setter (ByteType x _) a = ByteType x a - setter (I16Type x _) a = I16Type x a - setter (I32Type x _) a = I32Type x a - setter (I64Type x _) a = I64Type x a - setter (DoubleType x _) a = DoubleType x a - setter (MapType k v x _) a = MapType k v x a - setter (SetType t x _) a = SetType t x a - setter (ListType t x _) a = ListType t x a - -class HasValueType t where - valueType :: Lens (t a) (TypeReference a) - --- | 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. - , 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, Functor) - -identifier :: Lens (Field a) (Maybe Integer) -identifier = lens fieldIdentifier (\s a -> s { fieldIdentifier = a }) - -requiredness :: Lens (Field a) (Maybe FieldRequiredness) -requiredness = lens fieldRequiredness (\s a -> s { fieldRequiredness = a }) - -defaultValue :: Lens (Field a) (Maybe (ConstValue a)) -defaultValue = lens fieldDefaultValue (\s a -> s { fieldDefaultValue = a }) - -instance HasName (Field a) where - name = lens fieldName (\s a -> s { fieldName = a }) - -instance HasValueType Field where - valueType = lens fieldValueType (\s a -> s { fieldValueType = a }) - -instance HasSrcAnnot Field where - srcAnnot = lens fieldSrcAnnot (\s a -> s { fieldSrcAnnot = a }) - -instance HasDocstring (Field a) where - docstring = lens fieldDocstring (\s a -> s { fieldDocstring = a }) - -instance HasAnnotations (Field a) where - annotations = lens fieldAnnotations (\s a -> s { fieldAnnotations = a }) - -class HasFields t where - fields :: Lens (t a) [Field a] - --- | 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 (TypeReference srcAnnot) - -- ^ 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, Functor) - -oneWay :: Lens (Function a) Bool -oneWay = lens functionOneWay (\s a -> s { functionOneWay = a }) - -returnType :: Lens (Function a) (Maybe (TypeReference a)) -returnType = lens functionReturnType (\s a -> s { functionReturnType = a }) - -parameters :: Lens (Function a) [Field a] -parameters = lens functionParameters (\s a -> s { functionParameters = a }) - -exceptions :: Lens (Function a) (Maybe [Field a]) -exceptions = lens functionExceptions (\s a -> s { functionExceptions = a }) - -instance HasName (Function a) where - name = lens functionName (\s a -> s { functionName = a }) - -instance HasSrcAnnot Function where - srcAnnot = lens functionSrcAnnot (\s a -> s { functionSrcAnnot = a }) - -instance HasDocstring (Function a) where - docstring = lens functionDocstring (\s a -> s { functionDocstring = a }) - -instance HasAnnotations (Function a) where - annotations = lens functionAnnotations (\s a -> s { functionAnnotations = a }) - --- | A service definition. --- --- > 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, Functor) - -functions :: Lens (Service a) [Function a] -functions = lens serviceFunctions (\s a -> s { serviceFunctions = a }) - -extends :: Lens (Service a) (Maybe Text) -extends = lens serviceExtends (\s a -> s { serviceExtends = a }) - -instance HasName (Service a) where - name = lens serviceName (\s a -> s { serviceName = a }) - -instance HasSrcAnnot Service where - srcAnnot = lens serviceSrcAnnot (\s a -> s { serviceSrcAnnot = a }) - -instance HasDocstring (Service a) where - docstring = lens serviceDocstring (\s a -> s { serviceDocstring = a }) - -instance HasAnnotations (Service a) where - annotations = lens serviceAnnotations (\s a -> s { serviceAnnotations = a }) - --- | A declared constant. --- --- > 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, Functor) - -instance HasValue (Const a) (ConstValue a) where - value = lens constValue (\s a -> s { constValue = a }) - -instance HasName (Const a) where - name = lens constName (\s a -> s { constName = a }) - -instance HasSrcAnnot Const where - srcAnnot = lens constSrcAnnot (\s a -> s { constSrcAnnot = a }) - -instance HasValueType Const where - valueType = lens constValueType (\s a -> s { constValueType = a }) - -instance HasDocstring (Const a) where - docstring = lens constDocstring (\s a -> s { constDocstring = a }) - --- | A typedef is just an alias for another type. --- --- > 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, Functor) - -targetType :: Lens (Typedef a) (TypeReference a) -targetType = lens typedefTargetType (\s a -> s { typedefTargetType = a }) - -instance HasName (Typedef a) where - name = lens typedefName (\s a -> s { typedefName = a }) - -instance HasSrcAnnot Typedef where - srcAnnot = lens typedefSrcAnnot (\s a -> s { typedefSrcAnnot = a }) - -instance HasDocstring (Typedef a) where - docstring = lens typedefDocstring (\s a -> s { typedefDocstring = a }) - -instance HasAnnotations (Typedef a) where - annotations = lens typedefAnnotations (\s a -> s { typedefAnnotations = a }) - --- | 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, Functor) - -instance HasValue (EnumDef a) (Maybe Integer) where - value = lens enumDefValue (\s a -> s { enumDefValue = a }) - -instance HasName (EnumDef a) where - name = lens enumDefName (\s a -> s { enumDefName = a }) - -instance HasSrcAnnot EnumDef where - srcAnnot = lens enumDefSrcAnnot (\s a -> s { enumDefSrcAnnot = a }) - -instance HasDocstring (EnumDef a) where - docstring = lens enumDefDocstring (\s a -> s { enumDefDocstring = a }) - -instance HasAnnotations (EnumDef a) where - annotations = lens enumDefAnnotations (\s a -> s { enumDefAnnotations = a }) - --- | 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, Functor) - -class HasValues s a | s -> a where - values :: Lens s a - -instance HasValues (Enum a) [EnumDef a] where - values = lens enumValues (\s a -> s { enumValues = a }) - -instance HasName (Enum a) where - name = lens enumName (\s a -> s { enumName = a }) - -instance HasSrcAnnot Enum where - srcAnnot = lens enumSrcAnnot (\s a -> s { enumSrcAnnot = a }) - -instance HasDocstring (Enum a) where - docstring = lens enumDocstring (\s a -> s { enumDocstring = a }) - -instance HasAnnotations (Enum a) where - annotations = lens enumAnnotations (\s a -> s { enumAnnotations = a }) - --- | 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, Functor) - -instance HasName (Struct a) where - name = lens structName (\s a -> s { structName = a }) - -instance HasFields Struct where - fields = lens structFields (\s a -> s { structFields = a }) - -instance HasSrcAnnot Struct where - srcAnnot = lens structSrcAnnot (\s a -> s { structSrcAnnot = a }) - -instance HasDocstring (Struct a) where - docstring = lens structDocstring (\s a -> s { structDocstring = a }) - -instance HasAnnotations (Struct a) where - annotations = lens structAnnotations (\s a -> s { structAnnotations = a }) - --- | 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, Functor) - -instance HasName (Union a) where - name = lens unionName (\s a -> s { unionName = a }) - -instance HasFields Union where - fields = lens unionFields (\s a -> s { unionFields = a }) - -instance HasSrcAnnot Union where - srcAnnot = lens unionSrcAnnot (\s a -> s { unionSrcAnnot = a }) - -instance HasDocstring (Union a) where - docstring = lens unionDocstring (\s a -> s { unionDocstring = a }) - -instance HasAnnotations (Union a) where - annotations = lens unionAnnotations (\s a -> s { unionAnnotations = a }) - --- | 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, Functor) - -instance HasName (Exception a) where - name = lens exceptionName (\s a -> s { exceptionName = a }) - -instance HasFields Exception where - fields = lens exceptionFields (\s a -> s { exceptionFields = a }) - -instance HasSrcAnnot Exception where - srcAnnot = lens exceptionSrcAnnot (\s a -> s { exceptionSrcAnnot = a }) - -instance HasDocstring (Exception a) where - docstring = lens exceptionDocstring (\s a -> s { exceptionDocstring = a }) - -instance HasAnnotations (Exception a) where - annotations = lens exceptionAnnotations (\s a -> s { exceptionAnnotations = a }) - --- | 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, Functor) - -instance HasValues (Senum a) [Text] where - values = lens senumValues (\s a -> s { senumValues = a }) - -instance HasName (Senum a) where - name = lens senumName (\s a -> s { senumName = a }) - -instance HasSrcAnnot Senum where - srcAnnot = lens senumSrcAnnot (\s a -> s { senumSrcAnnot = a }) - -instance HasDocstring (Senum a) where - docstring = lens senumDocstring (\s a -> s { senumDocstring = a }) - -instance HasAnnotations (Senum a) where - annotations = lens senumAnnotations (\s a -> s { senumAnnotations = a }) - --- | 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, Functor) - -instance HasName (Type a) where - name = lens getter setter - where - getter (TypedefType t) = view name t - getter (EnumType t) = view name t - getter (StructType t) = view name t - getter (UnionType t) = view name t - getter (ExceptionType t) = view name t - getter (SenumType t) = view name t - - setter (TypedefType t) n = TypedefType $ set name n t - setter (EnumType t) n = EnumType $ set name n t - setter (StructType t) n = StructType $ set name n t - setter (UnionType t) n = UnionType $ set name n t - setter (ExceptionType t) n = ExceptionType $ set name n t - setter (SenumType t) n = SenumType $ set name n t - -instance HasSrcAnnot Type where - srcAnnot = lens getter setter - where - getter (TypedefType t) = view srcAnnot t - getter (EnumType t) = view srcAnnot t - getter (StructType t) = view srcAnnot t - getter (UnionType t) = view srcAnnot t - getter (ExceptionType t) = view srcAnnot t - getter (SenumType t) = view srcAnnot t - - setter (TypedefType t) a = TypedefType $ set srcAnnot a t - setter (EnumType t) a = EnumType $ set srcAnnot a t - setter (StructType t) a = StructType $ set srcAnnot a t - setter (UnionType t) a = UnionType $ set srcAnnot a t - setter (ExceptionType t) a = ExceptionType $ set srcAnnot a t - setter (SenumType t) a = SenumType $ set srcAnnot a t - --- | 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, Functor) - -instance HasName (Definition a) where - name = lens getter setter - where - getter (ConstDefinition d) = view name d - getter (TypeDefinition d) = view name d - getter (ServiceDefinition d) = view name d - - setter (ConstDefinition d) n = ConstDefinition $ set name n d - setter (TypeDefinition d) n = TypeDefinition $ set name n d - setter (ServiceDefinition d) n = ServiceDefinition $ set name n d - -instance HasSrcAnnot Definition where - srcAnnot = lens getter setter - where - getter (ConstDefinition d) = view srcAnnot d - getter (TypeDefinition d) = view srcAnnot d - getter (ServiceDefinition d) = view srcAnnot d - - setter (ConstDefinition d) a = ConstDefinition $ set srcAnnot a d - setter (TypeDefinition d) a = TypeDefinition $ set srcAnnot a d - setter (ServiceDefinition d) a = ServiceDefinition $ set srcAnnot a d - - --- | 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, Functor) - -language :: Lens (Namespace a) Text -language = lens namespaceLanguage (\s a -> s { namespaceLanguage = a }) - -instance HasName (Namespace a) where - name = lens namespaceName (\s a -> s { namespaceName = a }) - -instance HasSrcAnnot Namespace where - srcAnnot = lens namespaceSrcAnnot (\s a -> s { namespaceSrcAnnot = a }) - --- | 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, Functor) - -path :: Lens (Include a) Text -path = lens includePath (\s a -> s { includePath = a }) - -instance HasSrcAnnot Include where - srcAnnot = lens includeSrcAnnot (\s a -> s { includeSrcAnnot = a }) - --- | 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, Functor) - --- | 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, Functor) - -headers :: Lens (Program a) [Header a] -headers = lens programHeaders (\s a -> s { programHeaders = a }) - -definitions :: Lens (Program a) [Definition a] -definitions = lens programDefinitions (\s a -> s { programDefinitions = a }) diff --git a/src/Language/Thrift/Parser.hs b/src/Language/Thrift/Parser.hs --- a/src/Language/Thrift/Parser.hs +++ b/src/Language/Thrift/Parser.hs @@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Language.Thrift.Parser -- Copyright : (c) Abhinav Gupta 2016 @@ -64,16 +65,16 @@ import Control.Applicative import Control.Monad import Control.Monad.Trans.State (StateT) +import Data.Scientific (floatingOrInteger) import Data.Text (Text) import qualified Control.Monad.Trans.State as State import qualified Data.Text as Text +import qualified Data.Text.IO as Text import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Lexer as PL -import Language.Thrift.Internal.Reserved (isReserved) - -import qualified Language.Thrift.Types as T +import qualified Language.Thrift.AST as T -- | Keeps track of the last docstring seen by the system so that we can -- attach it to entities. @@ -83,47 +84,53 @@ deriving (Show, Eq) -- | Underlying Parser type. -type Parser s = StateT State (P.Parsec s) +type Parser s = StateT State (P.Parsec P.Dec s) -- | Evaluates the underlying parser with a default state and get the Megaparsec -- parser. -runParser :: Parser s a -> P.Parsec s a +runParser + :: (P.Stream s, P.Token s ~ Char) + => Parser s a -> P.Parsec P.Dec s a runParser p = State.evalStateT p (State Nothing) -- | Parses the Thrift file at the given path. -parseFromFile :: FilePath -> IO (Either P.ParseError (T.Program P.SourcePos)) -parseFromFile = - P.parseFromFile (thriftIDL :: P.Parsec Text (T.Program P.SourcePos)) +parseFromFile + :: FilePath + -> IO (Either (P.ParseError Char P.Dec) (T.Program P.SourcePos)) +parseFromFile path = P.runParser thriftIDL path <$> Text.readFile path -- | @parse name contents@ parses the contents of a Thrift document with name -- @name@ held in @contents@. parse - :: P.Stream s Char - => FilePath -> s -> Either P.ParseError (T.Program P.SourcePos) + :: (P.Stream s, P.Token s ~ Char) + => FilePath + -> s -> Either (P.ParseError Char P.Dec) (T.Program P.SourcePos) parse = P.parse thriftIDL -- | Megaparsec parser that is able to parse full Thrift documents. -thriftIDL :: P.Stream s Char => P.Parsec s (T.Program P.SourcePos) +thriftIDL + :: (P.Stream s, P.Token s ~ Char) + => P.Parsec P.Dec s (T.Program P.SourcePos) thriftIDL = runParser program -clearDocstring :: Parser s () +clearDocstring :: P.Stream s => Parser s () clearDocstring = State.modify' (\s -> s { stateDocstring = Nothing }) -- | Returns the last docstring recorded by the parser and forgets about it. -lastDocstring :: Parser s T.Docstring +lastDocstring :: P.Stream s => Parser s T.Docstring lastDocstring = do s <- State.gets stateDocstring clearDocstring return s -- | Optional whitespace. -whiteSpace :: P.Stream s Char => Parser s () +whiteSpace :: (P.Stream s, P.Token s ~ Char) => Parser s () whiteSpace = someSpace <|> pure () -- | Required whitespace. -someSpace :: P.Stream s Char => Parser s () +someSpace :: (P.Stream s, P.Token s ~ Char) => Parser s () someSpace = P.skipSome $ readDocstring <|> skipComments <|> skipSpace where readDocstring = do @@ -145,14 +152,23 @@ skipLine = void P.eol <|> P.eof <|> (P.anyChar *> skipLine) skipCStyleComment = P.choice - [ P.try (P.string "*/") *> pure () - , P.skipSome (P.noneOf "/*") *> skipCStyleComment - , P.oneOf "/*" *> skipCStyleComment + [ P.try (P.string "*/") *> pure () + , P.skipSome (noneOf "/*") *> skipCStyleComment + , oneOf "/*" *> skipCStyleComment ] +oneOf :: (P.Stream s, P.Token s ~ Char) => String -> Parser s Char +oneOf = P.oneOf +{-# INLINE oneOf #-} + +noneOf :: (P.Stream s, P.Token s ~ Char) => String -> Parser s Char +noneOf = P.noneOf +{-# INLINE noneOf #-} + -- | @p `skipUpTo` n@ skips @p@ @n@ times or until @p@ stops matching -- -- whichever comes first. -skipUpTo :: P.Stream s Char => Parser s a -> Int -> Parser s () +skipUpTo + :: (P.Stream s, P.Token s ~ Char) => Parser s a -> Int -> Parser s () skipUpTo p = loop where loop 0 = return () @@ -162,8 +178,8 @@ loop $! n - 1 ) <|> return () -hspace :: P.Stream s Char => Parser s () -hspace = void $ P.oneOf " \t" +hspace :: (P.Stream s, P.Token s ~ Char) => Parser s () +hspace = void $ oneOf " \t" -- | A javadoc-style docstring. -- @@ -174,10 +190,10 @@ -- This parses attempts to preserve indentation inside the docstring while -- getting rid of the aligned @*@s (if any) and any other preceding space. -- -docstring :: P.Stream s Char => Parser s Text +docstring :: (P.Stream s, P.Token s ~ Char) => Parser s Text docstring = do P.try (P.string "/**") >> P.skipMany hspace - indent <- P.sourceColumn <$> P.getPosition + indent <- fromIntegral . P.unPos <$> PL.indentLevel isNewLine <- maybeEOL chunks <- loop isNewLine (indent - 1) [] return $! Text.intercalate "\n" chunks @@ -185,7 +201,7 @@ maybeEOL = (P.eol >> return True) <|> return False commentChar = - P.noneOf "*\r\n" <|> + noneOf "*\r\n" <|> P.try (P.char '*' <* P.notFollowedBy (P.char '/')) loop shouldDedent maxDedent chunks = do @@ -222,68 +238,59 @@ loop True maxDedent (line:chunks) -symbolic :: P.Stream s Char => Char -> Parser s () +symbolic :: (P.Stream s, P.Token s ~ Char) => Char -> Parser s () symbolic c = void $ PL.symbol whiteSpace [c] -token :: P.Stream s Char => Parser s a -> Parser s a +token :: (P.Stream s, P.Token s ~ Char) => Parser s a -> Parser s a token = PL.lexeme whiteSpace -braces, angles, parens :: P.Stream s Char => Parser s a -> Parser s a +braces, angles, parens + :: (P.Stream s, P.Token s ~ Char) => Parser s a -> Parser s a braces = P.between (symbolic '{') (symbolic '}') angles = P.between (symbolic '<') (symbolic '>') parens = P.between (symbolic '(') (symbolic ')') -comma, semi, colon, equals :: P.Stream s Char => Parser s () +comma, semi, colon, equals :: (P.Stream s, P.Token s ~ Char) => Parser s () comma = symbolic ',' semi = symbolic ';' colon = symbolic ':' equals = symbolic '=' --- | errorUnlessReserved ensures that the given identifier is in the --- reservedKeywords list. If it's not, we have a bug and we should crash. -errorUnlessReserved :: Monad m => String -> m () -errorUnlessReserved name = - unless (isReserved name) $ - error ("reserved called with unreserved identifier " ++ show name) - -- | Parses a reserved identifier and adds it to the collection of known -- reserved keywords. -reserved :: P.Stream s Char => String -> Parser s () -reserved name = - errorUnlessReserved name >> - P.label name $ token $ P.try $ do - void (P.string name) - P.notFollowedBy (P.alphaNumChar <|> P.oneOf "_.") +reserved :: (P.Stream s, P.Token s ~ Char) => String -> Parser s () +reserved name = P.label name $ token $ P.try $ do + void (P.string name) + P.notFollowedBy (P.alphaNumChar <|> oneOf "_.") + -- | A string literal. @"hello"@ -literal :: P.Stream s Char => Parser s Text +literal :: (P.Stream s, P.Token s ~ Char) => Parser s Text literal = P.label "string literal" $ token $ stringLiteral '"' <|> stringLiteral '\'' -stringLiteral :: P.Stream s Char => Char -> Parser s Text +stringLiteral :: (P.Stream s, P.Token s ~ Char) => Char -> Parser s Text stringLiteral q = fmap Text.pack $ P.char q >> P.manyTill PL.charLiteral (P.char q) -integer :: P.Stream s Char => Parser s Integer +integer :: (P.Stream s, P.Token s ~ Char) => Parser s Integer integer = token PL.integer -- | An identifier in a Thrift file. -identifier :: P.Stream s Char => Parser s Text +identifier :: (P.Stream s, P.Token s ~ Char) => Parser s Text identifier = P.label "identifier" $ token $ do name <- (:) <$> (P.letterChar <|> P.char '_') - <*> many (P.alphaNumChar <|> P.oneOf "_.") - when (isReserved name) $ - P.unexpected name + <*> many (P.alphaNumChar <|> oneOf "_.") return (Text.pack name) -- | Top-level parser to parse complete Thrift documents. -program :: P.Stream s Char => Parser s (T.Program P.SourcePos) +program :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Program P.SourcePos) program = whiteSpace >> T.Program <$> many (header <* optionalSep) @@ -291,7 +298,7 @@ <* P.eof -- | Headers defined for the IDL. -header :: P.Stream s Char => Parser s (T.Header P.SourcePos) +header :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Header P.SourcePos) header = P.choice [ T.HeaderInclude <$> include , T.HeaderNamespace <$> namespace @@ -304,7 +311,7 @@ -- > -- > typedef common.Foo Bar -- -include :: P.Stream s Char => Parser s (T.Include P.SourcePos) +include :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Include P.SourcePos) include = reserved "include" >> withPosition (T.Include <$> literal) @@ -312,7 +319,8 @@ -- name used by the generated code for certain languages. -- -- > namespace py my_service.generated -namespace :: P.Stream s Char => Parser s (T.Namespace P.SourcePos) +namespace + :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Namespace P.SourcePos) namespace = P.choice [ reserved "namespace" >> withPosition (T.Namespace <$> (star <|> identifier) <*> identifier) @@ -340,7 +348,9 @@ -- | Convenience wrapper for parsers expecting a position. -- -- The position will be retrieved BEFORE the parser itself is executed. -withPosition :: P.Stream s Char => Parser s (P.SourcePos -> a) -> Parser s a +withPosition + :: (P.Stream s, P.Token s ~ Char) + => Parser s (P.SourcePos -> a) -> Parser s a withPosition p = P.getPosition >>= \pos -> p <*> pure pos @@ -350,7 +360,7 @@ -- > -- > parseFoo = withDocstring $ Foo <$> parseBar withDocstring - :: P.Stream s Char + :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Docstring -> P.SourcePos -> a) -> Parser s a withDocstring p = lastDocstring >>= \s -> do pos <- P.getPosition @@ -358,7 +368,8 @@ -- | A constant, type, or service definition. -definition :: P.Stream s Char => Parser s (T.Definition P.SourcePos) +definition + :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Definition P.SourcePos) definition = whiteSpace >> P.choice [ T.ConstDefinition <$> constant , T.TypeDefinition <$> typeDefinition @@ -367,7 +378,8 @@ -- | A type definition. -typeDefinition :: P.Stream s Char => Parser s (T.Type P.SourcePos) +typeDefinition + :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Type P.SourcePos) typeDefinition = P.choice [ T.TypedefType <$> typedef , T.EnumType <$> enum @@ -381,7 +393,7 @@ -- | A typedef is just an alias for another type. -- -- > typedef common.Foo Bar -typedef :: P.Stream s Char => Parser s (T.Typedef P.SourcePos) +typedef :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Typedef P.SourcePos) typedef = reserved "typedef" >> withDocstring (T.Typedef <$> typeReference <*> identifier <*> typeAnnotations) @@ -390,8 +402,8 @@ -- -- > enum Role { -- > User = 1, Admin --- > } -enum :: P.Stream s Char => Parser s (T.Enum P.SourcePos) +-- > +enum :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Enum P.SourcePos) enum = reserved "enum" >> withDocstring ( T.Enum <$> identifier @@ -406,7 +418,7 @@ -- > 1: string name -- > 2: Role role = Role.User; -- > } -struct :: P.Stream s Char => Parser s (T.Struct P.SourcePos) +struct :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Struct P.SourcePos) struct = reserved "struct" >> withDocstring ( T.Struct <$> identifier @@ -421,7 +433,7 @@ -- > 1: string stringValue; -- > 2: i32 intValue; -- > } -union :: P.Stream s Char => Parser s (T.Union P.SourcePos) +union :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Union P.SourcePos) union = reserved "union" >> withDocstring ( T.Union <$> identifier @@ -436,7 +448,8 @@ -- > 1: optional string message -- > 2: required string username -- > } -exception :: P.Stream s Char => Parser s (T.Exception P.SourcePos) +exception + :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Exception P.SourcePos) exception = reserved "exception" >> withDocstring ( T.Exception <$> identifier @@ -446,7 +459,8 @@ -- | Whether a field is @required@ or @optional@. -fieldRequiredness :: P.Stream s Char => Parser s T.FieldRequiredness +fieldRequiredness + :: (P.Stream s, P.Token s ~ Char) => Parser s T.FieldRequiredness fieldRequiredness = P.choice [ reserved "required" *> pure T.Required , reserved "optional" *> pure T.Optional @@ -454,7 +468,7 @@ -- | A struct field. -field :: P.Stream s Char => Parser s (T.Field P.SourcePos) +field :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Field P.SourcePos) field = withDocstring $ T.Field <$> optional (integer <* colon) @@ -467,7 +481,7 @@ -- | A value defined inside an @enum@. -enumDef :: P.Stream s Char => Parser s (T.EnumDef P.SourcePos) +enumDef :: (P.Stream s, P.Token s ~ Char) => Parser s (T.EnumDef P.SourcePos) enumDef = withDocstring $ T.EnumDef <$> identifier @@ -478,7 +492,7 @@ -- | An string-only enum. These are a deprecated feature of Thrift and shouldn't -- be used. -senum :: P.Stream s Char => Parser s (T.Senum P.SourcePos) +senum :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Senum P.SourcePos) senum = reserved "senum" >> withDocstring ( T.Senum <$> identifier @@ -490,7 +504,7 @@ -- | A 'const' definition. -- -- > const i32 code = 1; -constant :: P.Stream s Char => Parser s (T.Const P.SourcePos) +constant :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Const P.SourcePos) constant = do reserved "const" withDocstring $ @@ -502,19 +516,23 @@ -- | A constant value literal. -constantValue :: P.Stream s Char => Parser s (T.ConstValue P.SourcePos) +constantValue + :: (P.Stream s, P.Token s ~ Char) => Parser s (T.ConstValue P.SourcePos) constantValue = withPosition $ P.choice [ P.try (P.string "0x") >> T.ConstInt <$> token PL.hexadecimal - , either T.ConstInt T.ConstFloat - <$> token (PL.signed whiteSpace PL.number) + , either T.ConstFloat T.ConstInt + <$> token signedNumber , T.ConstLiteral <$> literal , T.ConstIdentifier <$> identifier , T.ConstList <$> constList , T.ConstMap <$> constMap ] + where + signedNumber = floatingOrInteger <$> PL.signed whiteSpace PL.number -constList :: P.Stream s Char => Parser s [T.ConstValue P.SourcePos] +constList + :: (P.Stream s, P.Token s ~ Char) => Parser s [T.ConstValue P.SourcePos] constList = symbolic '[' *> loop [] where loop xs = P.choice @@ -526,7 +544,7 @@ constMap - :: P.Stream s Char + :: (P.Stream s, P.Token s ~ Char) => Parser s [(T.ConstValue P.SourcePos, T.ConstValue P.SourcePos)] constMap = symbolic '{' *> loop [] where @@ -539,7 +557,7 @@ constantValuePair - :: P.Stream s Char + :: (P.Stream s, P.Token s ~ Char) => Parser s (T.ConstValue P.SourcePos, T.ConstValue P.SourcePos) constantValuePair = (,) <$> (constantValue <* colon) @@ -547,7 +565,9 @@ -- | A reference to a built-in or defined field. -typeReference :: P.Stream s Char => Parser s (T.TypeReference P.SourcePos) +typeReference + :: (P.Stream s, P.Token s ~ Char) + => Parser s (T.TypeReference P.SourcePos) typeReference = P.choice [ baseType , containerType @@ -556,7 +576,8 @@ baseType - :: P.Stream s Char => Parser s (T.TypeReference P.SourcePos) + :: (P.Stream s, P.Token s ~ Char) + => Parser s (T.TypeReference P.SourcePos) baseType = withPosition $ P.choice [reserved s *> (v <$> typeAnnotations) | (s, v) <- bases] where @@ -575,7 +596,8 @@ containerType - :: P.Stream s Char => Parser s (T.TypeReference P.SourcePos) + :: (P.Stream s, P.Token s ~ Char) + => Parser s (T.TypeReference P.SourcePos) containerType = withPosition $ P.choice [mapType, setType, listType] <*> typeAnnotations where @@ -590,7 +612,7 @@ -- > service MyService { -- > // ... -- > } -service :: P.Stream s Char => Parser s (T.Service P.SourcePos) +service :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Service P.SourcePos) service = do reserved "service" withDocstring $ @@ -605,7 +627,8 @@ -- -- > Foo getFoo() throws (1: FooDoesNotExist doesNotExist); -- > oneway void putBar(1: Bar bar); -function :: P.Stream s Char => Parser s (T.Function P.SourcePos) +function + :: (P.Stream s, P.Token s ~ Char) => Parser s (T.Function P.SourcePos) function = withDocstring $ T.Function <$> ((reserved "oneway" *> pure True) <|> pure False) @@ -623,16 +646,17 @@ -- -- These do not usually affect code generation but allow for custom logic if -- writing your own code generator. -typeAnnotations :: P.Stream s Char => Parser s [T.TypeAnnotation] +typeAnnotations + :: (P.Stream s, P.Token s ~ Char) => Parser s [T.TypeAnnotation] typeAnnotations = parens (many typeAnnotation) <|> pure [] -typeAnnotation :: P.Stream s Char => Parser s T.TypeAnnotation +typeAnnotation :: (P.Stream s, P.Token s ~ Char) => Parser s T.TypeAnnotation typeAnnotation = T.TypeAnnotation <$> identifier <*> (optional (equals *> literal) <* optionalSep) -optionalSep :: P.Stream s Char => Parser s () +optionalSep :: (P.Stream s, P.Token s ~ Char) => Parser s () optionalSep = void $ optional (comma <|> semi) diff --git a/src/Language/Thrift/Pretty.hs b/src/Language/Thrift/Pretty.hs --- a/src/Language/Thrift/Pretty.hs +++ b/src/Language/Thrift/Pretty.hs @@ -73,8 +73,8 @@ linebreak, magenta, nest, plain, space, vsep, yellow, (<$$>), (<$>), (<+>), (<>)) -import qualified Language.Thrift.Internal.Types as T -import qualified Text.PrettyPrint.ANSI.Leijen as P +import qualified Language.Thrift.Internal.AST as T +import qualified Text.PrettyPrint.ANSI.Leijen as P -- | Configuration for the pretty printer. data Config = Config diff --git a/src/Language/Thrift/Types.hs b/src/Language/Thrift/Types.hs --- a/src/Language/Thrift/Types.hs +++ b/src/Language/Thrift/Types.hs @@ -6,22 +6,10 @@ -- Maintainer : Abhinav Gupta -- Stability : experimental -- --- This module defines types that compose a Thrift IDL file. --- --- Most of the types have an optional @srcAnnot@ parameter that represents a --- source annotation. The parser produces types annotated with their position --- in the Thrift file ('Text.Megaparsec.SourcePos'). When constructing the AST --- by hand, you can use @()@. The types are @Functor@s so you can use 'fmap' --- to change the annotation on all objects in a tree. --- --- Lenses for attributes of most types are provided for use with the `lens` --- library. --- --- Types representing the AST all have 'Text.PrettyPrint.ANSI.Leijen.Pretty' --- instances to go with them. +-- This module is deprecated. Use "Language.Thrift.AST" instead. module Language.Thrift.Types - ( module Language.Thrift.Internal.Types + {-# DEPRECATED "This module will be removed in a future release." #-} + ( module Language.Thrift.AST ) where -import Language.Thrift.Internal.Types -import Language.Thrift.Pretty () +import Language.Thrift.AST diff --git a/test/Language/Thrift/ASTSpec.hs b/test/Language/Thrift/ASTSpec.hs new file mode 100644 --- /dev/null +++ b/test/Language/Thrift/ASTSpec.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +module Language.Thrift.ASTSpec (spec) where + +import Control.Monad (void) +import Test.Hspec +import Test.Hspec.QuickCheck +import Text.Megaparsec (SourcePos) + +import qualified Text.PrettyPrint.ANSI.Leijen as PP (Doc, plain) + +import Language.Thrift.Arbitrary () +import TestUtils + +import qualified Language.Thrift.Parser as P +import qualified Language.Thrift.Pretty as PP + +spec :: Spec +spec = + describe "Parser and Printer" $ do + + prop "can round-trip type references" $ + roundtrip PP.typeReference P.typeReference + + prop "can round-trip constant values" $ + roundtrip PP.constantValue P.constantValue + + prop "can round-trip typedefs" $ + roundtrip PP.typedef (P.whiteSpace >> P.typedef) + + prop "can round-trip enums" $ + roundtrip PP.enum (P.whiteSpace >> P.enum) + + prop "can round-trip structs" $ + roundtrip PP.struct (P.whiteSpace >> P.struct) + + prop "can round-trip unions" $ + roundtrip PP.union (P.whiteSpace >> P.union) + + prop "can round-trip exceptions" $ + roundtrip PP.exception (P.whiteSpace >> P.exception) + + prop "can round-trip senums" $ + roundtrip PP.senum (P.whiteSpace >> P.senum) + + prop "can round-trip services" $ + roundtrip PP.service (P.whiteSpace >> P.service) + + prop "can round-trip constants" $ + roundtrip PP.constant (P.whiteSpace >> P.constant) + + prop "can round-trip includes" $ + roundtrip (const PP.include) (P.whiteSpace >> P.include) + + prop "can round-trip namespaces" $ + roundtrip (const PP.namespace) (P.whiteSpace >> P.namespace) + + prop "can round-trip documents" $ + roundtrip PP.program P.program + + +roundtrip + :: (Show (n ()), Eq (n ()), Functor n) + => (PP.Config -> n () -> PP.Doc) + -> Parser (n SourcePos) + -> n () + -> IO () +roundtrip printer parser value = + assertParses (void `fmap` parser) value + (show . PP.plain $ printer (PP.Config 4) value) diff --git a/test/Language/Thrift/Arbitrary.hs b/test/Language/Thrift/Arbitrary.hs --- a/test/Language/Thrift/Arbitrary.hs +++ b/test/Language/Thrift/Arbitrary.hs @@ -17,9 +17,7 @@ import qualified Data.Text as Text -import Language.Thrift.Internal.Reserved (isReserved) - -import qualified Language.Thrift.Types as T +import qualified Language.Thrift.AST as T #ifdef MIN_VERSION_QuickCheck #if !MIN_VERSION_QuickCheck(2, 8, 0) @@ -66,15 +64,6 @@ shrink (Docstring t) = Docstring <$> shrink t -newtype Identifier = Identifier { getIdentifier :: Text } - deriving (Show, Typeable, Generic) - -instance Arbitrary Identifier where - arbitrary = Identifier <$> arbitrary `suchThat` (not . isReserved . Text.unpack) - - shrink (Identifier t) = - [Identifier t' | t' <- shrink t, not (isReserved (Text.unpack t'))] - ------------------------------------------------------------------------------ instance Arbitrary (T.Program ()) where @@ -94,11 +83,7 @@ instance Arbitrary (T.Namespace ()) where shrink = genericShrink - arbitrary = - T.Namespace - <$> elements scopes - <*> (getIdentifier <$> arbitrary) - <*> pure () + arbitrary = T.Namespace <$> elements scopes <*> arbitrary <*> pure () where scopes = ["*", "py", "rb", "java", "hs", "cpp"] @@ -116,8 +101,8 @@ arbitrary = T.Const <$> arbitrary - <*> (getIdentifier <$> arbitrary) <*> arbitrary + <*> arbitrary <*> (getDocstring <$> arbitrary) <*> pure () @@ -125,12 +110,9 @@ shrink = genericShrink arbitrary = T.Service - <$> (getIdentifier <$> arbitrary) - <*> frequency - [ (1, return Nothing) - , (3, Just . getIdentifier <$> arbitrary) - ] + <$> arbitrary <*> arbitrary + <*> arbitrary <*> halfSize arbitrary <*> (getDocstring <$> arbitrary) <*> pure () @@ -141,7 +123,7 @@ T.Function <$> arbitrary <*> halfSize arbitrary - <*> (getIdentifier <$> arbitrary) + <*> arbitrary <*> halfSize arbitrary <*> halfSize arbitrary <*> halfSize arbitrary @@ -163,7 +145,7 @@ shrink = genericShrink arbitrary = T.Typedef <$> arbitrary - <*> (getIdentifier <$> arbitrary) + <*> arbitrary <*> halfSize arbitrary <*> (getDocstring <$> arbitrary) <*> pure () @@ -171,7 +153,7 @@ instance Arbitrary (T.Enum ()) where shrink = genericShrink arbitrary = T.Enum - <$> (getIdentifier <$> arbitrary) + <$> arbitrary <*> arbitrary <*> halfSize arbitrary <*> (getDocstring <$> arbitrary) @@ -181,7 +163,7 @@ shrink = genericShrink arbitrary = T.EnumDef - <$> (getIdentifier <$> arbitrary) + <$> arbitrary <*> arbitrary <*> halfSize arbitrary <*> (getDocstring <$> arbitrary) @@ -190,7 +172,7 @@ instance Arbitrary (T.Struct ()) where shrink = genericShrink arbitrary = T.Struct - <$> (getIdentifier <$> arbitrary) + <$> arbitrary <*> arbitrary <*> halfSize arbitrary <*> (getDocstring <$> arbitrary) @@ -199,7 +181,7 @@ instance Arbitrary (T.Union ()) where shrink = genericShrink arbitrary = T.Union - <$> (getIdentifier <$> arbitrary) + <$> arbitrary <*> arbitrary <*> halfSize arbitrary <*> (getDocstring <$> arbitrary) @@ -208,7 +190,7 @@ instance Arbitrary (T.Exception ()) where shrink = genericShrink arbitrary = T.Exception - <$> (getIdentifier <$> arbitrary) + <$> arbitrary <*> arbitrary <*> halfSize arbitrary <*> (getDocstring <$> arbitrary) @@ -217,7 +199,7 @@ instance Arbitrary (T.Senum ()) where shrink = genericShrink arbitrary = T.Senum - <$> (getIdentifier <$> arbitrary) + <$> arbitrary <*> arbitrary <*> halfSize arbitrary <*> (getDocstring <$> arbitrary) @@ -230,7 +212,7 @@ <$> (fmap getPositive <$> arbitrary) <*> arbitrary <*> halfSize arbitrary - <*> (getIdentifier <$> arbitrary) + <*> arbitrary <*> halfSize arbitrary <*> halfSize arbitrary <*> (getDocstring <$> arbitrary) @@ -239,8 +221,7 @@ instance Arbitrary (T.TypeReference ()) where shrink = genericShrink arbitrary = oneof - [ T.DefinedType <$> (getIdentifier <$> arbitrary) - <*> pure () + [ T.DefinedType <$> arbitrary <*> pure () , halfSize $ T.StringType <$> arbitrary <*> pure () , halfSize $ T.BinaryType <$> arbitrary <*> pure () , halfSize $ T.SListType <$> arbitrary <*> pure () @@ -261,7 +242,7 @@ instance Arbitrary T.TypeAnnotation where shrink = genericShrink - arbitrary = T.TypeAnnotation <$> (getIdentifier <$> arbitrary) <*> arbitrary + arbitrary = T.TypeAnnotation <$> arbitrary <*> arbitrary newtype BasicConstValue = BasicConstValue { @@ -275,8 +256,7 @@ [ T.ConstFloat <$> choose (0.0, 10000.0) <*> pure () , T.ConstInt <$> arbitrary <*> pure () , T.ConstLiteral <$> arbitrary <*> pure () - , T.ConstIdentifier <$> (getIdentifier <$> arbitrary) - <*> pure () + , T.ConstIdentifier <$> arbitrary <*> pure () ] -- | newtype wrapper around const values so that we're not generating lists diff --git a/test/Language/Thrift/ParserSpec.hs b/test/Language/Thrift/ParserSpec.hs --- a/test/Language/Thrift/ParserSpec.hs +++ b/test/Language/Thrift/ParserSpec.hs @@ -14,8 +14,8 @@ import TestUtils +import qualified Language.Thrift.AST as T import qualified Language.Thrift.Parser as P -import qualified Language.Thrift.Types as T spec :: Spec spec = describe "Parser" $ do @@ -79,13 +79,6 @@ , "map" , "something_else" ] - - it "cannot parse reserved keywords in names" $ - parseFailureCases P.program - [ "enum struct {}" - , "strut Foo { 1: required string service }" - ] - parseFailureCases :: Show a => Parser a -> [String] -> Expectation parseFailureCases p = mapM_ (p `shouldNotParse`) diff --git a/test/Language/Thrift/TypesSpec.hs b/test/Language/Thrift/TypesSpec.hs deleted file mode 100644 --- a/test/Language/Thrift/TypesSpec.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Language.Thrift.TypesSpec (spec) where - -import Control.Monad (void) -import Test.Hspec -import Test.Hspec.QuickCheck -import Text.Megaparsec (SourcePos) - -import qualified Text.PrettyPrint.ANSI.Leijen as PP (Doc, plain) - -import Language.Thrift.Arbitrary () -import TestUtils - -import qualified Language.Thrift.Parser as P -import qualified Language.Thrift.Pretty as PP - -spec :: Spec -spec = - describe "Parser and Printer" $ do - - prop "can round-trip type references" $ - roundtrip PP.typeReference P.typeReference - - prop "can round-trip constant values" $ - roundtrip PP.constantValue P.constantValue - - prop "can round-trip typedefs" $ - roundtrip PP.typedef (P.whiteSpace >> P.typedef) - - prop "can round-trip enums" $ - roundtrip PP.enum (P.whiteSpace >> P.enum) - - prop "can round-trip structs" $ - roundtrip PP.struct (P.whiteSpace >> P.struct) - - prop "can round-trip unions" $ - roundtrip PP.union (P.whiteSpace >> P.union) - - prop "can round-trip exceptions" $ - roundtrip PP.exception (P.whiteSpace >> P.exception) - - prop "can round-trip senums" $ - roundtrip PP.senum (P.whiteSpace >> P.senum) - - prop "can round-trip services" $ - roundtrip PP.service (P.whiteSpace >> P.service) - - prop "can round-trip constants" $ - roundtrip PP.constant (P.whiteSpace >> P.constant) - - prop "can round-trip includes" $ - roundtrip (const PP.include) (P.whiteSpace >> P.include) - - prop "can round-trip namespaces" $ - roundtrip (const PP.namespace) (P.whiteSpace >> P.namespace) - - prop "can round-trip documents" $ - roundtrip PP.program P.program - - -roundtrip - :: (Show (n ()), Eq (n ()), Functor n) - => (PP.Config -> n () -> PP.Doc) - -> Parser (n SourcePos) - -> n () - -> IO () -roundtrip printer parser value = - assertParses (void `fmap` parser) value - (show . PP.plain $ printer (PP.Config 4) value) diff --git a/test/TestUtils.hs b/test/TestUtils.hs --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -13,7 +13,7 @@ type Parser = T.Parser String -parse :: Parser a -> String -> Either P.ParseError a +parse :: Parser a -> String -> Either (P.ParseError Char P.Dec) a parse parser = P.parse (T.runParser parser) "memory" -- | @assertParses parser expected input@ will assert that running @parser@ on