Expr.hs

module Calculator.Evaluator.Expr (evalExpr) where

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

import           Calculator.Prim.Base (Number)
import           Calculator.Prim.Expr (Bindings, Expr (..), Operator (..),
                                       fromConst, isConst, joinErrors)

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

import           Data.Function        (on)

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

evalExpr :: Bindings -> Expr -> Expr
evalExpr _ e@(Constant _)     = e
evalExpr _ e@(InvalidError _) = e
-- evalExpr b (UnOp (UnaryOp op) e) = Constant . op . fromConst $ evalExpr b e
evalExpr b (BinOp (expr, rest))  = process b expr rest
evalExpr (vs, _) (Variable s) =
  case lookup s vs of
    Nothing -> InvalidError ["Unknown variable " ++ show s]
    Just v  -> Constant v
evalExpr b (Function "" e) = evalExpr b e
evalExpr b@(_, fs) (Function f e)  =
  let func = lookup f fs :: Maybe (Number -> Number)
  in case evalExpr b e of
       Constant x -> case func of
                       Nothing -> InvalidError ["Unknown function " ++ show f]
                       Just g  -> Constant $ g x
       r@(InvalidError _) -> r
       _ -> InvalidError ["Recieved Impossible result from evalExpr"]
evalExpr _ _ = InvalidError ["Could not find suitable pattern for evalExpr"]

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

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) =
  let val1 = evalExpr b e1
      val2 = evalExpr b e2
  in if ((&&) `on` isConst) val1 val2
     then Constant $ (op `on` fromConst) val1 val2
     else case (val1, val2) of
           (e@(InvalidError _), f@(InvalidError _)) -> joinErrors e f
           (_, e@(InvalidError _)) -> e
           (e@(InvalidError _), _) -> e
           _ -> InvalidError ["Could not find matching pairs for evalPart"]
evalPart _ _ _ = InvalidError ["Could not find suitable pattern for evalPart"]

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