3a_asm: expr eval init

found on teh intern3tz

diff --git a/3a_asm/Expr_eval.hs b/3a_asm/Expr_eval.hs
new file mode 100644 (file)
index 0000000..9919b54
--- /dev/null
+++ b/3a_asm/Expr_eval.hs
@@ -0,0 +1,59 @@
+
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Expr
+import qualified Text.ParserCombinators.Parsec.Token as P
+import Text.ParserCombinators.Parsec.Language
+import System.IO
+
+lexer :: P.TokenParser ()
+lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","**"] })
+
+naturalOrFloat = P.naturalOrFloat lexer
+parens         = P.parens lexer
+reservedOp     = P.reservedOp lexer
+
+expr :: Parser Double
+expr = buildExpressionParser table factor <?> "expression"
+   where
+       table = [
+           [unary "-" negate, unary "+" id],
+           [op "**" (**) AssocRight],
+           [op "*" (*) AssocLeft, op "/" (/) AssocLeft],
+           [op "+" (+) AssocLeft, op "-" (-) AssocLeft]
+           ]
+       op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
+       unary s f = Prefix (do{ reservedOp s; return f })
+
+factor :: Parser Double
+factor =
+   do {
+       parens expr;
+   } <|> do {
+       norf <- naturalOrFloat;
+       case norf of
+           Left i    -> return $ fromInteger i
+           Right f    -> return $ f
+   } <?>
+       "factor"
+
+repl :: String -> (String -> Bool) -> (String -> String) -> IO ()
+repl prompt bQuit eval = loop
+   where
+       loop = do
+           putStr prompt
+           s <- getLine
+           if bQuit s
+               then return ()
+               else putStrLn (eval s) >> loop
+
+calc :: IO ()
+calc = repl "> " (== ":q") (tostring . parse stmt "")
+   where
+       tostring (Right v)    = show v
+       tostring (Left err)    = show err
+       stmt = do
+           e <- expr
+           eof
+           return e
+
+main = hSetBuffering stdout NoBuffering >> putStrLn "type ':q' to quit." >> calc >> putStrLn "Bye"