either-ex

either-ex.hs

module Evaluator where

import Data.Char
import qualified Data.Map as M

newtype Evaluator a = Ev (Either String a)

instance Functor Evaluator where
  fmap f (Ev a) = Ev $ fmap f a

instance Applicative Evaluator where
  (Ev f) <*> (Ev x) = Ev $ f <*> x
  pure v = Ev $ Right v

instance Monad Evaluator where
  (Ev ev) >>= k =
    case ev of
      Left msg → Ev $ Left msg
      Right v  → k v
  fail msg = Ev $ Left msg

data Operator = Plus | Minus | Times | Div
    deriving (Show, Eq)

data Token = TokOp Operator
           | TokAssign
           | TokLParen
           | TokRParen
           | TokIdent String
           | TokNum Double
           | TokEnd
    deriving (Show, Eq)

operator :: Char -> Operator
operator c | c == '+' = Plus
           | c == '-' = Minus
           | c == '*' = Times
           | c == '/' = Div

tokenize :: String -> [Token]
tokenize [] = []
tokenize (c : cs)
    | elem c "+-*/" = TokOp (operator c) : tokenize cs
    | c == '='  = TokAssign : tokenize cs
    | c == '('  = TokLParen : tokenize cs
    | c == ')'  = TokRParen : tokenize cs
    | isDigit c = number c cs
    | isAlpha c = identifier c cs
    | isSpace c = tokenize cs
    | otherwise = error $ "Cannot tokenize " ++ [c]

identifier :: Char -> String -> [Token]
identifier c cs = let (name, cs') = span isAlphaNum cs in
                  TokIdent (c:name) : tokenize cs'

number :: Char -> String -> [Token]
number c cs =
   let (digs, cs') = span isDigit cs in
   TokNum (read (c : digs)) : tokenize cs'

---- parser ----

data Tree = SumNode Operator Tree Tree
          | ProdNode Operator Tree Tree
          | AssignNode String Tree
          | UnaryNode Operator Tree
          | NumNode Double
          | VarNode String
    deriving Show

lookAhead :: [Token] -> Token
lookAhead [] = TokEnd
lookAhead (t:ts) = t

accept :: [Token] -> [Token]
accept [] = error "Nothing to accept"
accept (t:ts) = ts

expression :: [Token] -> (Tree, [Token])
expression toks =
   let (termTree, toks') = term toks
   in
      case lookAhead toks' of
         (TokOp op) | elem op [Plus, Minus] ->
            let (exTree, toks'') = expression (accept toks')
            in (SumNode op termTree exTree, toks'')
         TokAssign ->
            case termTree of
               VarNode str ->
                  let (exTree, toks'') = expression (accept toks')
                  in (AssignNode str exTree, toks'')
               _ -> error "Only variables can be assigned to"
         _ -> (termTree, toks')

term :: [Token] -> (Tree, [Token])
term toks =
   let (facTree, toks') = factor toks
   in
      case lookAhead toks' of
         (TokOp op) | elem op [Times, Div] ->
            let (termTree, toks'') = term (accept toks')
            in (ProdNode op facTree termTree, toks'')
         _ -> (facTree, toks')

factor :: [Token] -> (Tree, [Token])
factor toks =
   case lookAhead toks of
      (TokNum x)     -> (NumNode x, accept toks)
      (TokIdent str) -> (VarNode str, accept toks)
      (TokOp op) | elem op [Plus, Minus] ->
            let (facTree, toks') = factor (accept toks)
            in (UnaryNode op facTree, toks')
      TokLParen      ->
         let (expTree, toks') = expression (accept toks)
         in
            if lookAhead toks' /= TokRParen
            then error "Missing right parenthesis"
            else (expTree, accept toks')
      _ -> error $ "Parse error on token: " ++ show toks

parse :: [Token] -> Tree
parse toks = let (tree, toks') = expression toks
             in
               if null toks'
               then tree
               else error $ "Leftover tokens: " ++ show toks'

---- evaluator ----
-- show

type SymTab = M.Map String Double

lookUp :: String → SymTab → Either String (Double, SymTab)
lookUp str symTab =
    case M.lookup str symTab of
      Just v  → return (v, symTab)
      Nothing → fail $ "Undefined variable " ++ str

addSymbol :: String → Double → SymTab → Either String ((), SymTab)
addSymbol str val symTab =
    let symTab' = M.insert str val symTab
    in Right ((), symTab')

evaluate ∷ Tree → SymTab → Evaluator (Double, SymTab)

evaluate (SumNode op left right) symTab = do
  (lft, symTab')  ← evaluate left symTab
  (rgt, symTab'') ← evaluate right symTab
  case op of
    Plus  → return (lft + rgt, symTab'')
    Minus → return (lft - rgt, symTab'')

evaluate (ProdNode op left right) symTab = do
  (lft, symTab')  ← evaluate left symTab
  (rgt, symTab'') ← evaluate right symTab
  case op of
    Times → return (lft * rgt, symTab)
    Div   → return (lft / rgt, symTab)

evaluate (UnaryNode op tree) symTab = do
  (x, symTab') ← evaluate tree symTab
  case op of
    Plus  → return ( x, symTab')
    Minus → return (-x, symTab')

evaluate (NumNode x) symTab = return (x, symTab)

evaluate (VarNode str) symTab = Ev $ lookUp str symTab

evaluate (AssignNode str tree) symTab = do
  (v, symTab') ← evaluate tree symTab
  case addSymbol str v symTab' of
    Left msg → fail msg
    Right (_, symTab'') → return (v, symTab'')

-- Either a b → (a → Either a b) → Either a b

bindE' ∷ Either String (Double, SymTab)
       → ((Double, SymTab) → Either String (Double, SymTab))
       → Either String (Double, SymTab)
bindE' ev k =
  case ev of
    Left msg → Left msg
    Right (x, symTab') → k (x, symTab')

bindE ∷ Either String a
      → (a → Either String b)
      → Either String b
bindE ev k =
  case ev of
    Left msg → Left msg
    Right v  → k v

returnE ∷ a → Either String a
returnE x = Right x

failE ∷ String → Either String a
failE msg = Left msg

main = do
   loop (M.fromList [("pi", pi)])

loop symTab = do
   str <- getLine
   if null str
   then
      return ()
   else
      let toks = tokenize str
          tree = parse toks
      in
          case evaluate tree symTab of
          (Ev (Left msg)) -> do
              putStrLn $ "Error: " ++ msg
              loop symTab -- use old symTab
          (Ev (Right (v, symTab'))) -> do
              print v
              loop symTab'