module ProtoParser
( protoParser
, protoObjParser
, enumFieldParser
, messageFieldParser
, fieldQualifierParser
) where
import Tree( Tree(..) )
import Proto
import Prelude hiding (maybe, Enum)
import Control.Monad
import Data.Char (digitToInt)
import Data.List (foldl')
import Data.Text (Text, pack, unpack)
import Data.Maybe (catMaybes)
import Data.Either (lefts, rights)
import Text.Parsec hiding (token)
import Text.Parsec.Char
import Text.Parsec.Text (Parser)
protoParser :: Parser Proto
protoParser = parseNWithFallback protoObjParser line
protoObjParser :: Parser ProtoObj
protoObjParser = do
dataType <- token
case dataType of
"message" -> (uncurry Internal) <$> messageParser
"enum" -> Leaf <$> enumParser
_ -> fail "Failed to parse message fields"
messageParser :: Parser ([ProtoObj], Message)
messageParser = do
name <- token
elems <- brackets (parseNWithFallback messageFieldParser comment)
let nonRecFields = rights elems
let recFields = lefts elems
return $ (recFields, Message name nonRecFields)
enumParser :: Parser Enum
enumParser
= Enum
<$> token
<*> brackets (parseNWithFallback enumFieldParser comment)
enumFieldParser :: Parser EnumField
enumFieldParser = do
maybe deprecated
fieldName <- token
char '='
whitespace
value <- positiveNatural
line
return $ EnumField fieldName value
messageFieldParser :: Parser (Either ProtoObj MessageField)
messageFieldParser = do
maybe deprecated
fieldQualifierOrProtoObjDecl <- token
case fieldQualifierOrProtoObjDecl of
"message" -> (Left . uncurry Internal) <$> messageParser
"enum" -> (Left . Leaf) <$> enumParser
fieldQualifier -> Right <$> (nonRecMessageFieldParser' $ textToFieldQualifier fieldQualifier)
where
nonRecMessageFieldParser' :: FieldQualifier -> Parser MessageField
nonRecMessageFieldParser' fieldQualifier = do
fieldType <- token
fieldName <- token
char '='
whitespace
value <- positiveNatural
line
return $ MessageField fieldQualifier fieldType fieldName value
fieldQualifierParser :: Parser FieldQualifier
fieldQualifierParser = textToFieldQualifier <$> token
textToFieldQualifier :: Text -> FieldQualifier
textToFieldQualifier "optional" = Optional
textToFieldQualifier "required" = Required
textToFieldQualifier "repeated" = Repeated
textToFieldQualifier text = error $ "Parsing FieldQualifier failed: " ++ unpack text
deprecated :: Parser ()
deprecated
= void . maybe
$ ( string "//"
>> maybe space
>> string "DEPRECATED"
>> maybe (choice [char '.', char ':'])
>> char ' ' )
brackets :: Parser a -> Parser a
brackets = between (string "{" >> endl) (char '}')
positiveNatural :: Parser Integer
positiveNatural = fromIntegral . digitsToInt <$> many1 digit
where
digitsToInt :: [Char] -> Int
digitsToInt = foldl' (\acc ch -> acc * 10 + digitToInt ch) 0
comment :: Parser Text
comment = pack <$> (whitespace >> char '/' >> char '/' >> many1 (noneOf "\n"))
line :: Parser Text
line = pack <$> many1 (noneOf "\n")
maybe :: Parser a -> Parser (Maybe a)
maybe = try . optionMaybe
token :: Parser Text
token = pack <$> (many1 char' <* whitespace)
where
char' :: Parser Char
char' = choice [letter, char '_', char '.', digit]
whitespace :: Parser ()
whitespace = skipMany $ char ' '
endl :: Parser [()]
endl = many1 $ newline >> whitespace
parseNWithFallback :: forall a b. Parser a -> Parser b -> Parser [a]
parseNWithFallback posParser negParser = catMaybes <$> sepEndBy maybeParser (many1 endl)
where
maybeParser :: Parser (Maybe a)
maybeParser = (try $ Just <$> posParser) <|> (const Nothing <$> negParser)