module Language.Fortran.Vars.Eval
( eval
, eval'
, evalWithShortcircuit
)
where
import Prelude hiding ( fail )
import qualified Data.Map as M
import Language.Fortran.AST ( BinaryOp(..)
, Expression(..)
, Value(..)
, AList(..)
, Argument(..)
)
import Language.Fortran.Util.Position ( getSpan )
import Language.Fortran.Vars.Operation
( binaryOp'
, binaryTransformEither
, nonLogicalToLogical
, transformEither
, transformEitherList
, unaryOp'
, valueToExpVal'
, intrinsicFunctionCall
)
import Language.Fortran.Vars.Types
( SymbolTableEntry(..)
, ExpVal(..)
, SymbolTable
)
eval' :: SymbolTable -> Expression a -> Either String ExpVal
eval' :: SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symTable Expression a
expr = case Expression a
expr of
ExpValue a
_ SrcSpan
_ (ValVariable String
name) -> case String -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
name SymbolTable
symTable of
Just (SParameter Type
_ ExpVal
expVal) -> ExpVal -> Either String ExpVal
forall a b. b -> Either a b
Right ExpVal
expVal
Just SymbolTableEntry
_ -> String -> Either String ExpVal
forall a b. a -> Either a b
Left (String -> Either String ExpVal) -> String -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ String
"Cannot be evaluated: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a parameter."
Maybe SymbolTableEntry
Nothing -> String -> Either String ExpVal
forall a b. a -> Either a b
Left (String -> Either String ExpVal) -> String -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ String
"Cannot find parameter : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
ExpValue a
_ SrcSpan
s Value a
val -> SrcSpan -> Value a -> Either String ExpVal
forall a. SrcSpan -> Value a -> Either String ExpVal
valueToExpVal' SrcSpan
s Value a
val
ExpUnary a
_ SrcSpan
_ UnaryOp
op Expression a
e -> (ExpVal -> Either String ExpVal)
-> Either String ExpVal -> Either String ExpVal
forall a b.
(a -> Either String b) -> Either String a -> Either String b
transformEither (UnaryOp -> ExpVal -> Either String ExpVal
unaryOp' UnaryOp
op) (Either String ExpVal -> Either String ExpVal)
-> Either String ExpVal -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symTable Expression a
e
ExpBinary a
_ SrcSpan
_ BinaryOp
op Expression a
e1 Expression a
e2 ->
(ExpVal -> ExpVal -> Either String ExpVal)
-> Either String ExpVal
-> Either String ExpVal
-> Either String ExpVal
forall a b.
(a -> a -> Either String b)
-> Either String a -> Either String a -> Either String b
binaryTransformEither (BinaryOp -> ExpVal -> ExpVal -> Either String ExpVal
binaryOp' BinaryOp
op) (SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symTable Expression a
e1) (SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symTable Expression a
e2)
ExpFunctionCall a
_ SrcSpan
_ (ExpValue a
_ SrcSpan
_ Value a
function) (Just (AList a
_ SrcSpan
_ [Argument a]
args)) ->
([ExpVal] -> Either String ExpVal)
-> [Either String ExpVal] -> Either String ExpVal
forall a b.
([a] -> Either String b) -> [Either String a] -> Either String b
transformEitherList [ExpVal] -> Either String ExpVal
intrinsicFunctionCall' ([Either String ExpVal] -> Either String ExpVal)
-> [Either String ExpVal] -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ [Argument a] -> [Either String ExpVal]
forall a. [Argument a] -> [Either String ExpVal]
evalArgs [Argument a]
args
where
intrinsicFunctionCall' :: [ExpVal] -> Either String ExpVal
intrinsicFunctionCall' = String -> [ExpVal] -> Either String ExpVal
intrinsicFunctionCall (String -> [ExpVal] -> Either String ExpVal)
-> String -> [ExpVal] -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ Value a -> String
forall a. Value a -> String
functionName Value a
function
functionName :: Value a -> String
functionName (ValVariable String
name) = String
name
functionName (ValIntrinsic String
name) = String
name
functionName Value a
_ = String
""
evalArgs :: [Argument a] -> [Either String ExpVal]
evalArgs :: [Argument a] -> [Either String ExpVal]
evalArgs [] = []
evalArgs [Argument a
_ SrcSpan
_ Maybe String
_ Expression a
arg ] = [SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symTable Expression a
arg]
evalArgs (Argument a
_ SrcSpan
_ Maybe String
_ Expression a
arg : [Argument a]
args') = SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symTable Expression a
arg Either String ExpVal
-> [Either String ExpVal] -> [Either String ExpVal]
forall a. a -> [a] -> [a]
: [Argument a] -> [Either String ExpVal]
forall a. [Argument a] -> [Either String ExpVal]
evalArgs [Argument a]
args'
Expression a
_ -> String -> Either String ExpVal
forall a b. a -> Either a b
Left (String -> Either String ExpVal) -> String -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ String
"Unsupported expression at: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SrcSpan -> String
forall a. Show a => a -> String
show (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
expr)
eval :: SymbolTable -> Expression a -> ExpVal
eval :: SymbolTable -> Expression a -> ExpVal
eval SymbolTable
symTable Expression a
expr = case SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symTable Expression a
expr of
Left String
err -> String -> ExpVal
forall a. HasCallStack => String -> a
error (String
err String -> String -> String
forall a. [a] -> [a] -> [a]
++ SrcSpan -> String
forall a. Show a => a -> String
show (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
expr))
Right ExpVal
r -> ExpVal
r
evalWithShortcircuit :: SymbolTable -> Expression a -> Either String ExpVal
evalWithShortcircuit :: SymbolTable -> Expression a -> Either String ExpVal
evalWithShortcircuit SymbolTable
symTable Expression a
expr = case Expression a
expr of
ExpUnary a
_ SrcSpan
_ UnaryOp
op Expression a
e ->
(ExpVal -> Either String ExpVal)
-> Either String ExpVal -> Either String ExpVal
forall a b.
(a -> Either String b) -> Either String a -> Either String b
transformEither (UnaryOp -> ExpVal -> Either String ExpVal
unaryOp' UnaryOp
op) (Either String ExpVal -> Either String ExpVal)
-> Either String ExpVal -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
evalWithShortcircuit SymbolTable
symTable Expression a
e
ExpBinary a
_ SrcSpan
_ BinaryOp
op Expression a
e1 Expression a
e2 ->
let e1' :: Either String ExpVal
e1' = SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
evalWithShortcircuit SymbolTable
symTable Expression a
e1
e2' :: Either String ExpVal
e2' = SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
evalWithShortcircuit SymbolTable
symTable Expression a
e2
t :: Either String ExpVal -> Either String Bool
t = (ExpVal -> Either String Bool)
-> Either String ExpVal -> Either String Bool
forall a b.
(a -> Either String b) -> Either String a -> Either String b
transformEither ExpVal -> Either String Bool
nonLogicalToLogical
in case (BinaryOp
op, Either String ExpVal -> Either String Bool
t Either String ExpVal
e1', Either String ExpVal -> Either String Bool
t Either String ExpVal
e2') of
(BinaryOp
And, Right Bool
r , Right Bool
l ) -> ExpVal -> Either String ExpVal
forall a b. b -> Either a b
Right (ExpVal -> Either String ExpVal)
-> (Bool -> ExpVal) -> Bool -> Either String ExpVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ExpVal
Logical (Bool -> Either String ExpVal) -> Bool -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ Bool
r Bool -> Bool -> Bool
&& Bool
l
(BinaryOp
And, Right Bool
False, Either String Bool
_ ) -> ExpVal -> Either String ExpVal
forall a b. b -> Either a b
Right (ExpVal -> Either String ExpVal) -> ExpVal -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ Bool -> ExpVal
Logical Bool
False
(BinaryOp
And, Either String Bool
_ , Right Bool
False) -> ExpVal -> Either String ExpVal
forall a b. b -> Either a b
Right (ExpVal -> Either String ExpVal) -> ExpVal -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ Bool -> ExpVal
Logical Bool
False
(BinaryOp
Or , Right Bool
r , Right Bool
l ) -> ExpVal -> Either String ExpVal
forall a b. b -> Either a b
Right (ExpVal -> Either String ExpVal)
-> (Bool -> ExpVal) -> Bool -> Either String ExpVal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ExpVal
Logical (Bool -> Either String ExpVal) -> Bool -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ Bool
r Bool -> Bool -> Bool
|| Bool
l
(BinaryOp
Or , Right Bool
True , Either String Bool
_ ) -> ExpVal -> Either String ExpVal
forall a b. b -> Either a b
Right (ExpVal -> Either String ExpVal) -> ExpVal -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ Bool -> ExpVal
Logical Bool
True
(BinaryOp
Or , Either String Bool
_ , Right Bool
True ) -> ExpVal -> Either String ExpVal
forall a b. b -> Either a b
Right (ExpVal -> Either String ExpVal) -> ExpVal -> Either String ExpVal
forall a b. (a -> b) -> a -> b
$ Bool -> ExpVal
Logical Bool
True
(BinaryOp, Either String Bool, Either String Bool)
_ -> (ExpVal -> ExpVal -> Either String ExpVal)
-> Either String ExpVal
-> Either String ExpVal
-> Either String ExpVal
forall a b.
(a -> a -> Either String b)
-> Either String a -> Either String a -> Either String b
binaryTransformEither (BinaryOp -> ExpVal -> ExpVal -> Either String ExpVal
binaryOp' BinaryOp
op) Either String ExpVal
e1' Either String ExpVal
e2'
Expression a
_ -> SymbolTable -> Expression a -> Either String ExpVal
forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symTable Expression a
expr