module Language.Thrift.Parser
(
thriftIDL
, ThriftParser
, runThriftParser
, program
, header
, definition
, typeDefinition
, typedef
, enum
, enumDef
, senum
, struct
, union
, exception
, fieldRequiredness
, fieldType
, field
, constant
, constantValue
, service
, function
, typeAnnotations
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Reader (ReaderT)
import Control.Monad.State (StateT)
import Control.Monad.Trans (lift)
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.Reader as Reader
import qualified Control.Monad.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.unlines . 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 <*> many definition
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
header = choice [
reserved "include" >> T.Include <$> literal
, reserved "namespace" >>
T.Namespace <$> (text "*" <|> identifier) <*> identifier
, reserved "cpp_namespace" >> T.Namespace "cpp" <$> identifier
, reserved "php_namespace" >> T.Namespace "php" <$> identifier
, reserved "py_module" >> T.Namespace "py" <$> identifier
, reserved "perl_package" >> T.Namespace "perl" <$> identifier
, reserved "ruby_namespace" >> T.Namespace "rb" <$> identifier
, reserved "java_package" >> T.Namespace "java" <$> identifier
, reserved "cocoa_package" >> T.Namespace "cocoa" <$> identifier
, reserved "csharp_namespace" >> T.Namespace "csharp" <$> identifier
]
docstring :: Monad p => ThriftParser p n (T.Docstring -> n -> a) -> ThriftParser p n a
docstring p = lastDocstring >>= \s -> do
annot <- ThriftParser . lift $ Reader.ask >>= lift
p <*> pure s <*> pure annot
definition :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n)
definition = choice [constant, typeDefinition, service]
typeDefinition :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n)
typeDefinition =
T.TypeDefinition
<$> choice [typedef, enum, senum, struct, union, exception]
<*> typeAnnotations
typedef :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)
typedef = reserved "typedef" >>
docstring (T.Typedef <$> fieldType <*> identifier)
enum :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)
enum = reserved "enum" >>
docstring (T.Enum <$> identifier <*> braces (many enumDef))
struct :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)
struct = reserved "struct" >>
docstring (T.Struct <$> identifier <*> braces (many field))
union :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)
union = reserved "union" >>
docstring (T.Union <$> identifier <*> braces (many field))
exception :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Type n)
exception = reserved "exception" >>
docstring (T.Exception <$> identifier <*> braces (many field))
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
<*> fieldType
<*> 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.Type n)
senum = reserved "senum" >> docstring
(T.Senum <$> identifier <*> braces (many (literal <* optionalSep)))
constant :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n)
constant = do
reserved "const"
docstring $
T.ConstDefinition
<$> fieldType
<*> (identifier <* equals)
<*> constantValue
<* optionalSep
constantValue :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.ConstValue
constantValue = choice [
either T.ConstInt T.ConstFloat <$> integerOrDouble
, T.ConstLiteral <$> literal
, T.ConstIdentifier <$> identifier
, T.ConstList <$> constList
, T.ConstMap <$> constMap
]
constList :: (TokenParsing p, MonadPlus p) => ThriftParser p n [T.ConstValue]
constList = brackets $ commaSep (constantValue <* optionalSep)
constMap
:: (TokenParsing p, MonadPlus p)
=> ThriftParser p n [(T.ConstValue, T.ConstValue)]
constMap = braces $ commaSep constantValuePair
constantValuePair
:: (TokenParsing p, MonadPlus p)
=> ThriftParser p n (T.ConstValue, T.ConstValue)
constantValuePair =
(,) <$> (constantValue <* colon)
<*> (constantValue <* optionalSep)
fieldType :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.FieldType
fieldType = choice [
baseType
, containerType
, T.DefinedType <$> identifier
]
baseType :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.FieldType
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)
, ("i16", T.I16Type)
, ("i32", T.I32Type)
, ("i64", T.I64Type)
, ("double", T.DoubleType)
]
containerType :: (TokenParsing p, MonadPlus p) => ThriftParser p n T.FieldType
containerType =
choice [mapType, setType, listType] <*> typeAnnotations
where
mapType = reserved "map" >>
angles (T.MapType <$> (fieldType <* comma) <*> fieldType)
setType = reserved "set" >> angles (T.SetType <$> fieldType)
listType = reserved "list" >> angles (T.ListType <$> fieldType)
service :: (TokenParsing p, MonadPlus p) => ThriftParser p n (T.Definition n)
service = do
reserved "service"
docstring $
T.ServiceDefinition
<$> 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 <$> fieldType)
<*> 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
<*> (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 '='