module Language.Thrift.Parser
( thriftIDL
, program
, header
, include
, namespace
, definition
, constant
, typeDefinition
, service
, typedef
, enum
, struct
, union
, exception
, senum
, typeReference
, constantValue
, ThriftParser
, runThriftParser
) 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 qualified Control.Monad.Trans.Reader as Reader
import qualified Control.Monad.Trans.State as State
import qualified Data.Text as Text
import qualified Language.Thrift.Types as T
thriftIDL :: (MonadPlus p, TokenParsing p) => p n -> p (T.Program n)
thriftIDL getAnnot = runThriftParser getAnnot program
newtype ParserState = ParserState
{ parserLastDocstring :: T.Docstring
} deriving (Show, Ord, Eq)
newtype ThriftParser p n a =
ThriftParser (StateT ParserState (ReaderT (p n) p) a)
deriving
( Functor
, Applicative
, Alternative
, Monad
, MonadPlus
, Parsing
, CharParsing
)
lastDocstring :: Monad p => ThriftParser p n T.Docstring
lastDocstring = ThriftParser $ do
s <- State.gets parserLastDocstring
State.put (ParserState Nothing)
return s
runThriftParser
:: (MonadPlus p, TokenParsing p)
=> p n
-> ThriftParser p n a
-> p a
runThriftParser getAnnot (ThriftParser p) =
Reader.runReaderT (State.evalStateT p (ParserState Nothing)) getAnnot
instance
(TokenParsing p, MonadPlus p) => TokenParsing (ThriftParser p n) where
someSpace = skipSome $ readDocstring <|> skipComments <|> skipSpace
where
skipSpace = choice [
newline *> clearDocstring
, ThriftParser someSpace
]
skipComments = choice [
char '#' *> skipLine
, text "//" *> skipLine
, text "/*" *> skipCStyleComment
] *> clearDocstring
skipLine = skipMany (satisfy (/= '\n')) <* newline
skipCStyleComment = choice [
text "*/" *> pure ()
, skipSome (noneOf "/*") *> skipCStyleComment
, oneOf "/*" *> skipCStyleComment
]
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 == ' '
idStyle
:: forall p n. (TokenParsing p, MonadPlus p)
=> IdentifierStyle (ThriftParser p n)
idStyle = (emptyIdents :: IdentifierStyle (ThriftParser p n))
{ _styleStart = letter <|> char '_'
, _styleLetter = alphaNum <|> oneOf "_."
}
reserved :: (TokenParsing p, MonadPlus p) => Text -> ThriftParser p n ()
reserved = reserveText idStyle
program :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Program n)
program = whiteSpace >>
T.Program
<$> many (header <* optionalSep)
<*> many (definition <* optionalSep)
<* eof
literal :: (TokenParsing p, MonadPlus p) => ThriftParser p n Text
literal = stringLiteral <|> stringLiteral'
identifier :: (TokenParsing p, MonadPlus p) => ThriftParser p n Text
identifier = ident idStyle
header :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Header n)
header = choice
[ T.HeaderInclude <$> include
, T.HeaderNamespace <$> namespace
]
include :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Include n)
include = reserved "include" >> withSrcAnnot (T.Include <$> literal)
namespace :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Namespace n)
namespace = choice
[ reserved "namespace" >>
withSrcAnnot (T.Namespace <$> (text "*" <|> identifier) <*> identifier)
, reserved "cpp_namespace" >>
withSrcAnnot (T.Namespace "cpp" <$> identifier)
, reserved "php_namespace" >>
withSrcAnnot (T.Namespace "php" <$> identifier)
, reserved "py_module" >>
withSrcAnnot (T.Namespace "py" <$> identifier)
, reserved "perl_package" >>
withSrcAnnot (T.Namespace "perl" <$> identifier)
, reserved "ruby_namespace" >>
withSrcAnnot (T.Namespace "rb" <$> identifier)
, reserved "java_package" >>
withSrcAnnot (T.Namespace "java" <$> identifier)
, reserved "cocoa_package" >>
withSrcAnnot (T.Namespace "cocoa" <$> identifier)
, reserved "csharp_namespace" >>
withSrcAnnot (T.Namespace "csharp" <$> identifier)
]
getSrcAnnot :: Monad p => ThriftParser p n n
getSrcAnnot = ThriftParser . lift $ Reader.ask >>= lift
withSrcAnnot
:: (Functor p, Monad p)
=> ThriftParser p n (n -> a) -> ThriftParser p n a
withSrcAnnot p = getSrcAnnot >>= \annot -> p <*> pure annot
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
definition
:: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n)
definition = whiteSpace >> choice
[ T.ConstDefinition <$> constant
, T.TypeDefinition <$> typeDefinition
, T.ServiceDefinition <$> service
]
typeDefinition :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)
typeDefinition = choice
[ T.TypedefType <$> typedef
, T.EnumType <$> enum
, T.SenumType <$> senum
, T.StructType <$> struct
, T.UnionType <$> union
, T.ExceptionType <$> exception
]
typedef :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Typedef n)
typedef = reserved "typedef" >>
docstring (T.Typedef <$> typeReference <*> identifier <*> typeAnnotations)
enum :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Enum n)
enum = reserved "enum" >>
docstring (T.Enum
<$> identifier
<*> braces (many enumDef)
<*> typeAnnotations)
struct :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Struct n)
struct = reserved "struct" >>
docstring (T.Struct
<$> identifier
<*> braces (many field)
<*> typeAnnotations)
union :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Union n)
union = reserved "union" >>
docstring (T.Union
<$> identifier
<*> braces (many field)
<*> typeAnnotations)
exception :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Exception n)
exception = reserved "exception" >>
docstring (T.Exception
<$> identifier
<*> braces (many field)
<*> typeAnnotations)
fieldRequiredness
:: (TokenParsing p, MonadPlus p) => ThriftParser p n T.FieldRequiredness
fieldRequiredness = choice [
reserved "required" *> pure T.Required
, reserved "optional" *> pure T.Optional
]
field :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Field n)
field = docstring $
T.Field
<$> optional (integer <* symbolic ':')
<*> optional fieldRequiredness
<*> typeReference
<*> identifier
<*> optional (equals *> constantValue)
<*> typeAnnotations
<* optionalSep
enumDef :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.EnumDef n)
enumDef = docstring $
T.EnumDef
<$> identifier
<*> optional (equals *> integer)
<*> typeAnnotations
<* optionalSep
senum :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Senum n)
senum = reserved "senum" >> docstring
(T.Senum
<$> identifier
<*> braces (many (literal <* optionalSep))
<*> typeAnnotations)
constant :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Const n)
constant = do
reserved "const"
docstring $
T.Const
<$> typeReference
<*> (identifier <* equals)
<*> constantValue
<* optionalSep
constantValue
:: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.ConstValue n)
constantValue = choice [
either T.ConstInt T.ConstFloat <$> integerOrDouble
, T.ConstLiteral <$> literal
, withSrcAnnot (T.ConstIdentifier <$> identifier)
, T.ConstList <$> constList
, T.ConstMap <$> constMap
]
constList
:: (TokenParsing p, MonadPlus p) => ThriftParser p n [T.ConstValue n]
constList = symbolic '[' *> loop []
where
loop xs = choice [
symbolic ']' *> return (reverse xs)
, (:) <$> (constantValue <* optionalSep)
<*> pure xs
>>= loop
]
constMap
:: (TokenParsing p, MonadPlus p)
=> ThriftParser p n [(T.ConstValue n, T.ConstValue n)]
constMap = symbolic '{' *> loop []
where
loop xs = choice [
symbolic '}' *> return (reverse xs)
, (:) <$> (constantValuePair <* optionalSep)
<*> pure xs
>>= loop
]
constantValuePair
:: (TokenParsing p, MonadPlus p)
=> ThriftParser p n (T.ConstValue n, T.ConstValue n)
constantValuePair =
(,) <$> (constantValue <* colon)
<*> (constantValue <* optionalSep)
typeReference
:: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.TypeReference n)
typeReference = choice [
baseType
, containerType
, withSrcAnnot (T.DefinedType <$> identifier)
]
baseType
:: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.TypeReference n)
baseType =
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
:: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.TypeReference n)
containerType =
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)
service :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Service n)
service = do
reserved "service"
docstring $
T.Service
<$> identifier
<*> optional (reserved "extends" *> identifier)
<*> braces (many function)
<*> typeAnnotations
function :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Function n)
function = docstring $
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
typeAnnotations
:: (TokenParsing p, MonadPlus p)
=> ThriftParser p n [T.TypeAnnotation]
typeAnnotations = parens (many typeAnnotation) <|> pure []
typeAnnotation
:: (TokenParsing p, MonadPlus p)
=> ThriftParser p n T.TypeAnnotation
typeAnnotation =
T.TypeAnnotation
<$> identifier
<*> (optional (equals *> literal) <* optionalSep)
optionalSep :: (TokenParsing p, MonadPlus p) => ThriftParser p n ()
optionalSep = void $ optional (comma <|> semi)
equals :: (TokenParsing p, MonadPlus p) => ThriftParser p n ()
equals = void $ symbolic '='