module Burrito.Parse
( parse
)
where
import qualified Burrito.Type.Expression as Expression
import qualified Burrito.Type.LitChar as LitChar
import qualified Burrito.Type.Literal as Literal
import qualified Burrito.Type.Modifier as Modifier
import qualified Burrito.Type.Name as Name
import qualified Burrito.Type.NonEmpty as NonEmpty
import qualified Burrito.Type.Operator as Operator
import qualified Burrito.Type.Template as Template
import qualified Burrito.Type.Token as Token
import qualified Burrito.Type.VarChar as VarChar
import qualified Burrito.Type.Variable as Variable
import qualified Control.Applicative as Applicative
import qualified Control.Monad as Monad
import qualified Data.Char as Char
import qualified Data.Maybe as Maybe
import qualified Data.Word as Word
parse :: String -> Maybe Template.Template
parse string = case runParser parseTemplate string of
Just (template, "") -> Just template
_ -> Nothing
intToWord8 :: Int -> Word.Word8
intToWord8 x =
let
lo = word8ToInt (minBound :: Word.Word8)
hi = word8ToInt (maxBound :: Word.Word8)
in if x < lo
then error $ "intToWord8: " <> show x <> " < " <> show lo
else if x > hi
then error $ "intToWord8: " <> show x <> " > " <> show hi
else fromIntegral x
word8ToInt :: Word.Word8 -> Int
word8ToInt = fromIntegral
newtype Parser a = Parser
{ runParser :: String -> Maybe (a, String)
}
instance Functor Parser where
fmap f p = Parser $ \s -> case runParser p s of
Nothing -> Nothing
Just (x, t) -> Just (f x, t)
instance Applicative Parser where
pure x = Parser $ \s -> Just (x, s)
p <*> q = Parser $ \s -> case runParser p s of
Nothing -> Nothing
Just (f, t) -> case runParser q t of
Nothing -> Nothing
Just (x, u) -> Just (f x, u)
instance Monad Parser where
p >>= f = Parser $ \s -> case runParser p s of
Nothing -> Nothing
Just (x, t) -> runParser (f x) t
instance Applicative.Alternative Parser where
empty = Parser $ const Nothing
p <|> q = Parser $ \s -> case runParser p s of
Nothing -> runParser q s
Just (x, t) -> Just (x, t)
parseAny :: Parser Char
parseAny = Parser $ \string -> case string of
"" -> Nothing
first : rest -> Just (first, rest)
parseBetween :: Parser before -> Parser after -> Parser a -> Parser a
parseBetween before after parser = before *> parser <* after
parseChar :: Char -> Parser Char
parseChar = parseIf . (==)
parseChar_ :: Char -> Parser ()
parseChar_ = Monad.void . parseChar
parseEither :: Parser a -> Parser a -> Parser a
parseEither = (Applicative.<|>)
parseIf :: (Char -> Bool) -> Parser Char
parseIf predicate = do
char <- parseAny
if predicate char then pure char else Applicative.empty
parseNonEmpty :: Parser a -> Parser (NonEmpty.NonEmpty a)
parseNonEmpty parser = nonEmpty <$> parser <*> Applicative.many parser
parseSepBy1 :: Parser separator -> Parser a -> Parser (NonEmpty.NonEmpty a)
parseSepBy1 separator parser =
nonEmpty <$> parser <*> Applicative.many (separator *> parser)
parseTemplate :: Parser Template.Template
parseTemplate = Template.Template <$> Applicative.many parseToken
parseToken :: Parser Token.Token
parseToken = parseEither
(Token.Literal <$> parseLiteral)
(Token.Expression <$> parseExpression)
parseLiteral :: Parser Literal.Literal
parseLiteral = Literal.Literal <$> parseNonEmpty parseCharacter
parseCharacter :: Parser LitChar.LitChar
parseCharacter = parseEither parseCharacterUnencoded parseCharacterEncoded
parseCharacterUnencoded :: Parser LitChar.LitChar
parseCharacterUnencoded = do
char <- parseIf LitChar.isLiteral
maybe Applicative.empty pure $ LitChar.makeUnencoded char
parseCharacterEncoded :: Parser LitChar.LitChar
parseCharacterEncoded = do
(hi, lo) <- parsePercentEncoded
pure . LitChar.Encoded $ intToWord8
(Char.digitToInt hi * 16 + Char.digitToInt lo)
parseExpression :: Parser Expression.Expression
parseExpression =
parseBetween (parseChar_ '{') (parseChar_ '}')
$ Expression.Expression
<$> parseOperator
<*> parseVariableList
parseVariableList :: Parser (NonEmpty.NonEmpty Variable.Variable)
parseVariableList = parseSepBy1 (parseChar_ ',') parseVarspec
parseVarspec :: Parser Variable.Variable
parseVarspec = do
name <- parseVarname
modifier <- parseModifier
pure $ Variable.Variable
{ Variable.name = name
, Variable.modifier = modifier
}
parseVarname :: Parser Name.Name
parseVarname = do
first <- parseVarcharFirst
rest <- Applicative.many parseVarcharRest
pure Name.Name { Name.first = first, Name.rest = rest }
parseVarcharFirst :: Parser VarChar.VarChar
parseVarcharFirst = parseEither parseVarcharUnencoded parseVarcharEncoded
parseVarcharUnencoded :: Parser VarChar.VarChar
parseVarcharUnencoded = do
char <- parseIf VarChar.isVarchar
maybe Applicative.empty pure $ VarChar.makeUnencoded char
parseVarcharEncoded :: Parser VarChar.VarChar
parseVarcharEncoded = do
(hi, lo) <- parsePercentEncoded
maybe Applicative.empty pure $ VarChar.makeEncoded hi lo
parseVarcharRest :: Parser (Bool, VarChar.VarChar)
parseVarcharRest =
(,)
<$> parseEither (True <$ parseChar_ '.') (pure False)
<*> parseVarcharFirst
nonEmpty :: a -> [a] -> NonEmpty.NonEmpty a
nonEmpty = NonEmpty.NonEmpty
parsePercentEncoded :: Parser (Char, Char)
parsePercentEncoded = do
parseChar_ '%'
(,) <$> parseIf Char.isHexDigit <*> parseIf Char.isHexDigit
parseOperator :: Parser Operator.Operator
parseOperator =
Maybe.fromMaybe Operator.None <$> Applicative.optional parseRequiredOperator
parseRequiredOperator :: Parser Operator.Operator
parseRequiredOperator = do
operator <- parseIf isOperator
maybe Applicative.empty pure $ toOperator operator
toOperator :: Char -> Maybe Operator.Operator
toOperator x = case x of
'+' -> Just Operator.PlusSign
'#' -> Just Operator.NumberSign
'.' -> Just Operator.FullStop
'/' -> Just Operator.Solidus
';' -> Just Operator.Semicolon
'?' -> Just Operator.QuestionMark
'&' -> Just Operator.Ampersand
_ -> Nothing
isOperator :: Char -> Bool
isOperator x = isOpLevel2 x || isOpLevel3 x || isOpReserve x
isOpLevel2 :: Char -> Bool
isOpLevel2 x = case x of
'+' -> True
'#' -> True
_ -> False
isOpLevel3 :: Char -> Bool
isOpLevel3 x = case x of
'.' -> True
'/' -> True
';' -> True
'?' -> True
'&' -> True
_ -> False
isOpReserve :: Char -> Bool
isOpReserve x = case x of
'=' -> True
',' -> True
'!' -> True
'@' -> True
'|' -> True
_ -> False
parseModifier :: Parser Modifier.Modifier
parseModifier =
fmap (Maybe.fromMaybe Modifier.None) . Applicative.optional $ parseEither
parsePrefixModifier
parseExplodeModifier
parsePrefixModifier :: Parser Modifier.Modifier
parsePrefixModifier = do
parseChar_ ':'
maxLength <- parseMaxLength
maybe Applicative.empty pure $ Modifier.makeColon maxLength
parseMaxLength :: Parser Int
parseMaxLength = do
first <- parseNonZeroDigit
rest <- parseUpTo 3 parseDigit
pure . fromDigits $ rest <> [first]
fromDigits :: [Int] -> Int
fromDigits = foldr (\digit -> (+ digit) . (* 10)) 0
parseUpTo :: Int -> Parser a -> Parser [a]
parseUpTo = parseUpToWith []
parseUpToWith :: [a] -> Int -> Parser a -> Parser [a]
parseUpToWith accumulator remaining parser = if remaining < 1
then pure accumulator
else do
result <- Applicative.optional parser
case result of
Nothing -> pure accumulator
Just value -> parseUpToWith (value : accumulator) (remaining - 1) parser
parseNonZeroDigit :: Parser Int
parseNonZeroDigit = Char.digitToInt <$> parseIf isNonZeroDigit
isNonZeroDigit :: Char -> Bool
isNonZeroDigit x = case x of
'0' -> False
_ -> Char.isDigit x
parseDigit :: Parser Int
parseDigit = Char.digitToInt <$> parseIf Char.isDigit
parseExplodeModifier :: Parser Modifier.Modifier
parseExplodeModifier = Modifier.Asterisk <$ parseChar_ '*'