language-thrift 0.7.0.1 → 0.8.0.0
raw patch · 20 files changed
+912/−1126 lines, 20 filesdep +megaparsecdep −lensdep −parsersdep −trifecta
Dependencies added: megaparsec
Dependencies removed: lens, parsers, trifecta, wl-pprint
Files
- CHANGES.md +13/−0
- Language/Thrift/Internal/Types.hs +61/−273
- Language/Thrift/Parser.hs +307/−254
- Language/Thrift/Parser/Trifecta.hs +0/−23
- Language/Thrift/Pretty.hs +395/−6
- Language/Thrift/Pretty/ANSI.hs +0/−65
- Language/Thrift/Pretty/PrettyInc.hs +0/−383
- Language/Thrift/Pretty/Types.hs +0/−15
- Language/Thrift/Types.hs +9/−4
- README.md +3/−8
- examples/generateHaskellTypes.hs +10/−17
- examples/reformatIDL.hs +6/−8
- language-thrift.cabal +5/−13
- test/Language/Thrift/Arbitrary.hs +1/−1
- test/Language/Thrift/ParserSpec.hs +46/−3
- test/Language/Thrift/TypesSpec.hs +26/−37
- test/Main.hs +1/−1
- test/TestUtils.hs +15/−15
- test/data/docstring-1.txt +9/−0
- test/data/docstring-2.txt +5/−0
CHANGES.md view
@@ -1,3 +1,16 @@+0.8.0.0+=======++This release contains breaking changes. The number of transitive dependencies+has been reduced significantly.++- Switched parser to `megaparsec`. `trifecta` and `parsers` bring too many+ dependencies with them.+- Drop support for `wl-pprint`. Only `ansi-wl-pprint` is supported now.+- Drop dependency on `lens`. Lenses for fields of the AST elements are still+ provided but prisms are not. Use `Control.Lens.makePrisms` to derive your+ own if needed.+ 0.7.0.1 =======
Language/Thrift/Internal/Types.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-} module Language.Thrift.Internal.Types ( -- * AST@@ -12,8 +14,6 @@ , definitions , Header(..)- , _Include- , _Namespace , Include(..) , path@@ -22,9 +22,6 @@ , language , Definition(..)- , _Const- , _Service- , _Type , Const(..) , Service(..)@@ -32,12 +29,6 @@ , extends , Type(..)- , _Typedef- , _Enum- , _Struct- , _Union- , _Exception- , _Senum , Typedef(..) , targetType@@ -49,8 +40,6 @@ , Senum(..) , FieldRequiredness(..)- , _Required- , _Optional , Field(..) , identifier@@ -60,27 +49,8 @@ , EnumDef(..) , ConstValue(..)- , _ConstInt- , _ConstFloat- , _ConstLiteral- , _ConstIdentifier- , _ConstList- , _ConstMap , TypeReference(..)- , _DefinedType- , _StringType- , _BinaryType- , _SListType- , _BoolType- , _ByteType- , _I16Type- , _I32Type- , _I64Type- , _DoubleType- , _MapType- , _SetType- , _ListType , Function(..) , oneWay@@ -103,20 +73,33 @@ , HasValueType(..) ) where -import Control.Lens (Lens', Prism', lens, prism', set, view)-import Data.Data (Data, Typeable)-import Data.Text (Text)-import GHC.Generics (Generic)-import Prelude hiding (Enum)+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+ srcAnnot :: Lens (t a) a class HasName t where- name :: Lens' t Text+ name :: Lens t Text class HasValue s a | s -> a where- value :: Lens' s a+ value :: Lens s a -- | Type annoations may be added in various places in the form, --@@ -139,7 +122,7 @@ value = lens typeAnnotationValue (\s a -> s { typeAnnotationValue = a }) class HasAnnotations t where- annotations :: Lens' t [TypeAnnotation]+ annotations :: Lens t [TypeAnnotation] -- | Docstrings are Javadoc-style comments attached various defined objects. --@@ -150,7 +133,7 @@ type Docstring = Maybe Text class HasDocstring t where- docstring :: Lens' t Docstring+ 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.@@ -170,43 +153,7 @@ | ConstMap [(ConstValue srcAnnot, ConstValue srcAnnot)] srcAnnot -- ^ A literal list containing other constant values. -- @{"hellO": 1, "world": 2}@- deriving (Show, Ord, Eq, Data, Typeable, Generic)--_ConstInt :: Prism' (ConstValue a) (Integer, a)-_ConstInt = prism' (uncurry ConstInt) $ \c ->- case c of- ConstInt v a -> Just (v, a)- _ -> Nothing--_ConstFloat :: Prism' (ConstValue a) (Double, a)-_ConstFloat = prism' (uncurry ConstFloat) $ \c ->- case c of- ConstFloat v a -> Just (v, a)- _ -> Nothing--_ConstLiteral :: Prism' (ConstValue a) (Text, a)-_ConstLiteral = prism' (uncurry ConstLiteral) $ \c ->- case c of- ConstLiteral v a -> Just (v, a)- _ -> Nothing--_ConstIdentifier :: Prism' (ConstValue a) (Text, a)-_ConstIdentifier = prism' (uncurry ConstIdentifier) $ \c ->- case c of- ConstIdentifier v a -> Just (v, a)- _ -> Nothing--_ConstList :: Prism' (ConstValue a) ([ConstValue a], a)-_ConstList = prism' (uncurry ConstList) $ \c ->- case c of- ConstList v a -> Just (v, a)- _ -> Nothing--_ConstMap :: Prism' (ConstValue a) ([(ConstValue a, ConstValue a)], a)-_ConstMap = prism' (uncurry ConstMap) $ \c ->- case c of- ConstMap v a -> Just (v, a)- _ -> Nothing+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) instance HasSrcAnnot ConstValue where srcAnnot = lens getter setter@@ -260,85 +207,7 @@ -- ^ @set\<baz\>@ and annotations. | ListType (TypeReference srcAnnot) [TypeAnnotation] srcAnnot -- ^ @list\<qux\>@ and annotations.- deriving (Show, Ord, Eq, Data, Typeable, Generic)--_DefinedType :: Prism' (TypeReference a) (Text, a)-_DefinedType = prism' (uncurry DefinedType) $ \r ->- case r of- DefinedType t a -> Just (t, a)- _ -> Nothing--_StringType :: Prism' (TypeReference a) ([TypeAnnotation], a)-_StringType = prism' (uncurry StringType) $ \r ->- case r of- StringType t a -> Just (t, a)- _ -> Nothing--_BinaryType :: Prism' (TypeReference a) ([TypeAnnotation], a)-_BinaryType = prism' (uncurry BinaryType) $ \r ->- case r of- BinaryType t a -> Just (t, a)- _ -> Nothing--_SListType :: Prism' (TypeReference a) ([TypeAnnotation], a)-_SListType = prism' (uncurry SListType) $ \r ->- case r of- SListType t a -> Just (t, a)- _ -> Nothing--_BoolType :: Prism' (TypeReference a) ([TypeAnnotation], a)-_BoolType = prism' (uncurry BoolType) $ \r ->- case r of- BoolType t a -> Just (t, a)- _ -> Nothing--_ByteType :: Prism' (TypeReference a) ([TypeAnnotation], a)-_ByteType = prism' (uncurry ByteType) $ \r ->- case r of- ByteType t a -> Just (t, a)- _ -> Nothing--_I16Type :: Prism' (TypeReference a) ([TypeAnnotation], a)-_I16Type = prism' (uncurry I16Type) $ \r ->- case r of- I16Type t a -> Just (t, a)- _ -> Nothing--_I32Type :: Prism' (TypeReference a) ([TypeAnnotation], a)-_I32Type = prism' (uncurry I32Type) $ \r ->- case r of- I32Type t a -> Just (t, a)- _ -> Nothing--_I64Type :: Prism' (TypeReference a) ([TypeAnnotation], a)-_I64Type = prism' (uncurry I64Type) $ \r ->- case r of- I64Type t a -> Just (t, a)- _ -> Nothing--_DoubleType :: Prism' (TypeReference a) ([TypeAnnotation], a)-_DoubleType = prism' (uncurry DoubleType) $ \r ->- case r of- DoubleType t a -> Just (t, a)- _ -> Nothing--_MapType :: Prism' (TypeReference a) (TypeReference a, TypeReference a, [TypeAnnotation], a)-_MapType = prism' (\(k, v, t, a) -> MapType k v t a) $ \r ->- case r of- MapType k v t a -> Just (k, v, t, a)- _ -> Nothing--_SetType :: Prism' (TypeReference a) (TypeReference a, [TypeAnnotation], a)-_SetType = prism' (\(v, t, a) -> SetType v t a) $ \r ->- case r of- SetType v t a -> Just (v, t, a)- _ -> Nothing--_ListType :: Prism' (TypeReference a) (TypeReference a, [TypeAnnotation], a)-_ListType = prism' (\(v, t, a) -> ListType v t a) $ \r ->- case r of- ListType v t a -> Just (v, t, a)- _ -> Nothing+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) instance HasSrcAnnot TypeReference where srcAnnot = lens getter setter@@ -372,7 +241,7 @@ setter (ListType t x _) a = ListType t x a class HasValueType t where- valueType :: Lens' (t a) (TypeReference a)+ valueType :: Lens (t a) (TypeReference a) -- | Whether a field is required or optional. data FieldRequiredness@@ -380,18 +249,6 @@ | Optional -- ^ The field is @optional@. deriving (Show, Ord, Eq, Data, Typeable, Generic) -_Required :: Prism' FieldRequiredness ()-_Required = prism' (\() -> Required) $ \r ->- case r of- Required -> Just ()- _ -> Nothing--_Optional :: Prism' FieldRequiredness ()-_Optional = prism' (\() -> Optional) $ \r ->- case r of- Optional -> Just ()- _ -> Nothing- -- | A field inside a struct, exception, or function parameters list. data Field srcAnnot = Field { fieldIdentifier :: Maybe Integer@@ -417,15 +274,15 @@ -- ^ Documentation. , fieldSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) -identifier :: Lens' (Field a) (Maybe Integer)+identifier :: Lens (Field a) (Maybe Integer) identifier = lens fieldIdentifier (\s a -> s { fieldIdentifier = a }) -requiredness :: Lens' (Field a) (Maybe FieldRequiredness)+requiredness :: Lens (Field a) (Maybe FieldRequiredness) requiredness = lens fieldRequiredness (\s a -> s { fieldRequiredness = a }) -defaultValue :: Lens' (Field a) (Maybe (ConstValue a))+defaultValue :: Lens (Field a) (Maybe (ConstValue a)) defaultValue = lens fieldDefaultValue (\s a -> s { fieldDefaultValue = a }) instance HasName (Field a) where@@ -444,7 +301,7 @@ annotations = lens fieldAnnotations (\s a -> s { fieldAnnotations = a }) class HasFields t where- fields :: Lens' (t a) [Field a]+ fields :: Lens (t a) [Field a] -- | A function defined inside a service. data Function srcAnnot = Function@@ -465,18 +322,18 @@ -- ^ Documentation. , functionSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) -oneWay :: Lens' (Function a) Bool+oneWay :: Lens (Function a) Bool oneWay = lens functionOneWay (\s a -> s { functionOneWay = a }) -returnType :: Lens' (Function a) (Maybe (TypeReference a))+returnType :: Lens (Function a) (Maybe (TypeReference a)) returnType = lens functionReturnType (\s a -> s { functionReturnType = a }) -parameters :: Lens' (Function a) [Field a]+parameters :: Lens (Function a) [Field a] parameters = lens functionParameters (\s a -> s { functionParameters = a }) -exceptions :: Lens' (Function a) (Maybe [Field a])+exceptions :: Lens (Function a) (Maybe [Field a]) exceptions = lens functionExceptions (\s a -> s { functionExceptions = a }) instance HasName (Function a) where@@ -509,12 +366,12 @@ -- ^ Documentation. , serviceSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) -functions :: Lens' (Service a) [Function a]+functions :: Lens (Service a) [Function a] functions = lens serviceFunctions (\s a -> s { serviceFunctions = a }) -extends :: Lens' (Service a) (Maybe Text)+extends :: Lens (Service a) (Maybe Text) extends = lens serviceExtends (\s a -> s { serviceExtends = a }) instance HasName (Service a) where@@ -543,7 +400,7 @@ -- ^ Documentation. , constSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) instance HasValue (Const a) (ConstValue a) where value = lens constValue (\s a -> s { constValue = a })@@ -574,9 +431,9 @@ -- ^ Documentation. , typedefSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) -targetType :: Lens' (Typedef a) (TypeReference a)+targetType :: Lens (Typedef a) (TypeReference a) targetType = lens typedefTargetType (\s a -> s { typedefTargetType = a }) instance HasName (Typedef a) where@@ -603,7 +460,7 @@ -- ^ Documentation , enumDefSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) instance HasValue (EnumDef a) (Maybe Integer) where value = lens enumDefValue (\s a -> s { enumDefValue = a })@@ -636,10 +493,10 @@ -- ^ Documentation. , enumSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) class HasValues s a | s -> a where- values :: Lens' s a+ values :: Lens s a instance HasValues (Enum a) [EnumDef a] where values = lens enumValues (\s a -> s { enumValues = a })@@ -672,7 +529,7 @@ -- ^ Documentation. , structSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) instance HasName (Struct a) where name = lens structName (\s a -> s { structName = a })@@ -706,7 +563,7 @@ -- ^ Documentation. , unionSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) instance HasName (Union a) where name = lens unionName (\s a -> s { unionName = a })@@ -740,7 +597,7 @@ -- ^ Documentation. , exceptionSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) instance HasName (Exception a) where name = lens exceptionName (\s a -> s { exceptionName = a })@@ -768,7 +625,7 @@ -- ^ Documentation. , senumSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) instance HasValues (Senum a) [Text] where values = lens senumValues (\s a -> s { senumValues = a })@@ -799,7 +656,7 @@ ExceptionType (Exception srcAnnot) | -- | @senum@ SenumType (Senum srcAnnot)- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) instance HasName (Type a) where name = lens getter setter@@ -835,43 +692,6 @@ setter (ExceptionType t) a = ExceptionType $ set srcAnnot a t setter (SenumType t) a = SenumType $ set srcAnnot a t -_Typedef :: Prism' (Type ann) (Typedef ann)-_Typedef = prism' TypedefType $ \t ->- case t of- TypedefType a -> Just a- _ -> Nothing--_Enum :: Prism' (Type ann) (Enum ann)-_Enum = prism' EnumType $ \t ->- case t of- EnumType a -> Just a- _ -> Nothing--_Struct :: Prism' (Type ann) (Struct ann)-_Struct = prism' StructType $ \t ->- case t of- StructType a -> Just a- _ -> Nothing--_Union :: Prism' (Type ann) (Union ann)-_Union = prism' UnionType $ \t ->- case t of- UnionType a -> Just a- _ -> Nothing--_Exception :: Prism' (Type ann) (Exception ann)-_Exception = prism' ExceptionType $ \t ->- case t of- ExceptionType a -> Just a- _ -> Nothing--_Senum :: Prism' (Type ann) (Senum ann)-_Senum = prism' SenumType $ \t ->- case t of- SenumType a -> Just a- _ -> Nothing-- -- | A definition either consists of new constants, new types, or new -- services. data Definition srcAnnot@@ -881,7 +701,7 @@ TypeDefinition (Type srcAnnot) | -- | A service definition. ServiceDefinition (Service srcAnnot)- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) instance HasName (Definition a) where name = lens getter setter@@ -906,25 +726,6 @@ setter (ServiceDefinition d) a = ServiceDefinition $ set srcAnnot a d -_Const :: Prism' (Definition ann) (Const ann)-_Const = prism' ConstDefinition $ \def ->- case def of- ConstDefinition c -> Just c- _ -> Nothing--_Type :: Prism' (Definition ann) (Type ann)-_Type = prism' TypeDefinition $ \def ->- case def of- TypeDefinition c -> Just c- _ -> Nothing--_Service :: Prism' (Definition ann) (Service ann)-_Service = prism' ServiceDefinition $ \def ->- case def of- ServiceDefinition c -> Just c- _ -> Nothing-- -- | Namespace directives allows control of the namespace or package -- name used by the generated code for certain languages. --@@ -938,9 +739,9 @@ -- language. , namespaceSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) -language :: Lens' (Namespace a) Text+language :: Lens (Namespace a) Text language = lens namespaceLanguage (\s a -> s { namespaceLanguage = a }) instance HasName (Namespace a) where@@ -960,9 +761,9 @@ -- ^ Path to the included file. , includeSrcAnnot :: srcAnnot }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) -path :: Lens' (Include a) Text+path :: Lens (Include a) Text path = lens includePath (\s a -> s { includePath = a }) instance HasSrcAnnot Include where@@ -974,20 +775,7 @@ HeaderInclude (Include srcAnnot) | -- | A @namespace@ specifier. HeaderNamespace (Namespace srcAnnot)- deriving (Show, Ord, Eq, Data, Typeable, Generic)--_Include :: Prism' (Header ann) (Include ann)-_Include = prism' HeaderInclude $ \h ->- case h of- HeaderInclude inc -> Just inc- _ -> Nothing--_Namespace :: Prism' (Header ann) (Namespace ann)-_Namespace = prism' HeaderNamespace $ \h ->- case h of- HeaderNamespace ns -> Just ns- _ -> Nothing-+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) -- | A program represents a single Thrift document. data Program srcAnnot = Program@@ -996,10 +784,10 @@ , programDefinitions :: [Definition srcAnnot] -- ^ Types and services defined in the document. }- deriving (Show, Ord, Eq, Data, Typeable, Generic)+ deriving (Show, Ord, Eq, Data, Typeable, Generic, Functor) -headers :: Lens' (Program a) [Header a]+headers :: Lens (Program a) [Header a] headers = lens programHeaders (\s a -> s { programHeaders = a }) -definitions :: Lens' (Program a) [Definition a]+definitions :: Lens (Program a) [Definition a] definitions = lens programDefinitions (\s a -> s { programDefinitions = a })
Language/Thrift/Parser.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Language.Thrift.Parser -- Copyright : (c) Abhinav Gupta 2015@@ -24,7 +25,9 @@ -- for example, you could define a string value for an int constant. -- module Language.Thrift.Parser- ( thriftIDL+ ( parseFromFile+ , parse+ , thriftIDL -- * Components @@ -49,247 +52,302 @@ , typeReference , constantValue + , docstring+ -- * Parser - , ThriftParser- , runThriftParser+ , Parser+ , runParser+ , whiteSpace ) where import Control.Applicative import Control.Monad-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Reader (ReaderT)-import Control.Monad.Trans.State (StateT)-import Data.Text (Text)-import Text.Parser.Char-import Text.Parser.Combinators-import Text.Parser.Token-import Text.Parser.Token.Style (emptyIdents)+import Control.Monad.Trans.State (StateT)+import Data.Text (Text) -import qualified Control.Monad.Trans.Reader as Reader-import qualified Control.Monad.Trans.State as State-import qualified Data.Text as 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) --- | Get a top level parser that is able to parse full Thrift documents.------ Entities defined in the IDL are annotated with @n@ values (determined by--- executing @p n@ before the parser for the entity is executed).------ Usage with Trifecta to get entities tagged with location information (see--- also, 'Language.Thrift.Parser.Trifecta.thriftIDL'):------ > Trifecta.parseFromFile (thriftIDL Trifecta.position) "service.thrift"------ Usage with Attoparsec without any annotations:------ > Attoparsec.parse (thriftIDL (return ())) document----thriftIDL :: (MonadPlus p, TokenParsing p) => p n -> p (T.Program n)-thriftIDL getAnnot = runThriftParser getAnnot program+-- | 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) --- | Keeps track of the last docstring seen by the system so that we can--- attach it to entities.-newtype ParserState = ParserState- { parserLastDocstring :: T.Docstring- } deriving (Show, Ord, Eq)+-- | 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)) --- | The ThriftParser wraps another parser @p@ with some extra state. It also--- allows injecting a configurable action @(p n)@ which produces annotations--- that will be attached to entities in the Thrift file. See 'thriftIDLParser'--- for an example.-newtype ThriftParser p n a =- ThriftParser (StateT ParserState (ReaderT (p n) p) a)- deriving- ( Functor- , Applicative- , Alternative- , Monad- , MonadPlus- , Parsing- , CharParsing- )+-- | @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 --- | Returns the last docstring recorded by the system and clears it from the--- parser state.-lastDocstring :: Monad p => ThriftParser p n T.Docstring-lastDocstring = ThriftParser $ do- s <- State.gets parserLastDocstring- State.put (ParserState Nothing)+-- | 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 --- | Get an exeecutable parser from the given ThriftParser.-runThriftParser- :: (MonadPlus p, TokenParsing p)- => p n- -- ^ How to get annotations from the underlying parser. If this is not- -- something you need to use, make it @return ()@ and generated types will- -- be annotated with @()@.- -> ThriftParser p n a- -> p a-runThriftParser getAnnot (ThriftParser p) =- Reader.runReaderT (State.evalStateT p (ParserState Nothing)) getAnnot+-- | 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}) -instance- (TokenParsing p, MonadPlus p) => TokenParsing (ThriftParser p n) where- -- Docstring parsing works by cheating. We define docstrings as- -- whitespace, but we record it when we move over it. If we run into- -- another newline or other comments after seeing the docstring's "*/\n",- -- we clear the docstring out because it's most likely not attached to the- -- entity that follows. So for docstrings to be attached, there must be a- -- single newline between "*/" and the entity.- someSpace = skipSome $ readDocstring <|> skipComments <|> skipSpace+ 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- skipSpace = choice [- newline *> clearDocstring- , ThriftParser someSpace- ]+ 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) - skipComments = choice [- char '#' *> skipLine- , text "//" *> skipLine- , text "/*" *> skipCStyleComment- ] *> clearDocstring- skipLine = skipMany (satisfy (/= '\n')) <* newline- skipCStyleComment = choice [- text "*/" *> pure ()- , skipSome (noneOf "/*") *> skipCStyleComment- , oneOf "/*" *> skipCStyleComment- ]+ line <- Text.pack <$> P.many commentChar - -- TODO this is really ugly. use some sort of docstring parser instead- clearDocstring = ThriftParser $ State.put (ParserState Nothing)- readDocstring = text "/**" *> loop []- where- saveDocstring s = unless (Text.null s') $- ThriftParser . State.put . ParserState . Just $ s'- where- s' = sanitizeDocstring s- loop chunks = choice [- text "*/" *> optional (newline <|> space) *>- saveDocstring (Text.strip . Text.concat $ reverse chunks)- , Text.pack <$> some (noneOf "/*") >>= loop . (:chunks)- , Text.singleton <$> oneOf "/*" >>= loop . (:chunks)- ]- sanitizeDocstring :: Text -> Text- sanitizeDocstring =- Text.intercalate "\n"- . map (Text.dropWhile ignore)- . Text.lines- where ignore c = c == '*' || c == ' '+ -- 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) --- | Type of identifiers allowed by Thrift.-idStyle- :: forall p n. (TokenParsing p, MonadPlus p)- => IdentifierStyle (ThriftParser p n)-idStyle = (emptyIdents :: IdentifierStyle (ThriftParser p n))- { _styleStart = letter <|> char '_'- , _styleLetter = alphaNum <|> oneOf "_."- } +symbolic :: P.Stream s Char => Char -> Parser s ()+symbolic c = void $ PL.symbol whiteSpace [c] --- | Constructor for reserved keywords.-reserved :: (TokenParsing p, MonadPlus p) => Text -> ThriftParser p n ()-reserved = reserveText idStyle+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 --- | Top-level parser to parse complete Thrift documents.-program :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Program n)-program = whiteSpace >>- T.Program- <$> many (header <* optionalSep)- <*> many (definition <* optionalSep)- <* eof+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 :: (TokenParsing p, MonadPlus p) => ThriftParser p n Text-literal = stringLiteral <|> stringLiteral'+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 :: (TokenParsing p, MonadPlus p) => ThriftParser p n Text-identifier = ident idStyle+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 :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Header n)-header = choice+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 :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Include n)-include = reserved "include" >> withSrcAnnot (T.Include <$> literal)+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 :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Namespace n)-namespace = choice+namespace :: P.Stream s Char => Parser s (T.Namespace P.SourcePos)+namespace = P.choice [ reserved "namespace" >>- withSrcAnnot (T.Namespace <$> (text "*" <|> identifier) <*> identifier)+ withPosition (T.Namespace <$> (star <|> identifier) <*> identifier) , reserved "cpp_namespace" >>- withSrcAnnot (T.Namespace "cpp" <$> identifier)+ withPosition (T.Namespace "cpp" <$> identifier) , reserved "php_namespace" >>- withSrcAnnot (T.Namespace "php" <$> identifier)+ withPosition (T.Namespace "php" <$> identifier) , reserved "py_module" >>- withSrcAnnot (T.Namespace "py" <$> identifier)+ withPosition (T.Namespace "py" <$> identifier) , reserved "perl_package" >>- withSrcAnnot (T.Namespace "perl" <$> identifier)+ withPosition (T.Namespace "perl" <$> identifier) , reserved "ruby_namespace" >>- withSrcAnnot (T.Namespace "rb" <$> identifier)+ withPosition (T.Namespace "rb" <$> identifier) , reserved "java_package" >>- withSrcAnnot (T.Namespace "java" <$> identifier)+ withPosition (T.Namespace "java" <$> identifier) , reserved "cocoa_package" >>- withSrcAnnot (T.Namespace "cocoa" <$> identifier)+ withPosition (T.Namespace "cocoa" <$> identifier) , reserved "csharp_namespace" >>- withSrcAnnot (T.Namespace "csharp" <$> identifier)+ withPosition (T.Namespace "csharp" <$> identifier) ]+ where+ star = symbolic '*' >> pure "*" --- | Retrieve the current source annotation.-getSrcAnnot :: Monad p => ThriftParser p n n-getSrcAnnot = ThriftParser . lift $ Reader.ask >>= lift --- | Convenience wrapper for parsers expecting a source annotation.+-- | Convenience wrapper for parsers expecting a position. ----- The source annotation will be retrieved BEFORE the parser itself is--- executed.-withSrcAnnot- :: (Functor p, Monad p)- => ThriftParser p n (n -> a) -> ThriftParser p n a-withSrcAnnot p = getSrcAnnot >>= \annot -> p <*> pure annot+-- 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--- source annotation.++-- | Convenience wrapper for parsers that expect a docstring and a position. -- -- > data Foo = Foo { bar :: Bar, doc :: Docstring, pos :: Delta } -- >--- > parseFoo = docstring $ Foo <$> parseBar-docstring- :: (Functor p, Monad p)- => ThriftParser p n (T.Docstring -> n -> a) -> ThriftParser p n a-docstring p = lastDocstring >>= \s -> do- annot <- getSrcAnnot- p <*> pure s <*> pure annot+-- > 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- :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n)-definition = whiteSpace >> choice+definition :: P.Stream s Char => Parser s (T.Definition P.SourcePos)+definition = whiteSpace >> P.choice [ T.ConstDefinition <$> constant , T.TypeDefinition <$> typeDefinition , T.ServiceDefinition <$> service@@ -297,8 +355,8 @@ -- | A type definition.-typeDefinition :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)-typeDefinition = choice+typeDefinition :: P.Stream s Char => Parser s (T.Type P.SourcePos)+typeDefinition = P.choice [ T.TypedefType <$> typedef , T.EnumType <$> enum , T.SenumType <$> senum@@ -311,9 +369,9 @@ -- | A typedef is just an alias for another type. -- -- > typedef common.Foo Bar-typedef :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Typedef n)-typedef = reserved "typedef" >>- docstring (T.Typedef <$> typeReference <*> identifier <*> typeAnnotations)+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.@@ -321,12 +379,13 @@ -- > enum Role { -- > User = 1, Admin -- > }-enum :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Enum n)-enum = reserved "enum" >>- docstring (T.Enum+enum :: P.Stream s Char => Parser s (T.Enum P.SourcePos)+enum = reserved "enum" >> withDocstring+ ( T.Enum <$> identifier <*> braces (many enumDef)- <*> typeAnnotations)+ <*> typeAnnotations+ ) -- | A @struct@.@@ -335,12 +394,13 @@ -- > 1: string name -- > 2: Role role = Role.User; -- > }-struct :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Struct n)-struct = reserved "struct" >>- docstring (T.Struct+struct :: P.Stream s Char => Parser s (T.Struct P.SourcePos)+struct = reserved "struct" >> withDocstring+ ( T.Struct <$> identifier <*> braces (many field)- <*> typeAnnotations)+ <*> typeAnnotations+ ) -- | A @union@ of types.@@ -349,12 +409,13 @@ -- > 1: string stringValue; -- > 2: i32 intValue; -- > }-union :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Union n)-union = reserved "union" >>- docstring (T.Union+union :: P.Stream s Char => Parser s (T.Union P.SourcePos)+union = reserved "union" >> withDocstring+ ( T.Union <$> identifier <*> braces (many field)- <*> typeAnnotations)+ <*> typeAnnotations+ ) -- | An @exception@ that can be raised by service methods.@@ -363,27 +424,28 @@ -- > 1: optional string message -- > 2: required string username -- > }-exception :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Exception n)-exception = reserved "exception" >>- docstring (T.Exception+exception :: P.Stream s Char => Parser s (T.Exception P.SourcePos)+exception = reserved "exception" >> withDocstring+ ( T.Exception <$> identifier <*> braces (many field)- <*> typeAnnotations)+ <*> typeAnnotations+ ) -- | Whether a field is @required@ or @optional@.-fieldRequiredness- :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.FieldRequiredness-fieldRequiredness = choice [- reserved "required" *> pure T.Required+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 :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Field n)-field = docstring $+field :: P.Stream s Char => Parser s (T.Field P.SourcePos)+field = withDocstring $ T.Field- <$> optional (integer <* symbolic ':')+ <$> optional (integer <* colon) <*> optional fieldRequiredness <*> typeReference <*> identifier@@ -393,32 +455,33 @@ -- | A value defined inside an @enum@.-enumDef :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.EnumDef n)-enumDef = docstring $+enumDef :: P.Stream s Char => Parser s (T.EnumDef P.SourcePos)+enumDef = withDocstring $ T.EnumDef <$> identifier- <*> optional (equals *> integer)+ <*> 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 :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Senum n)-senum = reserved "senum" >> docstring- (T.Senum+-- | 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)+ <*> typeAnnotations+ ) -- | A 'const' definition. -- -- > const i32 code = 1;-constant :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Const n)+constant :: P.Stream s Char => Parser s (T.Const P.SourcePos) constant = do reserved "const"- docstring $+ withDocstring $ T.Const <$> typeReference <*> (identifier <* equals)@@ -427,11 +490,11 @@ -- | A constant value literal.-constantValue- :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.ConstValue n)-constantValue = withSrcAnnot $ choice [- either T.ConstInt T.ConstFloat- <$> integerOrDouble+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@@ -439,12 +502,11 @@ ] -constList- :: (TokenParsing p, MonadPlus p) => ThriftParser p n [T.ConstValue n]+constList :: P.Stream s Char => Parser s [T.ConstValue P.SourcePos] constList = symbolic '[' *> loop [] where- loop xs = choice [- symbolic ']' *> return (reverse xs)+ loop xs = P.choice+ [ symbolic ']' *> return (reverse xs) , (:) <$> (constantValue <* optionalSep) <*> pure xs >>= loop@@ -452,11 +514,11 @@ constMap- :: (TokenParsing p, MonadPlus p)- => ThriftParser p n [(T.ConstValue n, T.ConstValue n)]+ :: P.Stream s Char+ => Parser s [(T.ConstValue P.SourcePos, T.ConstValue P.SourcePos)] constMap = symbolic '{' *> loop [] where- loop xs = choice [+ loop xs = P.choice [ symbolic '}' *> return (reverse xs) , (:) <$> (constantValuePair <* optionalSep) <*> pure xs@@ -465,30 +527,29 @@ constantValuePair- :: (TokenParsing p, MonadPlus p)- => ThriftParser p n (T.ConstValue n, T.ConstValue n)+ :: 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- :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.TypeReference n)-typeReference = choice [- baseType+typeReference :: P.Stream s Char => Parser s (T.TypeReference P.SourcePos)+typeReference = P.choice+ [ baseType , containerType- , withSrcAnnot (T.DefinedType <$> identifier)+ , withPosition (T.DefinedType <$> identifier) ] baseType- :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.TypeReference n)-baseType = withSrcAnnot $- choice [reserved s *> (v <$> typeAnnotations) | (s, v) <- bases]+ :: 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)+ bases =+ [ ("string", T.StringType) , ("binary", T.BinaryType) , ("slist", T.SListType) , ("bool", T.BoolType)@@ -502,9 +563,9 @@ containerType- :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.TypeReference n)-containerType = withSrcAnnot $- choice [mapType, setType, listType] <*> typeAnnotations+ :: 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)@@ -517,10 +578,10 @@ -- > service MyService { -- > // ... -- > }-service :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Service n)+service :: P.Stream s Char => Parser s (T.Service P.SourcePos) service = do reserved "service"- docstring $+ withDocstring $ T.Service <$> identifier <*> optional (reserved "extends" *> identifier)@@ -532,8 +593,8 @@ -- -- > Foo getFoo() throws (1: FooDoesNotExist doesNotExist); -- > oneway void putBar(1: Bar bar);-function :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Function n)-function = docstring $+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)@@ -550,24 +611,16 @@ -- -- These do not usually affect code generation but allow for custom logic if -- writing your own code generator.-typeAnnotations- :: (TokenParsing p, MonadPlus p)- => ThriftParser p n [T.TypeAnnotation]+typeAnnotations :: P.Stream s Char => Parser s [T.TypeAnnotation] typeAnnotations = parens (many typeAnnotation) <|> pure [] -typeAnnotation- :: (TokenParsing p, MonadPlus p)- => ThriftParser p n T.TypeAnnotation+typeAnnotation :: P.Stream s Char => Parser s T.TypeAnnotation typeAnnotation = T.TypeAnnotation <$> identifier <*> (optional (equals *> literal) <* optionalSep) -optionalSep :: (TokenParsing p, MonadPlus p) => ThriftParser p n ()+optionalSep :: P.Stream s Char => Parser s () optionalSep = void $ optional (comma <|> semi)---equals :: (TokenParsing p, MonadPlus p) => ThriftParser p n ()-equals = void $ symbolic '='
− Language/Thrift/Parser/Trifecta.hs
@@ -1,23 +0,0 @@--- |--- Module : Language.Thrift.Parser.Trifecta--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ Provides a parser for Thrift IDLs based on Trifecta.----module Language.Thrift.Parser.Trifecta (thriftIDL) where--import Text.Trifecta-import Text.Trifecta.Delta (Delta)--import qualified Language.Thrift.Parser as P-import qualified Language.Thrift.Types as T---- | Parser for Thrift IDLs based on Trifecta.------ Use with 'parseFromFile', 'parseByteString' or friends.-thriftIDL :: Parser (T.Program Delta)-thriftIDL = P.thriftIDL position
Language/Thrift/Pretty.hs view
@@ -11,16 +11,23 @@ -- Maintainer : Abhinav Gupta <mail@abhinavg.net> -- Stability : experimental ----- This module provides a pretty printer for Thrift IDLs. The pretty printer--- preserves docstrings specified for types.+-- 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 (- prettyPrint+ prettyPrintHighlighted+ , prettyPrint -- * Components @@ -45,12 +52,394 @@ , typeReference , constantValue + , docstring+ -- * Configuration , Config(..) , defaultConfig ) where -#define PrettyPrinter Text.PrettyPrint.Leijen-#include "Pretty/PrettyInc.hs"-#undef PrettyPrinter+#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 "="
− Language/Thrift/Pretty/ANSI.hs
@@ -1,65 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--- |--- Module : Language.Thrift.Pretty.ANSI--- Copyright : (c) Abhinav Gupta 2015--- License : BSD3------ Maintainer : Abhinav Gupta <mail@abhinavg.net>--- Stability : experimental------ This module provides a pretty printer for Thrift IDLs that produces colored--- output. It is essentially the same as "Language.Thrift.Pretty" with the--- exception of the colored output.------ The behavior of the printer can be customized using 'Config' objects.------ The system uses ANSI escape codes to produce colored output. That makes the--- text output of this pretty printer unparseable without printing to a--- supported terminal. If this is undesirable, use--- 'Text.PrettyPrint.ANSI.Leijen.plain' to discard coloring information, or--- simply use the "Language.Thrift.Pretty" pretty printer instead.------ As with "Language.Thrift.Pretty", this module exports instances of the--- 'Pretty' typeclass for elements of the AST.-module Language.Thrift.Pretty.ANSI- (- prettyPrint-- -- * Components-- , program-- , header- , include- , namespace-- , definition- , constant- , typeDefinition- , service-- , typedef- , enum- , struct- , union- , exception- , senum-- , typeReference- , constantValue-- -- * Configuration-- , Config(..)- , defaultConfig- ) where--#define PrettyPrinter Text.PrettyPrint.ANSI.Leijen-#define PrettyPrinterSupportsHighlighting-#include "PrettyInc.hs"-#undef PrettyPrinterSupportsHighlighting-#undef PrettyPrinter
− Language/Thrift/Pretty/PrettyInc.hs
@@ -1,383 +0,0 @@--- This file implements the prettty printer. It is included with wl-pprint and--- ansi-wl-pprint in scope.--#if __GLASGOW_HASKELL__ >= 709-import Prelude hiding (lines, (<$>))-#else-import Prelude hiding (lines)-#endif--import Data.Text (Text, lines, strip, unpack)-import PrettyPrinter (Doc, align, double, dquotes, empty, nest, enclose, group, hcat, Pretty(..),- hsep, integer, line, linebreak, space, vsep, (<$$>),- (<$>), (<+>), (<>))--import qualified PrettyPrinter as P--import qualified Language.Thrift.Internal.Types as T--import Language.Thrift.Pretty.Types---bold, dullblue, magenta, yellow, cyan :: Doc -> Doc-#ifdef PrettyPrinterSupportsHighlighting-bold = P.bold-dullblue = P.dullblue-magenta = P.magenta-yellow = P.yellow-cyan = P.cyan-#else-bold = id-dullblue = id-magenta = id-yellow = id-cyan = id-#endif----- | Top-level pretty printer for Thrift documents that uses the default--- configuration ('defaultConfig') for pretty printing.-prettyPrint :: T.Program ann -> Doc-prettyPrint = program defaultConfig----- | Pretty print a Thrift IDL.-program :: Config -> T.Program ann -> Doc-program c T.Program{..} =- vsep (map header programHeaders) <$> line <>- map (definition c) programDefinitions `sepBy` (line <> line)--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 . 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 = case lines (strip t) of- [] -> y- ls -> dullblue (wrapComments ls) <$> y- where- wrapComments ls = align . vsep- $ text "/**"- : map (\l -> text " *" <+> text l) ls- ++ [text " */"]--infixr 1 $$---block :: Int -> Doc -> [Doc] -> Doc-block indent s items = 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 "="
− Language/Thrift/Pretty/Types.hs
@@ -1,15 +0,0 @@-module Language.Thrift.Pretty.Types- ( Config(..)- , defaultConfig- ) where---- | 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
Language/Thrift/Types.hs view
@@ -9,14 +9,19 @@ -- This module defines types that compose a Thrift IDL file. -- -- Most of the types have an optional @srcAnnot@ parameter that represents a--- parser-specific source annotation. With @trifecta@ this can hold the--- 'Text.Trifecta.Delta.Delta'. If you do not have need of this, you can use--- @()@ as the parameter.+-- 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 ()-import Language.Thrift.Pretty.ANSI ()
README.md view
@@ -6,19 +6,14 @@ field, above which they were added. These are retained when the document is sent through the pretty printer. -The parser uses [`parsers`] to allow plugging in the underlying parser. A-default [`trifecta`] based parser is provided.--The pretty printer supports both, [`wl-pprint`] and [`ansi-wl-pprint`]. The-`ansi-wl-pprint`-based pretty printer produces colored output.+The parser uses [`megaparsec`] and the pretty printer [`ansi-wl-pprint`]. The+pretty printer can produce syntax highlighted output. Haddock-generated docs are available on [Hackage] and [here]. [build-status]: https://travis-ci.org/abhinav/language-thrift.svg?branch=master [Thrift IDL format]: http://thrift.apache.org/docs/idl- [`parsers`]: http://hackage.haskell.org/package/parsers- [`trifecta`]: http://hackage.haskell.org/package/trifecta- [`wl-pprint`]: http://hackage.haskell.org/package/wl-pprint+ [`megaparsec`]: http://hackage.haskell.org/package/megaparsec [`ansi-wl-pprint`]: http://hackage.haskell.org/package/ansi-wl-pprint [Hackage]: http://hackage.haskell.org/package/language-thrift [here]: http://abhinavg.net/language-thrift/
examples/generateHaskellTypes.hs view
@@ -18,25 +18,18 @@ import Data.Maybe (isNothing) import Data.Text (Text, unpack) import System.Exit (exitFailure)-import System.IO (stderr, stdout)+import System.IO (hPrint, hPutStrLn, stderr, stdout) -import qualified Data.Text as Text-import qualified Text.PrettyPrint.ANSI.Leijen as AnsiPP-import Text.PrettyPrint.Leijen hiding (list, tupled)-import Text.Trifecta (Result (..), parseString)-import Text.Trifecta.Delta (Delta (Directed))+import Text.PrettyPrint.ANSI.Leijen hiding (list, tupled) -import Language.Thrift.Parser.Trifecta (thriftIDL)+import qualified Data.Text as Text +import Language.Thrift.Parser (parse)+ import qualified Language.Thrift.Types as T die :: String -> IO a-die s = putStrLn s >> exitFailure---- | '<$>' with the arguments flipped.-(<&>) :: Functor f => f a -> (a -> b) -> f b-(<&>) = flip fmap-infixl 1 <&>+die s = hPutStrLn stderr s >> exitFailure ($$) :: T.Docstring -> Doc -> Doc ($$) Nothing y = y@@ -262,9 +255,9 @@ main :: IO () main = do- result <- getContents <&> parseString thriftIDL (Directed "stdin" 0 0 0 0)+ result <- parse "stdin" `fmap` getContents case result of- Success p -> generateOutput p- Failure doc -> do- AnsiPP.displayIO stderr $ AnsiPP.renderPretty 0.8 80 doc+ Right p -> generateOutput p+ Left err -> do+ hPrint stderr err die "Parse Failed"
examples/reformatIDL.hs view
@@ -6,18 +6,16 @@ -- -- Docstrings in the IDL are preserved but COMMENTS WILL BE LOST. -import System.IO (stderr)-import Text.Trifecta (Result (..), parseString)-import Text.Trifecta.Delta (Delta (Directed))+import System.Exit (exitFailure)+import System.IO (stderr) import qualified Text.PrettyPrint.ANSI.Leijen as PP -import Language.Thrift.Parser.Trifecta (thriftIDL)+import Language.Thrift.Parser (parse) main :: IO () main = do- result <-- parseString thriftIDL (Directed "stdin" 0 0 0 0) `fmap` getContents+ result <- parse "stdin" `fmap` getContents case result of- Success p -> PP.putDoc (PP.pretty p) >> putStrLn ""- Failure doc -> PP.displayIO stderr $ PP.renderPretty 0.8 80 doc+ Right p -> PP.putDoc (PP.pretty p) >> putStrLn ""+ Left err -> print err >> exitFailure
language-thrift.cabal view
@@ -1,5 +1,5 @@ name: language-thrift-version: 0.7.0.1+version: 0.8.0.0 cabal-version: >=1.10 build-type: Simple license: BSD3@@ -13,10 +13,10 @@ category: Language author: Abhinav Gupta extra-source-files:- Language/Thrift/Pretty/PrettyInc.hs README.md CHANGES.md examples/*.hs+ test/data/*.txt source-repository head type: git@@ -25,22 +25,16 @@ library exposed-modules: Language.Thrift.Parser- Language.Thrift.Parser.Trifecta Language.Thrift.Pretty- Language.Thrift.Pretty.ANSI Language.Thrift.Types build-depends: base >=4.7 && <4.9, ansi-wl-pprint >=0.6 && <0.7,- lens >=4.0 && <5.0,- parsers >=0.12 && <0.13,+ megaparsec >=4.0 && <5.0, text >=1.2,- transformers -any,- trifecta >=1.5 && <1.6,- wl-pprint >=1.1+ transformers -any default-language: Haskell2010 other-modules:- Language.Thrift.Pretty.Types Language.Thrift.Internal.Types ghc-options: -Wall @@ -52,11 +46,9 @@ ansi-wl-pprint -any, hspec >=2.0, hspec-discover >=2.1,+ megaparsec -any, QuickCheck >=2.5,- parsers -any, text -any,- trifecta -any,- wl-pprint -any, language-thrift -any default-language: Haskell2010 hs-source-dirs: test
test/Language/Thrift/Arbitrary.hs view
@@ -85,7 +85,7 @@ shrink = genericShrink arbitrary = T.Namespace <$> elements scopes <*> arbitrary <*> pure () where- scopes = ["py", "rb", "java", "hs", "cpp"]+ scopes = ["*", "py", "rb", "java", "hs", "cpp"] instance Arbitrary (T.Definition ()) where
test/Language/Thrift/ParserSpec.hs view
@@ -1,12 +1,16 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} module Language.Thrift.ParserSpec (spec) where #if __GLASGOW_HASKELL__ < 709 import Control.Applicative #endif +import Control.Monad+import Data.Text (pack) import Test.Hspec-import Text.Parser.Combinators (eof)+import Text.Megaparsec (SourcePos, eof, skipMany, spaceChar) import TestUtils @@ -17,8 +21,41 @@ spec = describe "Parser" $ do it "can parse empty documents" $- assertParses P.program (T.Program [] []) ""+ parseSuccessCases P.program $ map (, T.Program [] [])+ [ ""+ , "// line comment at EOF"+ , "# line comment at EOF\n"+ , "/** docstring at EOF */"+ , "/** docstring with space\nand newline at EOF\n\t\t*/ "+ , "/* comment\n\tat eof\n\t */"+ ] + it "can parse docstrings" $ forM_+ [ ( return "/** foo */", "foo " )+ , ( return "/** foo\n */", "foo" )+ , ( readFile "test/data/docstring-1.txt"+ , "Hello. This is the first\n" +++ "paragraph.\n\n" +++ " This is some text indented 4 spaces,\n" +++ " spread across multiple lines.\n\n" +++ "Back."+ )+ , ( readFile "test/data/docstring-2.txt"+ , "The docstring itself is indented 4 spaces.\n\n" +++ "And has a missing * in between."+ )+ ] $ \(i, o) -> do+ input <- i+ assertParses (skipMany spaceChar *> P.docstring) (pack o) input++ it "can parse basic constants" $ parseSuccessCases P.constantValue+ [ ("42", T.ConstInt 42 ())+ , ("0x2a", T.ConstInt 42 ())+ , ("1.2", T.ConstFloat 1.2 ())+ , ("foo", T.ConstIdentifier "foo" ())+ , ("\"foo\"", T.ConstLiteral "foo" ())+ ]+ testParseFailure testParseFailure :: Spec@@ -45,3 +82,9 @@ parseFailureCases :: Show a => Parser a -> [String] -> Expectation parseFailureCases p = mapM_ (p `shouldNotParse`)++parseSuccessCases+ :: (Show (a ()), Eq (a ()), Functor a)+ => Parser (a SourcePos) -> [(String, a ())] -> Expectation+parseSuccessCases parser = mapM_ $ \(input, value) ->+ assertParses (void `fmap` parser) value input
test/Language/Thrift/TypesSpec.hs view
@@ -1,80 +1,69 @@ {-# LANGUAGE OverloadedStrings #-} module Language.Thrift.TypesSpec (spec) where +import Control.Monad (void) import Test.Hspec import Test.Hspec.QuickCheck-import Text.Parser.Token (whiteSpace)+import Text.Megaparsec (SourcePos) -import qualified Text.PrettyPrint.ANSI.Leijen as PPA (Doc, plain)-import qualified Text.PrettyPrint.Leijen as PP (Doc)+import qualified Text.PrettyPrint.ANSI.Leijen as PP (Doc, plain) import Language.Thrift.Arbitrary () import TestUtils -import qualified Language.Thrift.Parser as P-import qualified Language.Thrift.Pretty as PP-import qualified Language.Thrift.Pretty.ANSI as PPA+import qualified Language.Thrift.Parser as P+import qualified Language.Thrift.Pretty as PP spec :: Spec spec = describe "Parser and Printer" $ do prop "can round-trip type references" $- roundtrip PP.typeReference PPA.typeReference P.typeReference+ roundtrip PP.typeReference P.typeReference prop "can round-trip constant values" $- roundtrip PP.constantValue PPA.constantValue P.constantValue+ roundtrip PP.constantValue P.constantValue prop "can round-trip typedefs" $- roundtrip PP.typedef PPA.typedef (whiteSpace >> P.typedef)+ roundtrip PP.typedef (P.whiteSpace >> P.typedef) prop "can round-trip enums" $- roundtrip PP.enum PPA.enum (whiteSpace >> P.enum)+ roundtrip PP.enum (P.whiteSpace >> P.enum) prop "can round-trip structs" $- roundtrip PP.struct PPA.struct (whiteSpace >> P.struct)+ roundtrip PP.struct (P.whiteSpace >> P.struct) prop "can round-trip unions" $- roundtrip PP.union PPA.union (whiteSpace >> P.union)+ roundtrip PP.union (P.whiteSpace >> P.union) prop "can round-trip exceptions" $- roundtrip PP.exception PPA.exception (whiteSpace >> P.exception)+ roundtrip PP.exception (P.whiteSpace >> P.exception) prop "can round-trip senums" $- roundtrip PP.senum PPA.senum (whiteSpace >> P.senum)+ roundtrip PP.senum (P.whiteSpace >> P.senum) prop "can round-trip services" $- roundtrip PP.service PPA.service (whiteSpace >> P.service)+ roundtrip PP.service (P.whiteSpace >> P.service) prop "can round-trip constants" $- roundtrip PP.constant PPA.constant (whiteSpace >> P.constant)+ roundtrip PP.constant (P.whiteSpace >> P.constant) prop "can round-trip includes" $- roundtrip- (const PP.include)- (const PPA.include)- (whiteSpace >> P.include)+ roundtrip (const PP.include) (P.whiteSpace >> P.include) prop "can round-trip namespaces" $- roundtrip- (const PP.namespace)- (const PPA.namespace)- (whiteSpace >> P.namespace)+ roundtrip (const PP.namespace) (P.whiteSpace >> P.namespace) prop "can round-trip documents" $- roundtrip PP.program PPA.program P.program+ roundtrip PP.program P.program roundtrip- :: (Show a, Eq a)- => (PP.Config -> a -> PP.Doc)- -> (PPA.Config -> a -> PPA.Doc)- -> Parser a -> a -> IO ()-roundtrip printer ansiPrinter parser value = do- assertParses parser value- (show $ printer (PP.Config 4) value)-- -- For the ANSI pretty printer, we need to discard the color information- -- for the document to be parseable.- assertParses parser value- (show . PPA.plain $ ansiPrinter (PPA.Config 4) value)+ :: (Show (n ()), Eq (n ()), Functor n)+ => (PP.Config -> n () -> PP.Doc)+ -> Parser (n SourcePos)+ -> n ()+ -> IO ()+roundtrip printer parser value =+ assertParses (void `fmap` parser) value+ (show . PP.plain $ printer (PP.Config 4) value)
test/Main.hs view
@@ -7,5 +7,5 @@ main :: IO () main = hspecWith- defaultConfig { configQuickCheckMaxSize = Just 25 }+ defaultConfig { configQuickCheckMaxSize = Just 30 } Spec.spec
test/TestUtils.hs view
@@ -5,40 +5,40 @@ , Parser ) where -import Test.Hspec (expectationFailure, shouldBe)--import qualified Text.Trifecta as T-import qualified Text.Trifecta.Delta as T+import Control.Monad (when)+import Test.Hspec (expectationFailure) -import qualified Language.Thrift.Parser as P+import qualified Language.Thrift.Parser as T+import qualified Text.Megaparsec as P -type Parser a = P.ThriftParser T.Parser () a+type Parser = T.Parser String -parse :: Parser a -> String -> T.Result a-parse parser = T.parseString trifectaParser (T.Directed "memory" 0 0 0 0)- where- trifectaParser = P.runThriftParser (return ()) parser+parse :: Parser a -> String -> Either P.ParseError a+parse parser = P.parse (T.runParser parser) "memory" -- | @assertParses parser expected input@ will assert that running @parser@ on -- @input@ will produce @expected@. assertParses :: (Show a, Eq a) => Parser a -> a -> String -> IO () assertParses parser expected input = case parse parser input of- T.Success got -> got `shouldBe` expected- T.Failure msg -> expectationFailure $+ Right got -> when (got /= expected) $ expectationFailure $+ "\n\texpected: " ++ show expected +++ "\n\tgot: " ++ show got +++ "\n\tin:\n" ++ indent 8 input+ Left err -> expectationFailure $ "failed to parse:\n" ++ indent 8 input ++ "\n\texpected: " ++ show expected ++- "\n\tgot (error): " ++ show msg+ "\n\tgot (error): " ++ show err -- | @parser `shouldNotParse` input@ will assert that running @parser@ on -- @input@ will fail. shouldNotParse :: Show a => Parser a -> String -> IO () shouldNotParse parser input = case parse parser input of- T.Success result -> expectationFailure $+ Right result -> expectationFailure $ "expected parse failure for\n" ++ indent 8 input ++ "\n\tgot success: " ++ show result- T.Failure _ -> return ()+ Left _ -> return () -- | Indent all lines in the string the given number of spaces.
+ test/data/docstring-1.txt view
@@ -0,0 +1,9 @@+/**+ * Hello. This is the first+ * paragraph.+ *+ * This is some text indented 4 spaces,+ * spread across multiple lines.+ *+ * Back.+ */
+ test/data/docstring-2.txt view
@@ -0,0 +1,5 @@+ /**+ * The docstring itself is indented 4 spaces.++ * And has a missing * in between.+ */