3a_asm/Expr_eval.hs

   1
   2 import Text.ParserCombinators.Parsec
   3 import Text.ParserCombinators.Parsec.Expr
   4 import qualified Text.ParserCombinators.Parsec.Token as P
   5 import Text.ParserCombinators.Parsec.Language
   6 import System.IO
   7
   8 lexer :: P.TokenParser ()
   9 lexer = P.makeTokenParser (haskellDef { reservedOpNames = ["*","/","+","-","**"] })
  10
  11 naturalOrFloat = P.naturalOrFloat lexer
  12 parens         = P.parens lexer
  13 reservedOp     = P.reservedOp lexer
  14
  15 expr :: Parser Double
  16 expr = buildExpressionParser table factor <?> "expression"
  17    where
  18        table = [
  19            [unary "-" negate, unary "+" id],
  20            [op "**" (**) AssocRight],
  21            [op "*" (*) AssocLeft, op "/" (/) AssocLeft],
  22            [op "+" (+) AssocLeft, op "-" (-) AssocLeft]
  23            ]
  24        op s f assoc = Infix (do{ reservedOp s; return f } <?> "operator") assoc
  25        unary s f = Prefix (do{ reservedOp s; return f })
  26
  27 factor :: Parser Double
  28 factor =
  29    do {
  30        parens expr;
  31    } <|> do {
  32        norf <- naturalOrFloat;
  33        case norf of
  34            Left i    -> return $ fromInteger i
  35            Right f    -> return $ f
  36    } <?>
  37        "factor"
  38
  39 repl :: String -> (String -> Bool) -> (String -> String) -> IO ()
  40 repl prompt bQuit eval = loop
  41    where
  42        loop = do
  43            putStr prompt
  44            s <- getLine
  45            if bQuit s
  46                then return ()
  47                else putStrLn (eval s) >> loop
  48
  49 calc :: IO ()
  50 calc = repl "> " (== ":q") (tostring . parse stmt "")
  51    where
  52        tostring (Right v)    = show v
  53        tostring (Left err)    = show err
  54        stmt = do
  55            e <- expr
  56            eof
  57            return e
  58
  59 main = hSetBuffering stdout NoBuffering >> putStrLn "type ':q' to quit." >> calc >> putStrLn "Bye"