language-thrift 0.8.0.0 → 0.8.0.1

raw patch · 12 files changed

+1978/−1963 lines, 12 filesdep ~ansi-wl-pprintdep ~basedep ~megaparsecPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ansi-wl-pprint, base, megaparsec, text

API changes (from Hackage documentation)

Files

• CHANGES.md +43/−37
• LICENSE +1/−1
• Language/Thrift/Internal/Types.hs +0/−793
• Language/Thrift/Parser.hs +0/−626
• Language/Thrift/Pretty.hs +0/−445
• Language/Thrift/Types.hs +0/−27
• examples/Setup.hs +0/−2
• language-thrift.cabal +43/−32
• src/Language/Thrift/Internal/Types.hs +793/−0
• src/Language/Thrift/Parser.hs +626/−0
• src/Language/Thrift/Pretty.hs +445/−0
• src/Language/Thrift/Types.hs +27/−0

@@ -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.+

@@ -1,4 +1,4 @@-Copyright (c) 2015, Abhinav Gupta+Copyright (c) 2016, Abhinav Gupta  All rights reserved. 

@@ -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\<foo, bar\>@ and annotations.-    | SetType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot-    -- ^ @set\<baz\>@ and annotations.-    | ListType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot-    -- ^ @list\<qux\>@ 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 })

@@ -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 <mail@abhinavg.net>--- 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)

@@ -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 <mail@abhinavg.net>--- 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 "="

@@ -1,27 +0,0 @@--- |--- Module      :  Language.Thrift.Types--- Copyright   :  (c) Abhinav Gupta 2015--- License     :  BSD3------ Maintainer  :  Abhinav Gupta <mail@abhinavg.net>--- 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         ()

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

@@ -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 <mail@abhinavg.net>-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-    <http://thrift.apache.org/docs/idl Thrift IDL format>.-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 <mail@abhinavg.net>+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+                <http://thrift.apache.org/docs/idl Thrift IDL format>.+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

@@ -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\<foo, bar\>@ and annotations.+    | SetType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot+    -- ^ @set\<baz\>@ and annotations.+    | ListType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot+    -- ^ @list\<qux\>@ 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 })

@@ -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 <mail@abhinavg.net>+-- 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)

@@ -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 <mail@abhinavg.net>+-- 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 "="

@@ -0,0 +1,27 @@+-- |+-- Module      :  Language.Thrift.Types+-- Copyright   :  (c) Abhinav Gupta 2016+-- License     :  BSD3+--+-- Maintainer  :  Abhinav Gupta <mail@abhinavg.net>+-- 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         ()