calcast.hs

module Main where

import System
import Text.ParserCombinators.Parsec

-- ===========================================================================
--  data structures
-- ===========================================================================

data Expr = BinOp Char Expr Expr
          | Num Float
          | Var String
            deriving (Show, Eq)

binops = [('/',(/)), ('*',(*)), ('+',(+)), ('-',(-))]

default_env = [("x", 42), ("pi", pi)]


-- ===========================================================================
--  parsing
-- ===========================================================================

expr = leftfactor term addop
term = leftfactor factor mulop
factor = parens expr <|> number <|> var
mulop = oneOf "*/"
addop = oneOf "+-"
empty = return id

leftfactor base op = do
  expr <- base
  expr_builder <-  rest base op <|> empty
  return (expr_builder expr)

rest what op = do
  fun <- op
  expr <- what
  exprfun <- rest what op <|> empty
  return (\x -> BinOp fun x (exprfun expr))

parens = between (char '(') (char ')')

number = do chars <- many1 digit
            return (Num (read chars))

var = do varname <- many1 (oneOf "abcdefghijklmnopqrstuvwxyz")
         return (Var varname)


-- ===========================================================================
--  evaluation
-- ===========================================================================

get key map msg = case lookup key map of
  Just value -> value
  Nothing -> error msg

eval :: [(String,Float)] -> Expr -> Float
eval env expr = case expr of
  BinOp op x y -> (get op binops "Unbek. Operator!") (eval env x) (eval env y)
  Num value -> value
  Var varname -> get varname env ("Variable '" ++ varname ++ "' undefiniert!")


parse_expr string = case parse expr "<stdin>" string of
                      Left errmsg -> error (show errmsg)
                      Right expr -> expr


-- ===========================================================================
--  read-eval-print-loop
-- ===========================================================================

main = do
  putStr ">>> "
  line <- getLine
  let ast = parse_expr line
  let value = eval default_env ast
  putStrLn (show value)
  main

Generated by GNU enscript 1.6.4.