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
                                                )

-- | Given a 'SymbolTable' and some 'Expression', evaluate that expression
-- into a basic type and return it as an 'ExpVal' or a 'String' describing
-- the issue that prevented the evaluation
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)

-- | Given a 'SymbolTable' and some 'Expression', evaluate that expression
-- into a basic type and return it as an 'ExpVal'
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

-- | Given a 'SymbolTable' and some 'Expression', evaluate that expression
-- into a basic type and return it as an 'ExpVal' or a 'String' describing
-- the issue that prevented the evaluation. In the case of expressions like
--
-- @
--       foobar .AND. .FALSE.
--       .TRUE. .OR. .foobar
-- @
--
-- the expressions will be shortcircuited to produce
--
-- @
--       .FALSE.
--       .TRUE.
-- @
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