diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,11 @@ -0.8.0.0 -======= +0.8.0.1 (2016-05-24) +==================== +- Build with GHC 8. + +0.8.0.0 (2016-02-09) +==================== + This release contains breaking changes. The number of transitive dependencies has been reduced significantly. @@ -11,44 +16,44 @@ provided but prisms are not. Use `Control.Lens.makePrisms` to derive your own if needed. -0.7.0.1 -======= +0.7.0.1 (2016-01-27) +==================== - Drop use of `TemplateHaskell`. -0.7.0.0 -======= +0.7.0.0 (2016-01-15) +==================== -- Added source annotations to all `TypeReference` and `ConstValue` - constructors. +- Added source annotations to all `TypeReference` and + `ConstValue` constructors. - Added `name` and `srcAnnot` lenses for `Type` and `Definition`. -0.6.2.0 -======= +0.6.2.0 (2016-01-05) +==================== - Use more concrete types for lenses which don't need overloading. -0.6.1.0 -======= +0.6.1.0 (2016-01-03) +==================== - Output generated by the `ansi-wl-pprint` pretty printer will be colored using ANSI escape codes. -0.6.0.1 -======= +0.6.0.1 (2016-01-02) +==================== - Export `Pretty` instances from `Language.Thrift.Types` instead of requiring a separate import of the corresponding `Pretty` module. -0.6.0.0 -======= +0.6.0.0 (2016-01-02) +==================== - Added a pretty printer based on `ansi-wl-pprint`. - Both pretty printing modules now export instances of `Pretty` for relevant elements of the AST. These instances use `defaultConfig` for printing. -0.5.0.0 -======= +0.5.0.0 (2015-12-27) +==================== The AST representation has been overhauled to be more consistent and accessible. As a result, this release contains a number of breaking changes: @@ -64,15 +69,15 @@ `typedefType` to `typedefTargetType`, `fieldType` to `fieldValueType`, and `fieldDefault` to `fieldDefaultValue`. - Hide `function` parser and pretty printer. -- Moved type annotations for defined types into the records for the types - themselves. +- Moved type annotations for defined types into the records for the + types themselves. Other changes: - Added lenses and prisms for AST types where appropriate. -- Parsing will fail if the end of the document is not reached when the parser - stops. This fixes the bug where the parser would stop half way through a - file when it saw a recoverable error. +- Parsing will fail if the end of the document is not reached when the + parser stops. This fixes the bug where the parser would stop half way + through a file when it saw a recoverable error. - Added source annotations to headers, type references (`DefinedType`) and constant value references (`ConstIdentifer`). - Added `i8` as an alias for `byte`. @@ -82,37 +87,38 @@ semicolon or a comma. - Drop dependency on mtl. -0.4.0.0 -======= +0.4.0.0 (2015-08-02) +==================== - Add pretty printing module. - Parsers of different constructors are no longer exported by the parsing - module; instead only the parsers for their corresponding types are - exported. + module; instead only the parsers for their corresponding types + are exported. - Rename record for field requiredness from `fieldRequiredNess` to `fieldRequiredness`. -0.3.0.0 -======= +0.3.0.0 (2015-07-31) +==================== - 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. +- Add `Language.Thrift.Parser.Trifecta` with a standard + Trifecta-based parser. -0.2.0.0 -======= +0.2.0.0 (2015-06-12) +==================== - Track starting positions in source annotations. - Move docs to a separate field. -0.1.0.1 -======= +0.1.0.1 (2015-06-02) +==================== - Allow `base` 4.9. -0.1.0.0 -======= +0.1.0.0 (2015-04-05) +==================== - Initial release. + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Abhinav Gupta +Copyright (c) 2016, Abhinav Gupta All rights reserved. diff --git a/Language/Thrift/Internal/Types.hs b/Language/Thrift/Internal/Types.hs deleted file mode 100644 --- a/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/Language/Thrift/Parser.hs b/Language/Thrift/Parser.hs deleted file mode 100644 --- a/Language/Thrift/Parser.hs +++ /dev/null @@ -1,626 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# 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 - ( parseFromFile - , parse - , thriftIDL - - -- * Components - - , program - - , header - , include - , namespace - - , definition - , constant - , typeDefinition - , service - - , typedef - , enum - , struct - , union - , exception - , senum - - , typeReference - , constantValue - - , docstring - - -- * Parser - - , Parser - , runParser - , whiteSpace - ) where - -import Control.Applicative -import Control.Monad -import Control.Monad.Trans.State (StateT) -import Data.Text (Text) - -import qualified Control.Monad.Trans.State as State -import qualified Data.Text as Text -import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Lexer as PL - -import qualified Language.Thrift.Types as T - --- | Keeps track of the last docstring seen by the system so that we can --- attach it to entities. -data State = State - { stateDocstring :: T.Docstring - } - deriving (Show, Eq) - --- | Underlying Parser type. -type Parser s = StateT State (P.Parsec s) - --- | Evaluates the underlying parser with a default state and get the Megaparsec --- parser. -runParser :: Parser s a -> P.Parsec 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)) - --- | @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) -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 = runParser program - - -clearDocstring :: 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 = do - s <- State.gets stateDocstring - clearDocstring - return s - --- | Optional whitespace. -whiteSpace :: P.Stream s Char => Parser s () -whiteSpace = someSpace <|> pure () - --- | Required whitespace. -someSpace :: P.Stream s Char => Parser s () -someSpace = P.skipSome $ readDocstring <|> skipComments <|> skipSpace - where - readDocstring = do - s <- docstring - unless (Text.null s) $ - State.modify' (\st -> st { stateDocstring = Just s}) - - skipSpace = P.choice - [ P.newline *> clearDocstring - , P.skipSome P.spaceChar - ] - - skipComments = P.choice - [ P.char '#' *> skipLine - , P.try (P.string "//") *> skipLine - , P.try (P.string "/*") *> skipCStyleComment - ] *> clearDocstring - - 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 `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 = loop - where - loop 0 = return () - loop n = - ( do - void $ P.try p - loop $! n - 1 - ) <|> return () - -hspace :: P.Stream s Char => Parser s () -hspace = void $ P.oneOf " \t" - --- | A javadoc-style docstring. --- --- > /** --- > * foo --- > */ --- --- 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 = do - P.try (P.string "/**") >> P.skipMany hspace - indent <- P.sourceColumn <$> P.getPosition - isNewLine <- maybeEOL - chunks <- loop isNewLine (indent - 1) [] - return $! Text.intercalate "\n" chunks - where - maybeEOL = (P.eol >> return True) <|> return False - - commentChar = - P.noneOf "*\r\n" <|> - P.try (P.char '*' <* P.notFollowedBy (P.char '/')) - - loop shouldDedent maxDedent chunks = do - when shouldDedent $ - hspace `skipUpTo` maxDedent - finishComment <|> readDocLine - where - finishComment = do - P.try (P.skipMany hspace <* P.string "*/") - void $ optional P.spaceChar - return $! reverse chunks - readDocLine = do - -- Lines could have aligned *s at the start. - -- - -- /** - -- * foo - -- * bar - -- */ - -- - -- But only if we dedented. If we didn't, that's possibly because, - -- - -- /** foo [..] - -- - -- So if foo starts with "*", we don't want to drop that. - when shouldDedent . void $ - optional $ P.try (P.char '*' >> optional hspace) - - line <- Text.pack <$> P.many commentChar - - -- This line most likely ends with a newline but if it's the last - -- one, it could also be "foo */" - void (optional hspace >> maybeEOL) - - loop True maxDedent (line:chunks) - - -symbolic :: P.Stream s Char => Char -> Parser s () -symbolic c = void $ PL.symbol whiteSpace [c] - -token :: P.Stream 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 = 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 = symbolic ',' -semi = symbolic ';' -colon = symbolic ':' -equals = symbolic '=' - --- | Parses a reserved identifier and adds it to the collection of known --- reserved keywords. -reserved :: P.Stream s Char => String -> Parser s () -reserved name = P.label name $ token $ P.try $ do - void (P.string name) - P.notFollowedBy (P.alphaNumChar <|> P.oneOf "_.") - - --- | A string literal. @"hello"@ -literal :: P.Stream s Char => Parser s Text -literal = P.label "string literal" $ token $ - stringLiteral '"' <|> stringLiteral '\'' - -stringLiteral :: P.Stream 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 = token PL.integer - - --- | An identifier in a Thrift file. -identifier :: P.Stream s Char => Parser s Text -identifier = P.label "identifier" $ token $ do - name <- (:) - <$> (P.letterChar <|> P.char '_') - <*> many (P.alphaNumChar <|> P.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 = whiteSpace >> - T.Program - <$> many (header <* optionalSep) - <*> many (definition <* optionalSep) - <* P.eof - --- | Headers defined for the IDL. -header :: P.Stream s Char => Parser s (T.Header P.SourcePos) -header = P.choice - [ T.HeaderInclude <$> include - , T.HeaderNamespace <$> namespace - ] - - --- | The IDL includes another Thrift file. --- --- > include "common.thrift" --- > --- > typedef common.Foo Bar --- -include :: P.Stream s Char => Parser s (T.Include P.SourcePos) -include = reserved "include" >> withPosition (T.Include <$> literal) - - --- | Namespace directives allows control of the namespace or package --- 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.choice - [ reserved "namespace" >> - withPosition (T.Namespace <$> (star <|> identifier) <*> identifier) - , reserved "cpp_namespace" >> - withPosition (T.Namespace "cpp" <$> identifier) - , reserved "php_namespace" >> - withPosition (T.Namespace "php" <$> identifier) - , reserved "py_module" >> - withPosition (T.Namespace "py" <$> identifier) - , reserved "perl_package" >> - withPosition (T.Namespace "perl" <$> identifier) - , reserved "ruby_namespace" >> - withPosition (T.Namespace "rb" <$> identifier) - , reserved "java_package" >> - withPosition (T.Namespace "java" <$> identifier) - , reserved "cocoa_package" >> - withPosition (T.Namespace "cocoa" <$> identifier) - , reserved "csharp_namespace" >> - withPosition (T.Namespace "csharp" <$> identifier) - ] - where - star = symbolic '*' >> pure "*" - - --- | 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 = P.getPosition >>= \pos -> p <*> pure pos - - --- | Convenience wrapper for parsers that expect a docstring and a position. --- --- > data Foo = Foo { bar :: Bar, doc :: Docstring, pos :: Delta } --- > --- > parseFoo = withDocstring $ Foo <$> parseBar -withDocstring - :: P.Stream s Char - => Parser s (T.Docstring -> P.SourcePos -> a) -> Parser s a -withDocstring p = lastDocstring >>= \s -> do - pos <- P.getPosition - p <*> pure s <*> pure pos - - --- | A constant, type, or service definition. -definition :: P.Stream s Char => Parser s (T.Definition P.SourcePos) -definition = whiteSpace >> P.choice - [ T.ConstDefinition <$> constant - , T.TypeDefinition <$> typeDefinition - , T.ServiceDefinition <$> service - ] - - --- | A type definition. -typeDefinition :: P.Stream s Char => Parser s (T.Type P.SourcePos) -typeDefinition = P.choice - [ T.TypedefType <$> typedef - , T.EnumType <$> enum - , T.SenumType <$> senum - , T.StructType <$> struct - , T.UnionType <$> union - , T.ExceptionType <$> exception - ] - - --- | A typedef is just an alias for another type. --- --- > typedef common.Foo Bar -typedef :: P.Stream s Char => Parser s (T.Typedef P.SourcePos) -typedef = reserved "typedef" >> withDocstring - (T.Typedef <$> typeReference <*> identifier <*> typeAnnotations) - - --- | Enums are sets of named integer values. --- --- > enum Role { --- > User = 1, Admin --- > } -enum :: P.Stream s Char => Parser s (T.Enum P.SourcePos) -enum = reserved "enum" >> withDocstring - ( T.Enum - <$> identifier - <*> braces (many enumDef) - <*> typeAnnotations - ) - - --- | A @struct@. --- --- > struct User { --- > 1: string name --- > 2: Role role = Role.User; --- > } -struct :: P.Stream s Char => Parser s (T.Struct P.SourcePos) -struct = reserved "struct" >> withDocstring - ( T.Struct - <$> identifier - <*> braces (many field) - <*> typeAnnotations - ) - - --- | A @union@ of types. --- --- > union Value { --- > 1: string stringValue; --- > 2: i32 intValue; --- > } -union :: P.Stream s Char => Parser s (T.Union P.SourcePos) -union = reserved "union" >> withDocstring - ( T.Union - <$> identifier - <*> braces (many field) - <*> typeAnnotations - ) - - --- | An @exception@ that can be raised by service methods. --- --- > exception UserDoesNotExist { --- > 1: optional string message --- > 2: required string username --- > } -exception :: P.Stream s Char => Parser s (T.Exception P.SourcePos) -exception = reserved "exception" >> withDocstring - ( T.Exception - <$> identifier - <*> braces (many field) - <*> typeAnnotations - ) - - --- | Whether a field is @required@ or @optional@. -fieldRequiredness :: P.Stream s Char => Parser s T.FieldRequiredness -fieldRequiredness = P.choice - [ reserved "required" *> pure T.Required - , reserved "optional" *> pure T.Optional - ] - - --- | A struct field. -field :: P.Stream s Char => Parser s (T.Field P.SourcePos) -field = withDocstring $ - T.Field - <$> optional (integer <* colon) - <*> optional fieldRequiredness - <*> typeReference - <*> identifier - <*> optional (equals *> constantValue) - <*> typeAnnotations - <* optionalSep - - --- | A value defined inside an @enum@. -enumDef :: P.Stream s Char => Parser s (T.EnumDef P.SourcePos) -enumDef = withDocstring $ - T.EnumDef - <$> identifier - <*> optional (equals *> PL.signed whiteSpace integer) - <*> typeAnnotations - <* optionalSep - - --- | 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 = reserved "senum" >> withDocstring - ( T.Senum - <$> identifier - <*> braces (many (literal <* optionalSep)) - <*> typeAnnotations - ) - - --- | A 'const' definition. --- --- > const i32 code = 1; -constant :: P.Stream s Char => Parser s (T.Const P.SourcePos) -constant = do - reserved "const" - withDocstring $ - T.Const - <$> typeReference - <*> (identifier <* equals) - <*> constantValue - <* optionalSep - - --- | A constant value literal. -constantValue :: P.Stream 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) - , T.ConstLiteral <$> literal - , T.ConstIdentifier <$> identifier - , T.ConstList <$> constList - , T.ConstMap <$> constMap - ] - - -constList :: P.Stream s Char => Parser s [T.ConstValue P.SourcePos] -constList = symbolic '[' *> loop [] - where - loop xs = P.choice - [ symbolic ']' *> return (reverse xs) - , (:) <$> (constantValue <* optionalSep) - <*> pure xs - >>= loop - ] - - -constMap - :: P.Stream s Char - => Parser s [(T.ConstValue P.SourcePos, T.ConstValue P.SourcePos)] -constMap = symbolic '{' *> loop [] - where - loop xs = P.choice [ - symbolic '}' *> return (reverse xs) - , (:) <$> (constantValuePair <* optionalSep) - <*> pure xs - >>= loop - ] - - -constantValuePair - :: P.Stream s Char - => Parser s (T.ConstValue P.SourcePos, T.ConstValue P.SourcePos) -constantValuePair = - (,) <$> (constantValue <* colon) - <*> (constantValue <* optionalSep) - - --- | A reference to a built-in or defined field. -typeReference :: P.Stream s Char => Parser s (T.TypeReference P.SourcePos) -typeReference = P.choice - [ baseType - , containerType - , withPosition (T.DefinedType <$> identifier) - ] - - -baseType - :: P.Stream s Char => Parser s (T.TypeReference P.SourcePos) -baseType = withPosition $ - P.choice [reserved s *> (v <$> typeAnnotations) | (s, v) <- bases] - where - bases = - [ ("string", T.StringType) - , ("binary", T.BinaryType) - , ("slist", T.SListType) - , ("bool", T.BoolType) - , ("byte", T.ByteType) - , ("i8", T.ByteType) - , ("i16", T.I16Type) - , ("i32", T.I32Type) - , ("i64", T.I64Type) - , ("double", T.DoubleType) - ] - - -containerType - :: P.Stream s Char => Parser s (T.TypeReference P.SourcePos) -containerType = withPosition $ - P.choice [mapType, setType, listType] <*> typeAnnotations - where - mapType = reserved "map" >> - angles (T.MapType <$> (typeReference <* comma) <*> typeReference) - setType = reserved "set" >> angles (T.SetType <$> typeReference) - listType = reserved "list" >> angles (T.ListType <$> typeReference) - - --- | A service. --- --- > service MyService { --- > // ... --- > } -service :: P.Stream s Char => Parser s (T.Service P.SourcePos) -service = do - reserved "service" - withDocstring $ - T.Service - <$> identifier - <*> optional (reserved "extends" *> identifier) - <*> braces (many function) - <*> typeAnnotations - - --- | A function defined inside a service. --- --- > Foo getFoo() throws (1: FooDoesNotExist doesNotExist); --- > oneway void putBar(1: Bar bar); -function :: P.Stream s Char => Parser s (T.Function P.SourcePos) -function = withDocstring $ - T.Function - <$> ((reserved "oneway" *> pure True) <|> pure False) - <*> ((reserved "void" *> pure Nothing) <|> Just <$> typeReference) - <*> identifier - <*> parens (many field) - <*> optional (reserved "throws" *> parens (many field)) - <*> typeAnnotations - <* optionalSep - - --- | 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 :: P.Stream s Char => Parser s [T.TypeAnnotation] -typeAnnotations = parens (many typeAnnotation) <|> pure [] - - -typeAnnotation :: P.Stream s Char => Parser s T.TypeAnnotation -typeAnnotation = - T.TypeAnnotation - <$> identifier - <*> (optional (equals *> literal) <* optionalSep) - - -optionalSep :: P.Stream s Char => Parser s () -optionalSep = void $ optional (comma <|> semi) diff --git a/Language/Thrift/Pretty.hs b/Language/Thrift/Pretty.hs deleted file mode 100644 --- a/Language/Thrift/Pretty.hs +++ /dev/null @@ -1,445 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Language.Thrift.Pretty --- Copyright : (c) Abhinav Gupta 2015 --- License : BSD3 --- --- Maintainer : Abhinav Gupta --- Stability : experimental --- --- This module provides a pretty printer for Thrift IDLs. Most of the printers --- defined in this module produce output highlighted using ANSI escape codes. --- Get plain output by using 'Text.PrettyPrint.ANSI.Leijen.plain'. --- --- Use 'prettyPrintHighlighted' to produce output highlighted using ANSI escape --- codes. Note that this output will be unparseable and is suitable for printing --- inside a compatible terminal only. Use 'prettyPrint' if you don't want --- highlighted output. --- --- The behavior of the printer can be customized using 'Config' objects. --- --- The module also exports instances of the 'Pretty' typeclass for elements of --- the AST. -module Language.Thrift.Pretty - ( - prettyPrintHighlighted - , prettyPrint - - -- * Components - - , program - - , header - , include - , namespace - - , definition - , constant - , typeDefinition - , service - - , typedef - , enum - , struct - , union - , exception - , senum - - , typeReference - , constantValue - - , docstring - - -- * Configuration - - , Config(..) - , defaultConfig - ) where - -#if __GLASGOW_HASKELL__ >= 709 -import Prelude hiding ((<$>)) -#endif - -import Data.Text (Text) -import qualified Data.Text as Text - -import Text.PrettyPrint.ANSI.Leijen (Doc, Pretty (..), align, bold, cyan, - double, dquotes, dullblue, empty, enclose, - group, hcat, hsep, integer, line, - linebreak, magenta, nest, plain, space, - vsep, yellow, (<$$>), (<$>), (<+>), (<>)) - -import qualified Language.Thrift.Internal.Types as T -import qualified Text.PrettyPrint.ANSI.Leijen as P - --- | Configuration for the pretty printer. -data Config = Config - { indentWidth :: Int - -- ^ Number of spaces to use for indentation. - } deriving (Show, Ord, Eq) - - --- | Default pretty printing configuration. -defaultConfig :: Config -defaultConfig = Config 4 - --- | Top-level pretty printer for Thrift documents that uses the default --- configuration ('defaultConfig') for pretty printing. -prettyPrint :: T.Program ann -> Doc -prettyPrint = plain . prettyPrintHighlighted - --- | Top-level pretty printer for Thrift documents. -prettyPrintHighlighted :: T.Program ann -> Doc -prettyPrintHighlighted = program defaultConfig - --- | Pretty print a Thrift IDL. -program :: Config -> T.Program ann -> Doc -program c T.Program{..} = - ( if null programHeaders - then empty - else vsep (map header programHeaders) <$> line - ) <> map (definition c) programDefinitions `sepBy` (line <> line) - -instance Pretty (T.Program a) where - pretty = program defaultConfig - --- | Print the headers for a program. -header :: T.Header ann -> Doc -header (T.HeaderInclude inc) = include inc -header (T.HeaderNamespace ns) = namespace ns - -instance Pretty (T.Header a) where - pretty = header - -include :: T.Include ann -> Doc -include T.Include{..} = reserved "include" <+> literal includePath - -instance Pretty (T.Include a) where - pretty = include - -namespace :: T.Namespace ann -> Doc -namespace T.Namespace{..} = hsep - [reserved "namespace", text namespaceLanguage, text namespaceName] - -instance Pretty (T.Namespace a) where - pretty = namespace - --- | Print a constant, type, or service definition. -definition :: Config -> T.Definition ann -> Doc -definition c (T.ConstDefinition cd) = constant c cd -definition c (T.TypeDefinition def) = typeDefinition c def -definition c (T.ServiceDefinition s) = service c s - -instance Pretty (T.Definition a) where - pretty = definition defaultConfig - -constant :: Config -> T.Const ann -> Doc -constant c T.Const{..} = constDocstring $$ hsep - [ reserved "const" - , typeReference c constValueType - , declare constName - , equals - , constantValue c constValue - ] - -instance Pretty (T.Const a) where - pretty = constant defaultConfig - -service :: Config -> T.Service ann -> Doc -service c@Config{indentWidth} T.Service{..} = - serviceDocstring $$ - reserved "service" <+> declare serviceName <> extends <+> - block indentWidth (line <> line) (map (function c) serviceFunctions) <> - typeAnnots c serviceAnnotations - where - extends = case serviceExtends of - Nothing -> empty - Just name -> space <> reserved "extends" <+> text name - -instance Pretty (T.Service a) where - pretty = service defaultConfig - --- | Pretty print a function definition. --- -function :: Config -> T.Function ann -> Doc -function c@Config{indentWidth} T.Function{..} = functionDocstring $$ - oneway <> returnType <+> text functionName <> - encloseSep - indentWidth lparen rparen comma - (map (field c) functionParameters) <> - exceptions <> typeAnnots c functionAnnotations <> semi - where - exceptions = case functionExceptions of - Nothing -> empty - Just es -> space <> reserved "throws" <+> - encloseSep indentWidth lparen rparen comma (map (field c) es) - returnType = case functionReturnType of - Nothing -> reserved "void" - Just rt -> typeReference c rt - oneway = - if functionOneWay - then reserved "oneway" <> space - else empty - -instance Pretty (T.Function a) where - pretty = function defaultConfig - -typeDefinition :: Config -> T.Type ann -> Doc -typeDefinition c td = case td of - T.TypedefType t -> c `typedef` t - T.EnumType t -> c `enum` t - T.StructType t -> c `struct` t - T.UnionType t -> c `union` t - T.ExceptionType t -> c `exception` t - T.SenumType t -> c `senum` t - -instance Pretty (T.Type a) where - pretty = typeDefinition defaultConfig - -typedef :: Config -> T.Typedef ann -> Doc -typedef c T.Typedef{..} = typedefDocstring $$ - reserved "typedef" <+> typeReference c typedefTargetType <+> - declare typedefName <> typeAnnots c typedefAnnotations - -instance Pretty (T.Typedef a) where - pretty = typedef defaultConfig - -enum :: Config -> T.Enum ann -> Doc -enum c@Config{indentWidth} T.Enum{..} = enumDocstring $$ - reserved "enum" <+> declare enumName <+> - block indentWidth (comma <> line) (map (enumValue c) enumValues) - <> typeAnnots c enumAnnotations - -instance Pretty (T.Enum a) where - pretty = enum defaultConfig - -struct :: Config -> T.Struct ann -> Doc -struct c@Config{indentWidth} T.Struct{..} = structDocstring $$ - reserved "struct" <+> declare structName <+> - block indentWidth line (map (\f -> field c f <> semi) structFields) - <> typeAnnots c structAnnotations - -instance Pretty (T.Struct a) where - pretty = struct defaultConfig - -union :: Config -> T.Union ann -> Doc -union c@Config{indentWidth} T.Union{..} = unionDocstring $$ - reserved "union" <+> declare unionName <+> - block indentWidth line (map (\f -> field c f <> semi) unionFields) - <> typeAnnots c unionAnnotations - -instance Pretty (T.Union a) where - pretty = union defaultConfig - -exception :: Config -> T.Exception ann -> Doc -exception c@Config{indentWidth} T.Exception{..} = exceptionDocstring $$ - reserved "exception" <+> declare exceptionName <+> - block indentWidth line (map (\f -> field c f <> semi) exceptionFields) - <> typeAnnots c exceptionAnnotations - -instance Pretty (T.Exception a) where - pretty = exception defaultConfig - -senum :: Config -> T.Senum ann -> Doc -senum c@Config{indentWidth} T.Senum{..} = senumDocstring $$ - reserved "senum" <+> declare senumName <+> - encloseSep indentWidth lbrace rbrace comma (map literal senumValues) - <> typeAnnots c senumAnnotations - -instance Pretty (T.Senum a) where - pretty = senum defaultConfig - -field :: Config -> T.Field ann -> Doc -field c T.Field{..} = fieldDocstring $$ hcat - [ case fieldIdentifier of - Nothing -> empty - Just i -> yellow (integer i) <> colon <> space - , case fieldRequiredness of - Nothing -> empty - Just r -> requiredness r <> space - , typeReference c fieldValueType - , space - , text fieldName - , case fieldDefaultValue of - Nothing -> empty - Just v -> space <> equals <+> constantValue c v - , typeAnnots c fieldAnnotations - ] - -instance Pretty (T.Field a) where - pretty = field defaultConfig - -requiredness :: T.FieldRequiredness -> Doc -requiredness T.Optional = reserved "optional" -requiredness T.Required = reserved "required" - -instance Pretty T.FieldRequiredness where - pretty = requiredness - -enumValue :: Config -> T.EnumDef ann -> Doc -enumValue c T.EnumDef{..} = enumDefDocstring $$ - text enumDefName <> value <> typeAnnots c enumDefAnnotations - where - value = case enumDefValue of - Nothing -> empty - Just v -> space <> equals <+> integer v - -instance Pretty (T.EnumDef a) where - pretty = enumValue defaultConfig - --- | Pretty print a field type. -typeReference :: Config -> T.TypeReference ann -> Doc -typeReference c ft = case ft of - T.DefinedType t _ -> text t - - T.StringType anns _ -> reserved "string" <> typeAnnots c anns - T.BinaryType anns _ -> reserved "binary" <> typeAnnots c anns - T.SListType anns _ -> reserved "slist" <> typeAnnots c anns - T.BoolType anns _ -> reserved "bool" <> typeAnnots c anns - T.ByteType anns _ -> reserved "byte" <> typeAnnots c anns - T.I16Type anns _ -> reserved "i16" <> typeAnnots c anns - T.I32Type anns _ -> reserved "i32" <> typeAnnots c anns - T.I64Type anns _ -> reserved "i64" <> typeAnnots c anns - T.DoubleType anns _ -> reserved "double" <> typeAnnots c anns - - T.MapType k v anns _ -> - reserved "map" - <> enclose langle rangle - (typeReference c k <> comma <+> typeReference c v) - <> typeAnnots c anns - T.SetType v anns _ -> - reserved "set" - <> enclose langle rangle (typeReference c v) - <> typeAnnots c anns - T.ListType v anns _ -> - reserved "list" - <> enclose langle rangle (typeReference c v) - <> typeAnnots c anns - -instance Pretty (T.TypeReference a) where - pretty = typeReference defaultConfig - --- | Pretty print a constant value. -constantValue :: Config -> T.ConstValue ann -> Doc -constantValue c@Config{indentWidth} value = case value of - T.ConstInt i _ -> integer i - T.ConstFloat f _ -> double f - T.ConstLiteral l _ -> literal l - T.ConstIdentifier i _ -> text i - T.ConstList vs _ -> - encloseSep indentWidth lbracket rbracket comma $ map (constantValue c) vs - T.ConstMap vs _ -> - encloseSep indentWidth lbrace rbrace comma $ - map (\(k, v) -> constantValue c k <> colon <+> constantValue c v) vs - -instance Pretty (T.ConstValue a) where - pretty = constantValue defaultConfig - -typeAnnots :: Config -> [T.TypeAnnotation] -> Doc -typeAnnots _ [] = empty -typeAnnots Config{indentWidth} anns = - space <> encloseSep indentWidth lparen rparen comma (map typeAnnot anns) - -typeAnnot :: T.TypeAnnotation -> Doc -typeAnnot T.TypeAnnotation{..} = - text typeAnnotationName <> value - where - value = case typeAnnotationValue of - Nothing -> empty - Just v -> space <> equals <+> literal v - -instance Pretty T.TypeAnnotation where - pretty = typeAnnot - -literal :: Text -> Doc -literal = cyan . dquotes . text - -- TODO: escaping? - -text :: Text -> Doc -text = P.text . Text.unpack - -reserved :: String -> Doc -reserved = magenta . P.text - -op :: String -> Doc -op = yellow . P.text - -declare :: Text -> Doc -declare = bold . text - -($$) :: T.Docstring -> Doc -> Doc -($$) Nothing y = y -($$) (Just t) y = - if Text.null t' - then y - else docstring t' <$> y - where - t' = Text.strip t - -infixr 1 $$ - -docstring :: Text -> Doc -docstring = dullblue . wrapComments . Text.lines - where - wrapComments ls = align . vsep - $ text "/**" - : map (\l -> text " *" <+> text l) ls - ++ [text " */"] - -block :: Int -> Doc -> [Doc] -> Doc -block indent s items = enclose lbrace rbrace $ - nest indent (linebreak <> (items `sepBy` s)) <> linebreak - -sepBy :: [Doc] -> Doc -> Doc -sepBy [] _ = empty -sepBy [x] _ = x -sepBy (x:xs) s = x <> s <> sepBy xs s - -encloseSep :: Int -> Doc -> Doc -> Doc -> [Doc] -> Doc -encloseSep _ left right _ [] = left <> right -encloseSep _ left right _ [v] = left <> v <> right -encloseSep indent left right s vs = group $ - nest indent (left <$$> go vs) <$$> right - where go [] = empty - go [x] = x - go (x:xs) = (x <> s) <$> go xs - -lbrace :: Doc -lbrace = op "{" - -rbrace :: Doc -rbrace = op "}" - -lparen :: Doc -lparen = op "(" - -rparen :: Doc -rparen = op ")" - -lbracket :: Doc -lbracket = op "[" - -rbracket :: Doc -rbracket = op "]" - -langle :: Doc -langle = op "<" - -rangle :: Doc -rangle = op ">" - -comma :: Doc -comma = op "," - -semi :: Doc -semi = op ";" - -colon :: Doc -colon = op ":" - -equals :: Doc -equals = op "=" diff --git a/Language/Thrift/Types.hs b/Language/Thrift/Types.hs deleted file mode 100644 --- a/Language/Thrift/Types.hs +++ /dev/null @@ -1,27 +0,0 @@ --- | --- 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. --- --- 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.Types - ( module Language.Thrift.Internal.Types - ) where - -import Language.Thrift.Internal.Types -import Language.Thrift.Pretty () diff --git a/examples/Setup.hs b/examples/Setup.hs deleted file mode 100644 --- a/examples/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/language-thrift.cabal b/language-thrift.cabal --- a/language-thrift.cabal +++ b/language-thrift.cabal @@ -1,57 +1,68 @@ -name: language-thrift -version: 0.8.0.0 -cabal-version: >=1.10 -build-type: Simple -license: BSD3 -license-file: LICENSE -maintainer: Abhinav Gupta -homepage: https://github.com/abhinav/language-thrift -synopsis: Parser and pretty printer for the Thrift IDL format. -description: - This package provides a parser and pretty printer for the - . -category: Language -author: Abhinav Gupta +-- 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.1 +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 + . +category: Language +author: Abhinav Gupta + extra-source-files: - README.md CHANGES.md - examples/*.hs - test/data/*.txt + examples/generateHaskellTypes.hs + examples/reformatIDL.hs + README.md + test/data/docstring-1.txt + test/data/docstring-2.txt source-repository head type: git - location: git://github.com/abhinav/language-thrift.git + location: https://github.com/abhinav/language-thrift library + hs-source-dirs: + src exposed-modules: Language.Thrift.Parser Language.Thrift.Pretty Language.Thrift.Types build-depends: - base >=4.7 && <4.9, - ansi-wl-pprint >=0.6 && <0.7, - megaparsec >=4.0 && <5.0, - text >=1.2, - transformers -any + base >= 4.7 && < 5, + ansi-wl-pprint >= 0.6 && < 0.7, + megaparsec >= 4.0 && < 5.0, + text >= 1.2, + transformers default-language: Haskell2010 other-modules: Language.Thrift.Internal.Types + Paths_language_thrift ghc-options: -Wall test-suite spec type: exitcode-stdio-1.0 main-is: Main.hs build-depends: - base -any, - ansi-wl-pprint -any, - hspec >=2.0, - hspec-discover >=2.1, - megaparsec -any, - QuickCheck >=2.5, - text -any, - language-thrift -any + base >= 4.7 && < 5, + ansi-wl-pprint >= 0.6 && < 0.7, + megaparsec >= 4.0 && < 5.0, + text >= 1.2, + hspec >= 2.0, + hspec-discover >= 2.1, + language-thrift, + QuickCheck >= 2.5 default-language: Haskell2010 - hs-source-dirs: test + hs-source-dirs: + test other-modules: Language.Thrift.Arbitrary Language.Thrift.ParserSpec diff --git a/src/Language/Thrift/Internal/Types.hs b/src/Language/Thrift/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Thrift/Internal/Types.hs @@ -0,0 +1,793 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Language/Thrift/Parser.hs @@ -0,0 +1,626 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Language.Thrift.Parser +-- Copyright : (c) Abhinav Gupta 2016 +-- 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 + ( parseFromFile + , parse + , thriftIDL + + -- * Components + + , program + + , header + , include + , namespace + + , definition + , constant + , typeDefinition + , service + + , typedef + , enum + , struct + , union + , exception + , senum + + , typeReference + , constantValue + + , docstring + + -- * Parser + + , Parser + , runParser + , whiteSpace + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.State (StateT) +import Data.Text (Text) + +import qualified Control.Monad.Trans.State as State +import qualified Data.Text as Text +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Lexer as PL + +import qualified Language.Thrift.Types as T + +-- | Keeps track of the last docstring seen by the system so that we can +-- attach it to entities. +data State = State + { stateDocstring :: T.Docstring + } + deriving (Show, Eq) + +-- | Underlying Parser type. +type Parser s = StateT State (P.Parsec s) + +-- | Evaluates the underlying parser with a default state and get the Megaparsec +-- parser. +runParser :: Parser s a -> P.Parsec 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)) + +-- | @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) +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 = runParser program + + +clearDocstring :: 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 = do + s <- State.gets stateDocstring + clearDocstring + return s + +-- | Optional whitespace. +whiteSpace :: P.Stream s Char => Parser s () +whiteSpace = someSpace <|> pure () + +-- | Required whitespace. +someSpace :: P.Stream s Char => Parser s () +someSpace = P.skipSome $ readDocstring <|> skipComments <|> skipSpace + where + readDocstring = do + s <- docstring + unless (Text.null s) $ + State.modify' (\st -> st { stateDocstring = Just s}) + + skipSpace = P.choice + [ P.newline *> clearDocstring + , P.skipSome P.spaceChar + ] + + skipComments = P.choice + [ P.char '#' *> skipLine + , P.try (P.string "//") *> skipLine + , P.try (P.string "/*") *> skipCStyleComment + ] *> clearDocstring + + 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 `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 = loop + where + loop 0 = return () + loop n = + ( do + void $ P.try p + loop $! n - 1 + ) <|> return () + +hspace :: P.Stream s Char => Parser s () +hspace = void $ P.oneOf " \t" + +-- | A javadoc-style docstring. +-- +-- > /** +-- > * foo +-- > */ +-- +-- 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 = do + P.try (P.string "/**") >> P.skipMany hspace + indent <- P.sourceColumn <$> P.getPosition + isNewLine <- maybeEOL + chunks <- loop isNewLine (indent - 1) [] + return $! Text.intercalate "\n" chunks + where + maybeEOL = (P.eol >> return True) <|> return False + + commentChar = + P.noneOf "*\r\n" <|> + P.try (P.char '*' <* P.notFollowedBy (P.char '/')) + + loop shouldDedent maxDedent chunks = do + when shouldDedent $ + hspace `skipUpTo` maxDedent + finishComment <|> readDocLine + where + finishComment = do + P.try (P.skipMany hspace <* P.string "*/") + void $ optional P.spaceChar + return $! reverse chunks + readDocLine = do + -- Lines could have aligned *s at the start. + -- + -- /** + -- * foo + -- * bar + -- */ + -- + -- But only if we dedented. If we didn't, that's possibly because, + -- + -- /** foo [..] + -- + -- So if foo starts with "*", we don't want to drop that. + when shouldDedent . void $ + optional $ P.try (P.char '*' >> optional hspace) + + line <- Text.pack <$> P.many commentChar + + -- This line most likely ends with a newline but if it's the last + -- one, it could also be "foo */" + void (optional hspace >> maybeEOL) + + loop True maxDedent (line:chunks) + + +symbolic :: P.Stream s Char => Char -> Parser s () +symbolic c = void $ PL.symbol whiteSpace [c] + +token :: P.Stream 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 = 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 = symbolic ',' +semi = symbolic ';' +colon = symbolic ':' +equals = symbolic '=' + +-- | Parses a reserved identifier and adds it to the collection of known +-- reserved keywords. +reserved :: P.Stream s Char => String -> Parser s () +reserved name = P.label name $ token $ P.try $ do + void (P.string name) + P.notFollowedBy (P.alphaNumChar <|> P.oneOf "_.") + + +-- | A string literal. @"hello"@ +literal :: P.Stream s Char => Parser s Text +literal = P.label "string literal" $ token $ + stringLiteral '"' <|> stringLiteral '\'' + +stringLiteral :: P.Stream 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 = token PL.integer + + +-- | An identifier in a Thrift file. +identifier :: P.Stream s Char => Parser s Text +identifier = P.label "identifier" $ token $ do + name <- (:) + <$> (P.letterChar <|> P.char '_') + <*> many (P.alphaNumChar <|> P.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 = whiteSpace >> + T.Program + <$> many (header <* optionalSep) + <*> many (definition <* optionalSep) + <* P.eof + +-- | Headers defined for the IDL. +header :: P.Stream s Char => Parser s (T.Header P.SourcePos) +header = P.choice + [ T.HeaderInclude <$> include + , T.HeaderNamespace <$> namespace + ] + + +-- | The IDL includes another Thrift file. +-- +-- > include "common.thrift" +-- > +-- > typedef common.Foo Bar +-- +include :: P.Stream s Char => Parser s (T.Include P.SourcePos) +include = reserved "include" >> withPosition (T.Include <$> literal) + + +-- | Namespace directives allows control of the namespace or package +-- 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.choice + [ reserved "namespace" >> + withPosition (T.Namespace <$> (star <|> identifier) <*> identifier) + , reserved "cpp_namespace" >> + withPosition (T.Namespace "cpp" <$> identifier) + , reserved "php_namespace" >> + withPosition (T.Namespace "php" <$> identifier) + , reserved "py_module" >> + withPosition (T.Namespace "py" <$> identifier) + , reserved "perl_package" >> + withPosition (T.Namespace "perl" <$> identifier) + , reserved "ruby_namespace" >> + withPosition (T.Namespace "rb" <$> identifier) + , reserved "java_package" >> + withPosition (T.Namespace "java" <$> identifier) + , reserved "cocoa_package" >> + withPosition (T.Namespace "cocoa" <$> identifier) + , reserved "csharp_namespace" >> + withPosition (T.Namespace "csharp" <$> identifier) + ] + where + star = symbolic '*' >> pure "*" + + +-- | 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 = P.getPosition >>= \pos -> p <*> pure pos + + +-- | Convenience wrapper for parsers that expect a docstring and a position. +-- +-- > data Foo = Foo { bar :: Bar, doc :: Docstring, pos :: Delta } +-- > +-- > parseFoo = withDocstring $ Foo <$> parseBar +withDocstring + :: P.Stream s Char + => Parser s (T.Docstring -> P.SourcePos -> a) -> Parser s a +withDocstring p = lastDocstring >>= \s -> do + pos <- P.getPosition + p <*> pure s <*> pure pos + + +-- | A constant, type, or service definition. +definition :: P.Stream s Char => Parser s (T.Definition P.SourcePos) +definition = whiteSpace >> P.choice + [ T.ConstDefinition <$> constant + , T.TypeDefinition <$> typeDefinition + , T.ServiceDefinition <$> service + ] + + +-- | A type definition. +typeDefinition :: P.Stream s Char => Parser s (T.Type P.SourcePos) +typeDefinition = P.choice + [ T.TypedefType <$> typedef + , T.EnumType <$> enum + , T.SenumType <$> senum + , T.StructType <$> struct + , T.UnionType <$> union + , T.ExceptionType <$> exception + ] + + +-- | A typedef is just an alias for another type. +-- +-- > typedef common.Foo Bar +typedef :: P.Stream s Char => Parser s (T.Typedef P.SourcePos) +typedef = reserved "typedef" >> withDocstring + (T.Typedef <$> typeReference <*> identifier <*> typeAnnotations) + + +-- | Enums are sets of named integer values. +-- +-- > enum Role { +-- > User = 1, Admin +-- > } +enum :: P.Stream s Char => Parser s (T.Enum P.SourcePos) +enum = reserved "enum" >> withDocstring + ( T.Enum + <$> identifier + <*> braces (many enumDef) + <*> typeAnnotations + ) + + +-- | A @struct@. +-- +-- > struct User { +-- > 1: string name +-- > 2: Role role = Role.User; +-- > } +struct :: P.Stream s Char => Parser s (T.Struct P.SourcePos) +struct = reserved "struct" >> withDocstring + ( T.Struct + <$> identifier + <*> braces (many field) + <*> typeAnnotations + ) + + +-- | A @union@ of types. +-- +-- > union Value { +-- > 1: string stringValue; +-- > 2: i32 intValue; +-- > } +union :: P.Stream s Char => Parser s (T.Union P.SourcePos) +union = reserved "union" >> withDocstring + ( T.Union + <$> identifier + <*> braces (many field) + <*> typeAnnotations + ) + + +-- | An @exception@ that can be raised by service methods. +-- +-- > exception UserDoesNotExist { +-- > 1: optional string message +-- > 2: required string username +-- > } +exception :: P.Stream s Char => Parser s (T.Exception P.SourcePos) +exception = reserved "exception" >> withDocstring + ( T.Exception + <$> identifier + <*> braces (many field) + <*> typeAnnotations + ) + + +-- | Whether a field is @required@ or @optional@. +fieldRequiredness :: P.Stream s Char => Parser s T.FieldRequiredness +fieldRequiredness = P.choice + [ reserved "required" *> pure T.Required + , reserved "optional" *> pure T.Optional + ] + + +-- | A struct field. +field :: P.Stream s Char => Parser s (T.Field P.SourcePos) +field = withDocstring $ + T.Field + <$> optional (integer <* colon) + <*> optional fieldRequiredness + <*> typeReference + <*> identifier + <*> optional (equals *> constantValue) + <*> typeAnnotations + <* optionalSep + + +-- | A value defined inside an @enum@. +enumDef :: P.Stream s Char => Parser s (T.EnumDef P.SourcePos) +enumDef = withDocstring $ + T.EnumDef + <$> identifier + <*> optional (equals *> PL.signed whiteSpace integer) + <*> typeAnnotations + <* optionalSep + + +-- | 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 = reserved "senum" >> withDocstring + ( T.Senum + <$> identifier + <*> braces (many (literal <* optionalSep)) + <*> typeAnnotations + ) + + +-- | A 'const' definition. +-- +-- > const i32 code = 1; +constant :: P.Stream s Char => Parser s (T.Const P.SourcePos) +constant = do + reserved "const" + withDocstring $ + T.Const + <$> typeReference + <*> (identifier <* equals) + <*> constantValue + <* optionalSep + + +-- | A constant value literal. +constantValue :: P.Stream 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) + , T.ConstLiteral <$> literal + , T.ConstIdentifier <$> identifier + , T.ConstList <$> constList + , T.ConstMap <$> constMap + ] + + +constList :: P.Stream s Char => Parser s [T.ConstValue P.SourcePos] +constList = symbolic '[' *> loop [] + where + loop xs = P.choice + [ symbolic ']' *> return (reverse xs) + , (:) <$> (constantValue <* optionalSep) + <*> pure xs + >>= loop + ] + + +constMap + :: P.Stream s Char + => Parser s [(T.ConstValue P.SourcePos, T.ConstValue P.SourcePos)] +constMap = symbolic '{' *> loop [] + where + loop xs = P.choice [ + symbolic '}' *> return (reverse xs) + , (:) <$> (constantValuePair <* optionalSep) + <*> pure xs + >>= loop + ] + + +constantValuePair + :: P.Stream s Char + => Parser s (T.ConstValue P.SourcePos, T.ConstValue P.SourcePos) +constantValuePair = + (,) <$> (constantValue <* colon) + <*> (constantValue <* optionalSep) + + +-- | A reference to a built-in or defined field. +typeReference :: P.Stream s Char => Parser s (T.TypeReference P.SourcePos) +typeReference = P.choice + [ baseType + , containerType + , withPosition (T.DefinedType <$> identifier) + ] + + +baseType + :: P.Stream s Char => Parser s (T.TypeReference P.SourcePos) +baseType = withPosition $ + P.choice [reserved s *> (v <$> typeAnnotations) | (s, v) <- bases] + where + bases = + [ ("string", T.StringType) + , ("binary", T.BinaryType) + , ("slist", T.SListType) + , ("bool", T.BoolType) + , ("byte", T.ByteType) + , ("i8", T.ByteType) + , ("i16", T.I16Type) + , ("i32", T.I32Type) + , ("i64", T.I64Type) + , ("double", T.DoubleType) + ] + + +containerType + :: P.Stream s Char => Parser s (T.TypeReference P.SourcePos) +containerType = withPosition $ + P.choice [mapType, setType, listType] <*> typeAnnotations + where + mapType = reserved "map" >> + angles (T.MapType <$> (typeReference <* comma) <*> typeReference) + setType = reserved "set" >> angles (T.SetType <$> typeReference) + listType = reserved "list" >> angles (T.ListType <$> typeReference) + + +-- | A service. +-- +-- > service MyService { +-- > // ... +-- > } +service :: P.Stream s Char => Parser s (T.Service P.SourcePos) +service = do + reserved "service" + withDocstring $ + T.Service + <$> identifier + <*> optional (reserved "extends" *> identifier) + <*> braces (many function) + <*> typeAnnotations + + +-- | A function defined inside a service. +-- +-- > Foo getFoo() throws (1: FooDoesNotExist doesNotExist); +-- > oneway void putBar(1: Bar bar); +function :: P.Stream s Char => Parser s (T.Function P.SourcePos) +function = withDocstring $ + T.Function + <$> ((reserved "oneway" *> pure True) <|> pure False) + <*> ((reserved "void" *> pure Nothing) <|> Just <$> typeReference) + <*> identifier + <*> parens (many field) + <*> optional (reserved "throws" *> parens (many field)) + <*> typeAnnotations + <* optionalSep + + +-- | 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 :: P.Stream s Char => Parser s [T.TypeAnnotation] +typeAnnotations = parens (many typeAnnotation) <|> pure [] + + +typeAnnotation :: P.Stream s Char => Parser s T.TypeAnnotation +typeAnnotation = + T.TypeAnnotation + <$> identifier + <*> (optional (equals *> literal) <* optionalSep) + + +optionalSep :: P.Stream s Char => Parser s () +optionalSep = void $ optional (comma <|> semi) diff --git a/src/Language/Thrift/Pretty.hs b/src/Language/Thrift/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/Thrift/Pretty.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Language.Thrift.Pretty +-- Copyright : (c) Abhinav Gupta 2016 +-- License : BSD3 +-- +-- Maintainer : Abhinav Gupta +-- Stability : experimental +-- +-- This module provides a pretty printer for Thrift IDLs. Most of the printers +-- defined in this module produce output highlighted using ANSI escape codes. +-- Get plain output by using 'Text.PrettyPrint.ANSI.Leijen.plain'. +-- +-- Use 'prettyPrintHighlighted' to produce output highlighted using ANSI escape +-- codes. Note that this output will be unparseable and is suitable for printing +-- inside a compatible terminal only. Use 'prettyPrint' if you don't want +-- highlighted output. +-- +-- The behavior of the printer can be customized using 'Config' objects. +-- +-- The module also exports instances of the 'Pretty' typeclass for elements of +-- the AST. +module Language.Thrift.Pretty + ( + prettyPrintHighlighted + , prettyPrint + + -- * Components + + , program + + , header + , include + , namespace + + , definition + , constant + , typeDefinition + , service + + , typedef + , enum + , struct + , union + , exception + , senum + + , typeReference + , constantValue + + , docstring + + -- * Configuration + + , Config(..) + , defaultConfig + ) where + +#if __GLASGOW_HASKELL__ >= 709 +import Prelude hiding ((<$>)) +#endif + +import Data.Text (Text) +import qualified Data.Text as Text + +import Text.PrettyPrint.ANSI.Leijen (Doc, Pretty (..), align, bold, cyan, + double, dquotes, dullblue, empty, enclose, + group, hcat, hsep, integer, line, + linebreak, magenta, nest, plain, space, + vsep, yellow, (<$$>), (<$>), (<+>), (<>)) + +import qualified Language.Thrift.Internal.Types as T +import qualified Text.PrettyPrint.ANSI.Leijen as P + +-- | Configuration for the pretty printer. +data Config = Config + { indentWidth :: Int + -- ^ Number of spaces to use for indentation. + } deriving (Show, Ord, Eq) + + +-- | Default pretty printing configuration. +defaultConfig :: Config +defaultConfig = Config 4 + +-- | Top-level pretty printer for Thrift documents that uses the default +-- configuration ('defaultConfig') for pretty printing. +prettyPrint :: T.Program ann -> Doc +prettyPrint = plain . prettyPrintHighlighted + +-- | Top-level pretty printer for Thrift documents. +prettyPrintHighlighted :: T.Program ann -> Doc +prettyPrintHighlighted = program defaultConfig + +-- | Pretty print a Thrift IDL. +program :: Config -> T.Program ann -> Doc +program c T.Program{..} = + ( if null programHeaders + then empty + else vsep (map header programHeaders) <$> line + ) <> map (definition c) programDefinitions `sepBy` (line <> line) + +instance Pretty (T.Program a) where + pretty = program defaultConfig + +-- | Print the headers for a program. +header :: T.Header ann -> Doc +header (T.HeaderInclude inc) = include inc +header (T.HeaderNamespace ns) = namespace ns + +instance Pretty (T.Header a) where + pretty = header + +include :: T.Include ann -> Doc +include T.Include{..} = reserved "include" <+> literal includePath + +instance Pretty (T.Include a) where + pretty = include + +namespace :: T.Namespace ann -> Doc +namespace T.Namespace{..} = hsep + [reserved "namespace", text namespaceLanguage, text namespaceName] + +instance Pretty (T.Namespace a) where + pretty = namespace + +-- | Print a constant, type, or service definition. +definition :: Config -> T.Definition ann -> Doc +definition c (T.ConstDefinition cd) = constant c cd +definition c (T.TypeDefinition def) = typeDefinition c def +definition c (T.ServiceDefinition s) = service c s + +instance Pretty (T.Definition a) where + pretty = definition defaultConfig + +constant :: Config -> T.Const ann -> Doc +constant c T.Const{..} = constDocstring $$ hsep + [ reserved "const" + , typeReference c constValueType + , declare constName + , equals + , constantValue c constValue + ] + +instance Pretty (T.Const a) where + pretty = constant defaultConfig + +service :: Config -> T.Service ann -> Doc +service c@Config{indentWidth} T.Service{..} = + serviceDocstring $$ + reserved "service" <+> declare serviceName <> extends <+> + block indentWidth (line <> line) (map (function c) serviceFunctions) <> + typeAnnots c serviceAnnotations + where + extends = case serviceExtends of + Nothing -> empty + Just name -> space <> reserved "extends" <+> text name + +instance Pretty (T.Service a) where + pretty = service defaultConfig + +-- | Pretty print a function definition. +-- +function :: Config -> T.Function ann -> Doc +function c@Config{indentWidth} T.Function{..} = functionDocstring $$ + oneway <> returnType <+> text functionName <> + encloseSep + indentWidth lparen rparen comma + (map (field c) functionParameters) <> + exceptions <> typeAnnots c functionAnnotations <> semi + where + exceptions = case functionExceptions of + Nothing -> empty + Just es -> space <> reserved "throws" <+> + encloseSep indentWidth lparen rparen comma (map (field c) es) + returnType = case functionReturnType of + Nothing -> reserved "void" + Just rt -> typeReference c rt + oneway = + if functionOneWay + then reserved "oneway" <> space + else empty + +instance Pretty (T.Function a) where + pretty = function defaultConfig + +typeDefinition :: Config -> T.Type ann -> Doc +typeDefinition c td = case td of + T.TypedefType t -> c `typedef` t + T.EnumType t -> c `enum` t + T.StructType t -> c `struct` t + T.UnionType t -> c `union` t + T.ExceptionType t -> c `exception` t + T.SenumType t -> c `senum` t + +instance Pretty (T.Type a) where + pretty = typeDefinition defaultConfig + +typedef :: Config -> T.Typedef ann -> Doc +typedef c T.Typedef{..} = typedefDocstring $$ + reserved "typedef" <+> typeReference c typedefTargetType <+> + declare typedefName <> typeAnnots c typedefAnnotations + +instance Pretty (T.Typedef a) where + pretty = typedef defaultConfig + +enum :: Config -> T.Enum ann -> Doc +enum c@Config{indentWidth} T.Enum{..} = enumDocstring $$ + reserved "enum" <+> declare enumName <+> + block indentWidth (comma <> line) (map (enumValue c) enumValues) + <> typeAnnots c enumAnnotations + +instance Pretty (T.Enum a) where + pretty = enum defaultConfig + +struct :: Config -> T.Struct ann -> Doc +struct c@Config{indentWidth} T.Struct{..} = structDocstring $$ + reserved "struct" <+> declare structName <+> + block indentWidth line (map (\f -> field c f <> semi) structFields) + <> typeAnnots c structAnnotations + +instance Pretty (T.Struct a) where + pretty = struct defaultConfig + +union :: Config -> T.Union ann -> Doc +union c@Config{indentWidth} T.Union{..} = unionDocstring $$ + reserved "union" <+> declare unionName <+> + block indentWidth line (map (\f -> field c f <> semi) unionFields) + <> typeAnnots c unionAnnotations + +instance Pretty (T.Union a) where + pretty = union defaultConfig + +exception :: Config -> T.Exception ann -> Doc +exception c@Config{indentWidth} T.Exception{..} = exceptionDocstring $$ + reserved "exception" <+> declare exceptionName <+> + block indentWidth line (map (\f -> field c f <> semi) exceptionFields) + <> typeAnnots c exceptionAnnotations + +instance Pretty (T.Exception a) where + pretty = exception defaultConfig + +senum :: Config -> T.Senum ann -> Doc +senum c@Config{indentWidth} T.Senum{..} = senumDocstring $$ + reserved "senum" <+> declare senumName <+> + encloseSep indentWidth lbrace rbrace comma (map literal senumValues) + <> typeAnnots c senumAnnotations + +instance Pretty (T.Senum a) where + pretty = senum defaultConfig + +field :: Config -> T.Field ann -> Doc +field c T.Field{..} = fieldDocstring $$ hcat + [ case fieldIdentifier of + Nothing -> empty + Just i -> yellow (integer i) <> colon <> space + , case fieldRequiredness of + Nothing -> empty + Just r -> requiredness r <> space + , typeReference c fieldValueType + , space + , text fieldName + , case fieldDefaultValue of + Nothing -> empty + Just v -> space <> equals <+> constantValue c v + , typeAnnots c fieldAnnotations + ] + +instance Pretty (T.Field a) where + pretty = field defaultConfig + +requiredness :: T.FieldRequiredness -> Doc +requiredness T.Optional = reserved "optional" +requiredness T.Required = reserved "required" + +instance Pretty T.FieldRequiredness where + pretty = requiredness + +enumValue :: Config -> T.EnumDef ann -> Doc +enumValue c T.EnumDef{..} = enumDefDocstring $$ + text enumDefName <> value <> typeAnnots c enumDefAnnotations + where + value = case enumDefValue of + Nothing -> empty + Just v -> space <> equals <+> integer v + +instance Pretty (T.EnumDef a) where + pretty = enumValue defaultConfig + +-- | Pretty print a field type. +typeReference :: Config -> T.TypeReference ann -> Doc +typeReference c ft = case ft of + T.DefinedType t _ -> text t + + T.StringType anns _ -> reserved "string" <> typeAnnots c anns + T.BinaryType anns _ -> reserved "binary" <> typeAnnots c anns + T.SListType anns _ -> reserved "slist" <> typeAnnots c anns + T.BoolType anns _ -> reserved "bool" <> typeAnnots c anns + T.ByteType anns _ -> reserved "byte" <> typeAnnots c anns + T.I16Type anns _ -> reserved "i16" <> typeAnnots c anns + T.I32Type anns _ -> reserved "i32" <> typeAnnots c anns + T.I64Type anns _ -> reserved "i64" <> typeAnnots c anns + T.DoubleType anns _ -> reserved "double" <> typeAnnots c anns + + T.MapType k v anns _ -> + reserved "map" + <> enclose langle rangle + (typeReference c k <> comma <+> typeReference c v) + <> typeAnnots c anns + T.SetType v anns _ -> + reserved "set" + <> enclose langle rangle (typeReference c v) + <> typeAnnots c anns + T.ListType v anns _ -> + reserved "list" + <> enclose langle rangle (typeReference c v) + <> typeAnnots c anns + +instance Pretty (T.TypeReference a) where + pretty = typeReference defaultConfig + +-- | Pretty print a constant value. +constantValue :: Config -> T.ConstValue ann -> Doc +constantValue c@Config{indentWidth} value = case value of + T.ConstInt i _ -> integer i + T.ConstFloat f _ -> double f + T.ConstLiteral l _ -> literal l + T.ConstIdentifier i _ -> text i + T.ConstList vs _ -> + encloseSep indentWidth lbracket rbracket comma $ map (constantValue c) vs + T.ConstMap vs _ -> + encloseSep indentWidth lbrace rbrace comma $ + map (\(k, v) -> constantValue c k <> colon <+> constantValue c v) vs + +instance Pretty (T.ConstValue a) where + pretty = constantValue defaultConfig + +typeAnnots :: Config -> [T.TypeAnnotation] -> Doc +typeAnnots _ [] = empty +typeAnnots Config{indentWidth} anns = + space <> encloseSep indentWidth lparen rparen comma (map typeAnnot anns) + +typeAnnot :: T.TypeAnnotation -> Doc +typeAnnot T.TypeAnnotation{..} = + text typeAnnotationName <> value + where + value = case typeAnnotationValue of + Nothing -> empty + Just v -> space <> equals <+> literal v + +instance Pretty T.TypeAnnotation where + pretty = typeAnnot + +literal :: Text -> Doc +literal = cyan . dquotes . text + -- TODO: escaping? + +text :: Text -> Doc +text = P.text . Text.unpack + +reserved :: String -> Doc +reserved = magenta . P.text + +op :: String -> Doc +op = yellow . P.text + +declare :: Text -> Doc +declare = bold . text + +($$) :: T.Docstring -> Doc -> Doc +($$) Nothing y = y +($$) (Just t) y = + if Text.null t' + then y + else docstring t' <$> y + where + t' = Text.strip t + +infixr 1 $$ + +docstring :: Text -> Doc +docstring = dullblue . wrapComments . Text.lines + where + wrapComments ls = align . vsep + $ text "/**" + : map (\l -> text " *" <+> text l) ls + ++ [text " */"] + +block :: Int -> Doc -> [Doc] -> Doc +block indent s items = enclose lbrace rbrace $ + nest indent (linebreak <> (items `sepBy` s)) <> linebreak + +sepBy :: [Doc] -> Doc -> Doc +sepBy [] _ = empty +sepBy [x] _ = x +sepBy (x:xs) s = x <> s <> sepBy xs s + +encloseSep :: Int -> Doc -> Doc -> Doc -> [Doc] -> Doc +encloseSep _ left right _ [] = left <> right +encloseSep _ left right _ [v] = left <> v <> right +encloseSep indent left right s vs = group $ + nest indent (left <$$> go vs) <$$> right + where go [] = empty + go [x] = x + go (x:xs) = (x <> s) <$> go xs + +lbrace :: Doc +lbrace = op "{" + +rbrace :: Doc +rbrace = op "}" + +lparen :: Doc +lparen = op "(" + +rparen :: Doc +rparen = op ")" + +lbracket :: Doc +lbracket = op "[" + +rbracket :: Doc +rbracket = op "]" + +langle :: Doc +langle = op "<" + +rangle :: Doc +rangle = op ">" + +comma :: Doc +comma = op "," + +semi :: Doc +semi = op ";" + +colon :: Doc +colon = op ":" + +equals :: Doc +equals = op "=" diff --git a/src/Language/Thrift/Types.hs b/src/Language/Thrift/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Thrift/Types.hs @@ -0,0 +1,27 @@ +-- | +-- Module : Language.Thrift.Types +-- 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.Types + ( module Language.Thrift.Internal.Types + ) where + +import Language.Thrift.Internal.Types +import Language.Thrift.Pretty ()