module Sifflet.Language.Parser
(parseExpr, parseInput
, parseTest
, parseSuccFail, nothingBut
, expr, list, literal
, value, typedValue
, bool, qchar, qstring, integer, double
, number
)
where
import Text.ParserCombinators.Parsec
import Sifflet.Language.Expr
import Sifflet.Util
parseExpr :: String -> SuccFail Expr
parseExpr = parseSuccFail expr
parseInput :: String -> SuccFail Expr
parseInput = parseSuccFail input
parseSuccFail :: Parser a -> String -> SuccFail a
parseSuccFail p s =
case parse p "user input" s of
Left perr -> Fail (show perr)
Right v -> Succ v
input :: Parser Expr
input = nothingBut expr
nothingBut :: Parser a -> Parser a
nothingBut p = (many space >> p) `prog1` (many space >> eof)
prog1 :: (Monad m) => m a -> m b -> m a
prog1 m1 m2 = m1 >>= (\ r -> m2 >> return r)
expr :: Parser Expr
expr =
literal
list :: Parser a -> Parser [a]
list element =
let sep = try (skipMany space >> char ',' >> skipMany space)
in (char '[' >> many space >> sepBy element sep)
`prog1`
(many space >> char ']')
<?> "list"
literal :: Parser Expr
literal = value >>= return . ELit
value :: Parser Value
value = (bool >>= return . VBool) <|>
(qchar >>= return .VChar) <|>
(qstring >>= return . VStr) <|>
try (double >>= return . VFloat) <|>
(integer >>= return . VInt) <|>
(list value >>= return . VList)
typedValue :: VpType -> Parser Value
typedValue t =
(case t of
VpTypeBool -> bool >>= return . VBool
VpTypeChar -> qchar >>= return . VChar
VpTypeString -> qstring >>= return . VStr
VpTypeNum -> do { en <- number;
case en of
Left x -> return (VFloat x)
Right i -> return (VInt i)
}
VpTypeList e -> list (typedValue e) >>= return . VList
VpTypeVar _ -> value
VpTypeFunction _ _ ->
error "typedValue: not implemented for VpTypeFunction"
)
<?> typeName t
typeName :: VpType -> String
typeName t =
case t of
VpTypeBool -> "boolean"
VpTypeChar -> "character"
VpTypeNum -> "number"
VpTypeString -> "string"
VpTypeList e -> "list" ++
case e of
VpTypeVar _ -> ""
_ -> " of " ++ typeName e
VpTypeVar _ -> "anything"
VpTypeFunction _ _ -> "function"
bool :: Parser Bool
bool = (try (string "True" >> return True) <|>
(string "False" >> return False))
<?> typeName VpTypeBool
qchar :: Parser Char
qchar =
let sq = '\''
in (((char sq <?> "opening single quote") >>
(try escapedChar <|> noneOf [sq]))
`prog1`
(char sq <?> "closing single quote")
)
<?> typeName VpTypeChar
qstring :: Parser String
qstring =
let dq = '\"'
in (char dq >>
many (escapedChar <|> noneOf [dq] <?> ""))
`prog1`
(char dq <?> "close of quotation")
<?> typeName VpTypeString
escapedChar :: Parser Char
escapedChar =
let bs = '\\'
in char bs >>
(oneOf "ntr\\" <?> "n, t, r, or \\ to follow \\") >>=
(\ c ->
return (case c of
'n' -> '\n'
't' -> '\t'
'r' -> '\r'
'\\' -> '\\'
_ -> error "escapedChar: c MUST be n, t, r, or \\"
)
)
data Sign = Minus | Plus
integer :: Parser Integer
integer = do { s <- optSign;
u <- unsignedInteger;
return (applySign s u)
}
<?> "integer"
unsignedInteger :: Parser Integer
unsignedInteger = many1 digit >>= return . read
optSign :: Parser Sign
optSign = try ( char '-' >> return Minus ) <|>
try ( char '+' >> return Plus ) <|>
return Plus
applySign :: (Num n) => Sign -> n -> n
applySign s x =
case s of
Minus -> ( x)
Plus -> x
double :: Parser Double
double =
let digits1 = many1 digit
point = char '.'
wpf = do { dd <- digits1;
dd' <- point >> digits1;
return (dd, dd')
}
wp = do { dd <- digits1 `prog1` point;
return (dd, "0")
}
pf = do { dd' <- point >> digits1;
return ("0", dd')
}
scale = do { i <- oneOf "eE" >> integer;
return (10 ** fromIntegral i)
}
<|> return 1
in do { sign <- optSign
; (whole, frac) <- (try wpf <|>
try wp <|>
try pf)
; m <- scale;
; let w = read (whole ++ ".0")
f = read ("0." ++ frac)
; return (m * applySign sign (w + f))
}
<?> "real number"
number :: Parser (Either Double Integer)
number = (try (double >>= return . Left) <|>
(integer >>= return . Right))
<?> typeName VpTypeNum