hiccup-0.40: ExprParse.hs
module ExprParse (exprParseTests, riExpr, exprCompile) where
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Language
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Expr
import qualified TclLib.MathProcs as Math
import Test.HUnit
import qualified TclObj as T
import qualified Data.Map as M
import Util
lexer :: P.TokenParser ()
lexer = P.makeTokenParser emptyDef
intOrFloat = P.naturalOrFloat lexer
symbol = P.symbol lexer
schar c = char c >> P.whiteSpace lexer
identifier = P.identifier lexer
stringLit = P.stringLiteral lexer
data Op = OpDiv | OpPlus | OpMinus | OpTimes | OpEql | OpNeql |
OpLt | OpGt | OpLte | OpGte | OpStrNe | OpStrEq | OpAnd |
OpOr
deriving (Show,Eq)
data TExp = TOp !Op TExp TExp | TNot TExp | TVar String | TFun String [TExp] | TVal T.TclObj deriving (Show,Eq)
exprCompile :: (Monad m) => String -> m (Callback m -> m T.TclObj)
exprCompile s = do v <- expr s
return $ runExpr v
expr s = case parse pexpr "" s of
Left err -> fail $ "Bad parse: (" ++ s ++ "): " ++ show err
Right res -> return res
instance Num TExp where
a + b = TOp OpPlus a b
(-) = TOp OpMinus
(*) = TOp OpTimes
abs = undefined
signum = undefined
negate = undefined
fromInteger i = TVal (T.mkTclInt (fromIntegral i))
(.&&) = TOp OpAnd
(.||) = TOp OpOr
(.<) = TOp OpLt
(.<=) = TOp OpLte
(.>) = TOp OpGt
(.>=) = TOp OpGte
(.==) = TOp OpEql
eq = TOp OpStrEq
ne = TOp OpStrNe
objapply :: (Monad m) => Callback m -> (T.TclObj -> T.TclObj -> m T.TclObj) -> TExp -> TExp -> m T.TclObj
objapply lu f x y = do
i1 <- runExpr x lu
i2 <- runExpr y lu
f i1 i2
{-# INLINE objapply #-}
funapply lu fn al = do
args <- mapM (\v -> runExpr v lu) al
lu (mkCmd fn args)
type CBData = Either BString (BString, [T.TclObj])
type Callback m = (CBData -> m T.TclObj)
mkCmd a b = Right (pack a,b)
runExpr :: (Monad m) => TExp -> Callback m -> m T.TclObj
runExpr exp lu =
case exp of
(TOp OpPlus a b) -> objap Math.plus a b
(TOp OpTimes a b) -> objap Math.times a b
(TOp OpMinus a b) -> objap Math.minus a b
(TOp OpDiv a b) -> objap Math.divide a b
(TOp OpEql a b) -> objap (up Math.equals) a b
(TOp OpLt a b) -> objap (up Math.lessThan) a b
(TOp OpNeql a b) -> objap (up Math.notEquals) a b
(TOp OpGt a b) -> objap (up Math.greaterThan) a b
(TOp OpLte a b) -> objap (up Math.lessThanEq) a b
(TOp OpGte a b) -> objap (up Math.greaterThanEq) a b
(TOp OpStrEq a b) -> objap (sup T.strEq) a b
(TOp OpStrNe a b) -> objap (sup T.strNe) a b
(TOp OpAnd a b) -> objap (procBool (&&)) a b
(TOp OpOr a b) -> objap (procBool (||)) a b
(TNot v) -> runExpr v lu >>= return . T.fromBool . not . T.asBool
(TVal v) -> return $! v
(TVar n) -> lu (Left (pack n))
(TFun fn al) -> funapply lu fn al
where objap = objapply lu
up f a b = return (f a b)
sup f a b = return (T.fromBool (f a b))
procBool f a b = do
let ab = T.asBool a
let bb = T.asBool b
return $! T.fromBool (ab `f` bb)
pexpr :: Parser TExp
pexpr = do
many space
res <- myexpr
many space
eof
return res
myexpr = buildExpressionParser table factor
table = [[op1 '*' (OpTimes) AssocLeft, op1 '/' (OpDiv) AssocLeft]
,[op1 '+' (OpPlus) AssocLeft, op1 '-' (OpMinus) AssocLeft]
,[op "==" (OpEql) AssocLeft, op "!=" (OpNeql) AssocLeft]
,[op "eq" OpStrEq AssocLeft, op "ne" OpStrNe AssocLeft]
,[tryop "<=" (OpLte) AssocLeft, tryop ">=" (OpGte) AssocLeft]
,[op1 '<' OpLt AssocLeft, op1 '>' OpGt AssocLeft]
,[op "&&" OpAnd AssocLeft, op "||" OpOr AssocLeft]
,[prefix '!' TNot]
]
where
op s f assoc = Infix (do{ symbol s; return (TOp f)}) assoc
op1 s f assoc = Infix (do{ schar s; return (TOp f)}) assoc
tryop s f assoc = Infix (do{ try(symbol s); return (TOp f)}) assoc
prefix c f = Prefix (do { schar c; return f})
factor = nested <|> numval
<|> boolval <|> mystr <|> myvar <|> myfun <?> "term"
where nested = do
schar '('
x <- myexpr
schar ')'
return x
neg = (char '-' >> return True)
<|> (char '+' >> return False)
<|> return False
numval = do n <- neg
let adj v = if n then negate v else v
iorf <- intOrFloat
return $ case iorf of
Left i -> tInt (adj (fromIntegral i))
Right f -> tFloat (adj f)
mystr = do s <- stringLit
return $ tStr s
<?> "string"
boolval = do
b <- ((s "true" <|> try (s "on")) >> return True)
<|> ((s "false" <|> s "off") >> return False)
return . TVal $ T.fromBool b
where s str = symbol str
myvar = do char '$'
s <- identifier
return $ TVar s
<?> "variable"
myfun = do s <- identifier
schar '('
inner <- myexpr `sepBy` (char ',')
schar ')'
return $ TFun s inner
--- Unit Testing ---
ptest a (p,s) = a ~=? (tparse p s)
where tparse p s = case parse p "" s of
Left _ -> Nothing
Right res -> Just res
a ?=? x = ptest (Just a) x
isBad x = ptest Nothing x
aNumberTests = TestList
["ANumber1" ~: (tInt 3) ?=? (numval, "3"),
"double" ~: (tFloat 1.25) ?=? (numval, "1.25"),
"ANumber2" ~: (tInt (-1)) ?=? (numval, "-1"),
"ANumber3" ~: isBad (numval, "Button")]
stringTests = TestList [
"string1" ~: (tStr "boo") ?=? (mystr, "\"boo\"")
,"string2" ~: (tStr "") ?=? (mystr, "\"\"")
,"string3" ~: (tStr "44") ?=? (mystr, "\"44\"")
]
varTests = TestList [
"var1" ~: (TVar "boo") ??= "$boo"
,"var2" ~: (TVar "keebler") ??= "$keebler"
,"var3" ~: bad "$"
]
where bad v = ptest Nothing (myvar,v)
a ??= v = ptest (Just a) (myvar,v)
tInt i = TVal (T.mkTclInt i)
tStr s = TVal (T.mkTclStr s)
tFloat f = TVal (T.mkTclDouble f)
exprTests = TestList
[ "expr1" ~: (tInt 3) ?=? (pexpr, "3")
,"expr2" ~: ((tInt 3) + (tInt 1)) ?=? (pexpr, "3+1")
,"var+var" ~: ((TVar "a") + (TVar "b")) ?=? (pexpr, "$a+$b")
,"expr2 in paren" ~: ((tInt 3) + (tInt 1)) ?=? (pexpr, "(3+1)")
,"expr2 in paren 2" ~: ((tInt 3) + (tInt 1)) ?=? (pexpr, "((3)+1)")
,"expr3" ~: ((tInt 2) + (tInt 5) * (tInt 5)) ?=? (pexpr, "2+5*5")
,"lt" ~: ((tInt 2) .< (tInt 5)) ?=? (pexpr, "2 < 5")
,"lte" ~: ((tInt 2) .<= (tInt 5)) ?=? (pexpr, "2 <= 5")
,"gt" ~: ((tInt 5) .> (tInt 5)) ?=? (pexpr, "5 > 5")
,"gte" ~: ((tInt 6) .>= (tInt 5)) ?=? (pexpr, "6 >= 5")
,"string eq" ~: ((tStr "X") `eq` (tStr "Y")) ?=? (pexpr, "\"X\" eq \"Y\"")
,"string eq var" ~: ((TVar "X") `eq` (tStr "Y")) ?=? (pexpr, "$X eq \"Y\"")
,"string ne" ~: ((tStr "X") `ne` (tStr "Y")) ?=? (pexpr, " \"X\" ne \"Y\"")
,"varstorm1" ~: (((TVar "me") + (TVar "hey")) .< (TVar "something")) ?=? (pexpr, "($me + $hey) < $something")
,"varstorm2" ~: (((TVar "me") + (TVar "hey")) .< (TVar "something")) ?=? (pexpr, "($me + $hey)< $something")
,"varstorm3" ~: (((TVar "me") + (TVar "hey")) .< (TVar "st")) ?=? (pexpr, " ( $me+$hey ) <$st ")
,"varstorm4" ~: (((TVar "me") * (TVar "hey")) .== (TVar "st")) ?=? (pexpr, " $me * $hey == $st ")
,"fun1" ~: (TFun "sin" [tInt 44]) ?=? (pexpr, "sin(44)")
,"fun2" ~: ((tInt 11) + (TFun "sin" [tInt 44])) ?=? (pexpr, "11 + sin(44)")
,"fun3" ~: (TFun "rand" []) ?=? (pexpr, "rand()")
,"and expr" ~: ((tInt 1) .&& (tInt 2)) ?=? (pexpr, "1 && 2")
,"or expr" ~: (((tInt 1) + (tInt 1)) .|| (tInt 2)) ?=? (pexpr, "(1+1) || 2")
,"sin +" ~: ((TFun "sin" [tInt 0]) + (tInt 10)) ?=? (pexpr, "sin(0) + 10")
]
mint v = T.mkTclInt v
evalTests = TestList
[
(tInt 3) `eql` (mint 3),
((tInt 5) + (tInt 5)) `eql` (mint 10),
(((tInt 8) - (tInt 5)) + (tInt 5)) `eql` (mint 8),
(((tInt 8) - (tInt 5)) .> (tInt 5)) `eql` T.tclFalse,
"5 >= 5 -> true" ~: ((tInt 5) .>= (tInt 5)) `eql` (T.tclTrue),
"5 <= 5 -> true" ~: ((tInt 5) .<= (tInt 5)) `eql` (T.tclTrue),
((tInt 6) .<= (tInt 5)) `eql` (T.tclFalse),
"8 - 5 < 5 -> true" ~: (((tInt 8) - (tInt 5)) .< (tInt 5)) `eql` T.tclTrue
]
where eql a b = (runExpr a (return . make)) ~=? Just b
make (Left a) = T.mkTclBStr a
make (Right _) = T.mkTclStr "PROC"
varEvalTests = TestList
[
"$num -> 4" ~: (TVar "num") `eql` (mint 4),
((TVar "num") + (tInt 3)) `eql` (mint 7),
((tInt 4) + ((TVar "num") - (tInt 1))) `eql` (mint 7),
"$boo == \"bean\" -> true" ~: ((TVar "boo") `eq` (tStr "bean")) `eql` T.tclTrue
]
where eql a b = (runExpr a lu) ~=? Just b
table = M.fromList . mapFst pack $ [("boo", T.mkTclStr "bean"), ("num", T.mkTclInt 4)]
lu :: (Monad m) => Callback m
lu (Left v) = M.lookup v table
lu (Right _) = return $ T.mkTclStr "PROC"
riExpr s f = expr s >>= \e -> runExpr e f
exprParseTests = TestList [ aNumberTests, stringTests, varTests, exprTests, evalTests, varEvalTests ]
-- howbout s = parse pexpr "" s