Evaluator.hs

module Model.CellExpression.Evaluator (evaluate,Lookup)
    where

import Prelude hiding (lookup)
import Control.Applicative ((<$>))
import Control.Monad (forM)
import Model.CellContent (CellExpr (..),CellValue(..),RuntimeReason(..)
                         ,Reference(..),Symbol)
import Model.CellExpression.Evaluator.Common 
    (fLength,withNum,withList,withNumList,getNumList,withBool)
import Model.CellExpression.Evaluator.Math (mean,median)

type Lookup = Reference -> IO CellValue

evaluate :: Lookup -> CellExpr -> IO CellValue
evaluate lookup e =
    case e of
      EmptyExpr -> return $ EmptyValue
      NumberExpr a -> return $ NumberValue a
      StringExpr a -> return $ StringValue a
      ListExpr a -> ListValue <$> forM a eval
      Reference a -> lookup a
      UnaryOp "-" a -> mathBinary (-) <$> forM [NumberExpr 0,a] eval
      BinaryOp "+" a b -> mathBinary (+) <$> forM [a,b] eval
      BinaryOp "-" a b -> mathBinary (-) <$> forM [a,b] eval
      BinaryOp "*" a b -> mathBinary (*) <$> forM [a,b] eval
      BinaryOp "/" a b -> mathBinary (/) <$> forM [a,b] eval
      BinaryOp "^" a b -> mathBinary (**) <$> forM [a,b] eval
      BinaryOp "==" a b -> relation (==) <$> forM [a,b] eval
      BinaryOp "/=" a b -> relation (/=) <$> forM [a,b] eval
      BinaryOp "<" a b -> relation (<) <$> forM [a,b] eval
      BinaryOp "<=" a b -> relation (<=) <$> forM [a,b] eval
      BinaryOp ">" a b -> relation (>) <$> forM [a,b] eval
      BinaryOp ">=" a b -> relation (>=) <$> forM [a,b] eval
      BinaryOp "&&" a b -> logicalBinary (&&) <$> forM [a,b] eval
      BinaryOp "||" a b -> logicalBinary (||) <$> forM [a,b] eval
      Call f arg -> evaluateFun f <$> eval arg
      Constant c -> return $ evaluateConstant c
      Sub a -> eval a
      IfThenElse if' then' else' ->
          do ifValue <- eval if'
             thenValue <- eval then'
             elseValue <- eval else'
             return $ withBool ifValue
                        (\c -> if c then thenValue else elseValue)
      NamedReference a -> error $ "Model.CellExpression.Evaluator.evaluate: NamedReference: " ++ show a
      CompileErrorExpr a -> return $ Error $ CompileError a          
    where eval = evaluate lookup 

evaluateFun :: Symbol -> CellValue -> CellValue
evaluateFun f arg = 
    case f of
      "sum" -> withNumList arg $ NumberValue . sum
      "count" -> withList arg $ NumberValue . fLength
      "abs" -> withNum arg $ NumberValue . abs
      "mean" -> withNumList arg $ NumberValue . mean
      "median" -> withNumList arg $ NumberValue . median
      "not" -> withBool arg $ BoolValue . not
      _ -> Error $ UnknownIdentifier f

evaluateConstant :: Symbol -> CellValue
evaluateConstant c = 
    case c of
      "true" -> BoolValue True
      "false" -> BoolValue False
      "pi" -> NumberValue pi
      _ -> Error $ UnknownIdentifier c

mathBinary :: (Double -> Double -> Double) -> [CellValue] -> CellValue
mathBinary f = 
    either Error (\[a,b] -> NumberValue $ f a b) . getNumList

relation :: (CellValue -> CellValue -> Bool) -> [CellValue] -> CellValue
relation f [a,b] = 
    case (a,b) of 
      (Error x,_) -> Error x
      (_,Error x) -> Error x
      (EmptyValue,EmptyValue) -> BoolValue $ f a b
      (NumberValue _,NumberValue _) -> BoolValue $ f a b
      (StringValue _,StringValue _) -> BoolValue $ f a b
      (ListValue xs,ListValue ys) -> 
          let isTrue (BoolValue True) = True
              isTrue _ = False
          in
            BoolValue $ and $ map (isTrue . relation f) 
                          $ zipWith (\x y -> [x,y]) xs ys
      (BoolValue _,BoolValue _) -> BoolValue $ f a b
      _ -> Error $ TypeError b

logicalBinary :: (Bool -> Bool -> Bool) -> [CellValue] -> CellValue
logicalBinary f [a,b] =
    case (a,b) of
      (Error x,_) -> Error x
      (_,Error x) -> Error x
      (BoolValue x,BoolValue y) -> BoolValue $ f x y
      (BoolValue _,_) -> Error $ TypeError b
      _ -> Error $ TypeError a