Expr.hs

module Calculator.Evaluator.Expr (evalExpr) where

--------------------------------------------------------------------------------

import           Calculator.Prim.Bindings (Bindings, getFun, getVar)
import           Calculator.Prim.Expr     (Expr (..), Operator (..), isConst,
                                           joinMessage)
import           Calculator.Prim.Function (Function (..))

--------------------------------------------------------------------------------

evalExpr :: Bindings -> Expr -> Expr
evalExpr _ e@(Constant _) = e
evalExpr _ e@(Message _)  = e
evalExpr b (UnOp (UnaryOp op) e) =
    case evalExpr b e of
      Constant z -> Constant (op z)
      _          -> Message ["Negating invalid expression"]
evalExpr b (BinOp (e, r)) = process b e r
evalExpr b (Variable s)   =
  case getVar s b of
    Nothing -> Message ["Unknown variable " ++ show s]
    Just v  -> Constant v
evalExpr b (Call f args)  =
    let argVals = map (evalExpr b) args
    in if all isConst argVals
       then fapply b f (map (\(Constant x) -> x) argVals)
       else getMessage argVals
evalExpr _ _ = Message ["Could not find suitable pattern for evalExpr"]

--------------------------------------------------------------------------------

fapply :: Bindings -> String -> [Double] -> Expr
fapply b f args = case getFun f b of
                    Nothing -> Message ["Unknown function " ++ show f]
                    Just g  -> case apply g args of
                                 Left m  -> Message m
                                 Right v -> Constant v

--------------------------------------------------------------------------------

getMessage :: [Expr] -> Expr
getMessage xs = foldr joinMessage (Message []) xs

--------------------------------------------------------------------------------

process :: Bindings -> Expr -> [(Operator, Expr)] -> Expr
process bind expr rest = evalExpr bind $ foldl (evalPart bind) expr rest

--------------------------------------------------------------------------------

evalPart :: Bindings -> Expr -> (Operator, Expr) -> Expr
evalPart b e1 ((BinaryOp op), e2) =
  case (evalExpr b e1, evalExpr b e2) of
    (Constant n1, Constant n2) -> Constant $ op n1 n2
    (msg1, msg2)               -> joinMessage msg1 msg2
evalPart _ _ _ = Message ["Could not find suitable pattern for evalPart"]

--------------------------------------------------------------------------------