module Data.Binding.Hobbits.PatternParser (parsePattern, parseVar) where
import Text.ParserCombinators.Parsec
import Language.Haskell.TH
import Data.Char
varStartChars = ['a'..'z']
ctorStartChars = ['A'..'Z']
identChars = varStartChars ++ ctorStartChars ++ ['0'..'9'] ++ "'_"
infixChars = "!#$%&*+./<=>?@"
varParser :: GenParser Char st String
varParser =
do char1 <- oneOf varStartChars
char_rest <- many (oneOf identChars)
return (char1 : char_rest)
ctorParser :: GenParser Char st String
ctorParser =
do char1 <- oneOf ctorStartChars
char_rest <- many (oneOf identChars)
return (char1 : char_rest)
infixParser :: GenParser Char st String
infixParser =
do char1 <- char ':'
char_rest <- many (oneOf infixChars)
return (char1 : char_rest)
stringParser :: GenParser Char st String
stringParser =
do char '"'
res <- stringContentsParser
return res
stringContentsParser =
many (noneOf "\\\"") >>= \prefix ->
(char '"' >> return prefix)
<|>
(char '\\' >> do c <- anyChar
rest <- stringContentsParser
return $ prefix ++ [c] ++ rest)
charParser :: GenParser Char st Char
charParser =
do char '\''
c <- ((char '\\' >> anyChar) <|> anyChar)
char '\''
return c
digitsToInt digits = helper digits 0
where helper [] accum = accum
helper (digit:digits) accum =
helper digits (accum * 10 + (digitToInt digit))
intToRational :: Int -> Rational
intToRational = fromIntegral
digitsToFrac digits = helper digits
where helper [] = 0.0
helper (digit:digits) = ((helper digits) + (intToRational $ digitToInt digit)) / 10
numParser :: GenParser Char st Lit
numParser =
do base_digits <- many1 (oneOf ['0'..'9'])
((do char '.'
frac_digits <- many1 (oneOf ['0'..'9'])
return (RationalL $ (intToRational $ digitsToInt base_digits) + digitsToFrac frac_digits))
<|> return (IntegerL $ fromIntegral $ digitsToInt base_digits))
litParser :: GenParser Char st Lit
litParser = (charParser >>= return . CharL) <|>
(stringParser >>= return . StringL) <|>
numParser
commaSepParser :: GenParser Char st [Pat]
commaSepParser =
(do first <- pattParser 0
rest <- (char ',' >> commaSepParser) <|> (return [])
return (first:rest)) <|> (return [])
tokenParser :: Int -> GenParser Char st Pat
tokenParser i =
(litParser >>= return . LitP) <|>
(char '_' >> return WildP) <|>
(do char '!'
patt <- pattParser i
return $ BangP patt) <|>
(do char '~'
patt <- pattParser i
return $ TildeP patt) <|>
(try (do var <- varParser
wsParser
char '@'
patt <- pattParser i
return $ AsP (mkName var) patt)) <|>
(varParser >>= return . VarP . mkName) <|>
(do char '('
tup <- commaSepParser
char ')'
return (case tup of
[] -> ConP '() []
[patt] -> patt
_ -> TupP tup)) <|>
(do ctor <- ctorParser
args <- if i < 2 then many (try $ pattParser 2) else return []
return $ ConP (mkName ctor) args) <|>
(do char '['
elems <- commaSepParser
char ']'
return $ ListP elems)
wsParser :: GenParser Char st ()
wsParser = many (oneOf " \t\n\r") >> return ()
pattParser :: Int -> GenParser Char st Pat
pattParser i =
do wsParser
res <- if i == 0 then
try (do lhs <- pattParser 1
op <- infixParser
rhs <- pattParser 0
return $ ConP (mkName op) [lhs, rhs]) <|>
tokenParser i
else
tokenParser i
wsParser
return res
varOnlyParser :: GenParser Char st String
varOnlyParser = do wsParser
res <- varParser
wsParser
eof
return res
parsePattern str = case parse (pattParser 0) "" str of
Left err -> error $ show err
Right patt -> patt
parseVar str = case parse varOnlyParser "" str of
Left err -> error $ show err
Right str -> str