{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingVia #-}

-- | Evaluate AST terms to values in the value representation.

module Language.Fortran.Repr.Eval.Value where

import qualified Language.Fortran.AST as F
import qualified Language.Fortran.AST.Literal.Real as F
import qualified Language.Fortran.AST.Literal.Complex as F
import qualified Language.Fortran.AST.Literal.Boz as F

import Language.Fortran.Repr.Value
import Language.Fortran.Repr.Value.Scalar
import Language.Fortran.Repr.Value.Scalar.Common
import Language.Fortran.Repr.Value.Scalar.Int.Machine
import Language.Fortran.Repr.Value.Scalar.Real
import Language.Fortran.Repr.Value.Scalar.Logical.Machine
import Language.Fortran.Repr.Value.Scalar.String

import Language.Fortran.Repr.Type ( FType )
import Language.Fortran.Repr.Type.Scalar.Common ( FKindLit )
import Language.Fortran.Repr.Type.Scalar ( fScalarTypeKind )

import Language.Fortran.Repr.Eval.Common
import qualified Language.Fortran.Repr.Eval.Value.Op as Op

import qualified Language.Fortran.Analysis as FA

import GHC.Generics ( Generic )
import qualified Data.Text as Text
import qualified Data.Char
import qualified Data.Bits
import Data.Int

import Control.Monad.Except

import Data.Word ( Word8 )

-- pure implementation
import Control.Monad.Reader
import Control.Monad.Writer
import qualified Data.Map as Map
import Data.Map ( Map )

-- | Error encountered while evaluating a Fortran expression to a value.
data Error
  = ENoSuchVar F.Name
  | EKindLitBadType F.Name FType
  | ENoSuchKindForType String FKindLit

  | EUnsupported String
  -- ^ Syntax which probably should be supported, but (currently) isn't.

  | EOp Op.Error
  | EOpTypeError String

  | ESpecial String
  -- ^ Special value-like expression that we can't evaluate usefully.

  | ELazy String
  -- ^ Catch-all for non-grouped errors.

    deriving stock ((forall x. Error -> Rep Error x)
-> (forall x. Rep Error x -> Error) -> Generic Error
forall x. Rep Error x -> Error
forall x. Error -> Rep Error x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Error -> Rep Error x
from :: forall x. Error -> Rep Error x
$cto :: forall x. Rep Error x -> Error
to :: forall x. Rep Error x -> Error
Generic, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Error -> ShowS
showsPrec :: Int -> Error -> ShowS
$cshow :: Error -> String
show :: Error -> String
$cshowList :: [Error] -> ShowS
showList :: [Error] -> ShowS
Show, Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
/= :: Error -> Error -> Bool
Eq)

-- | A convenience constraint tuple defining the base requirements of the
--   'FValue' evaluator.
--
-- The evaluator is formed of combinators returning values in this monad. You
-- may insert your own evaluator which handles monadic actions differently,
-- provided it can fulfill these constraints.
type MonadFEvalValue m = (MonadFEval m, EvalTo m ~ FValue, MonadError Error m)

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

-- | derivingvia helper
type FEvalValuePureT = WriterT [String] (ExceptT Error (Reader (Map F.Name FValue)))

-- | A simple pure interpreter for Fortran value evaluation programs.
newtype FEvalValuePure a = FEvalValuePure { forall a.
FEvalValuePure a
-> WriterT [String] (ExceptT Error (Reader (Map String FValue))) a
unFEvalValuePure :: WriterT [String] (ExceptT Error (Reader (Map F.Name FValue))) a }
    deriving ((forall a b. (a -> b) -> FEvalValuePure a -> FEvalValuePure b)
-> (forall a b. a -> FEvalValuePure b -> FEvalValuePure a)
-> Functor FEvalValuePure
forall a b. a -> FEvalValuePure b -> FEvalValuePure a
forall a b. (a -> b) -> FEvalValuePure a -> FEvalValuePure b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> FEvalValuePure a -> FEvalValuePure b
fmap :: forall a b. (a -> b) -> FEvalValuePure a -> FEvalValuePure b
$c<$ :: forall a b. a -> FEvalValuePure b -> FEvalValuePure a
<$ :: forall a b. a -> FEvalValuePure b -> FEvalValuePure a
Functor, Functor FEvalValuePure
Functor FEvalValuePure =>
(forall a. a -> FEvalValuePure a)
-> (forall a b.
    FEvalValuePure (a -> b) -> FEvalValuePure a -> FEvalValuePure b)
-> (forall a b c.
    (a -> b -> c)
    -> FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure c)
-> (forall a b.
    FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure b)
-> (forall a b.
    FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure a)
-> Applicative FEvalValuePure
forall a. a -> FEvalValuePure a
forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure a
forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure b
forall a b.
FEvalValuePure (a -> b) -> FEvalValuePure a -> FEvalValuePure b
forall a b c.
(a -> b -> c)
-> FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> FEvalValuePure a
pure :: forall a. a -> FEvalValuePure a
$c<*> :: forall a b.
FEvalValuePure (a -> b) -> FEvalValuePure a -> FEvalValuePure b
<*> :: forall a b.
FEvalValuePure (a -> b) -> FEvalValuePure a -> FEvalValuePure b
$cliftA2 :: forall a b c.
(a -> b -> c)
-> FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure c
liftA2 :: forall a b c.
(a -> b -> c)
-> FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure c
$c*> :: forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure b
*> :: forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure b
$c<* :: forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure a
<* :: forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure a
Applicative, Applicative FEvalValuePure
Applicative FEvalValuePure =>
(forall a b.
 FEvalValuePure a -> (a -> FEvalValuePure b) -> FEvalValuePure b)
-> (forall a b.
    FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure b)
-> (forall a. a -> FEvalValuePure a)
-> Monad FEvalValuePure
forall a. a -> FEvalValuePure a
forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure b
forall a b.
FEvalValuePure a -> (a -> FEvalValuePure b) -> FEvalValuePure b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b.
FEvalValuePure a -> (a -> FEvalValuePure b) -> FEvalValuePure b
>>= :: forall a b.
FEvalValuePure a -> (a -> FEvalValuePure b) -> FEvalValuePure b
$c>> :: forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure b
>> :: forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure b
$creturn :: forall a. a -> FEvalValuePure a
return :: forall a. a -> FEvalValuePure a
Monad) via FEvalValuePureT
    deriving (MonadReader (Map F.Name FValue)) via FEvalValuePureT
    deriving (MonadWriter [String]) via FEvalValuePureT
    deriving (MonadError Error) via FEvalValuePureT

instance MonadFEval FEvalValuePure where
    type EvalTo FEvalValuePure = FValue
    warn :: String -> FEvalValuePure ()
warn String
msg = [String] -> FEvalValuePure ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
msg]
    lookupFVar :: String -> FEvalValuePure (Maybe (EvalTo FEvalValuePure))
lookupFVar String
nm = do
        Map String FValue
m <- FEvalValuePure (Map String FValue)
forall r (m :: * -> *). MonadReader r m => m r
ask
        Maybe FValue -> FEvalValuePure (Maybe FValue)
forall a. a -> FEvalValuePure a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FValue -> FEvalValuePure (Maybe FValue))
-> Maybe FValue -> FEvalValuePure (Maybe FValue)
forall a b. (a -> b) -> a -> b
$ String -> Map String FValue -> Maybe FValue
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
nm Map String FValue
m

runEvalFValuePure
    :: Map F.Name FValue
    -> FEvalValuePure a -> Either Error (a, [String])
runEvalFValuePure :: forall a.
Map String FValue -> FEvalValuePure a -> Either Error (a, [String])
runEvalFValuePure Map String FValue
m =
    (Reader (Map String FValue) (Either Error (a, [String]))
 -> Map String FValue -> Either Error (a, [String]))
-> Map String FValue
-> Reader (Map String FValue) (Either Error (a, [String]))
-> Either Error (a, [String])
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader (Map String FValue) (Either Error (a, [String]))
-> Map String FValue -> Either Error (a, [String])
forall r a. Reader r a -> r -> a
runReader Map String FValue
m (Reader (Map String FValue) (Either Error (a, [String]))
 -> Either Error (a, [String]))
-> (FEvalValuePure a
    -> Reader (Map String FValue) (Either Error (a, [String])))
-> FEvalValuePure a
-> Either Error (a, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT Error (Reader (Map String FValue)) (a, [String])
-> Reader (Map String FValue) (Either Error (a, [String]))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Error (Reader (Map String FValue)) (a, [String])
 -> Reader (Map String FValue) (Either Error (a, [String])))
-> (FEvalValuePure a
    -> ExceptT Error (Reader (Map String FValue)) (a, [String]))
-> FEvalValuePure a
-> Reader (Map String FValue) (Either Error (a, [String]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [String] (ExceptT Error (Reader (Map String FValue))) a
-> ExceptT Error (Reader (Map String FValue)) (a, [String])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT [String] (ExceptT Error (Reader (Map String FValue))) a
 -> ExceptT Error (Reader (Map String FValue)) (a, [String]))
-> (FEvalValuePure a
    -> WriterT [String] (ExceptT Error (Reader (Map String FValue))) a)
-> FEvalValuePure a
-> ExceptT Error (Reader (Map String FValue)) (a, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FEvalValuePure a
-> WriterT [String] (ExceptT Error (Reader (Map String FValue))) a
forall a.
FEvalValuePure a
-> WriterT [String] (ExceptT Error (Reader (Map String FValue))) a
unFEvalValuePure

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

evalVar :: MonadFEvalValue m => F.Name -> m FValue
evalVar :: forall (m :: * -> *). MonadFEvalValue m => String -> m FValue
evalVar String
name =
    String -> m (Maybe (EvalTo m))
forall (m :: * -> *).
MonadFEval m =>
String -> m (Maybe (EvalTo m))
lookupFVar String
name m (Maybe FValue) -> (Maybe FValue -> m FValue) -> m FValue
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe FValue
Nothing  -> Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
ENoSuchVar String
name
      Just FValue
val -> FValue -> m FValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FValue
val

evalExpr :: MonadFEvalValue m => F.Expression (FA.Analysis a) -> m FValue
evalExpr :: forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression (Analysis a) -> m FValue
evalExpr = \case
  e :: Expression (Analysis a)
e@(F.ExpValue Analysis a
_ SrcSpan
_ Value (Analysis a)
astVal) ->
    case Value (Analysis a)
astVal of
      F.ValVariable String
name -> String -> m FValue
forall (m :: * -> *). MonadFEvalValue m => String -> m FValue
evalVar (Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
FA.varName Expression (Analysis a)
e)
      -- TODO: Do same with ValIntrinsic??? idk...
      Value (Analysis a)
_ -> FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue) -> m FScalarValue -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value (Analysis a) -> m FScalarValue
forall (m :: * -> *) a.
MonadFEvalValue m =>
Value (Analysis a) -> m FScalarValue
evalLit Value (Analysis a)
astVal
  F.ExpUnary  Analysis a
_ SrcSpan
_ UnaryOp
uop Expression (Analysis a)
e   -> do
    FValue
v <- Expression (Analysis a) -> m FValue
forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression (Analysis a) -> m FValue
evalExpr Expression (Analysis a)
e
    UnaryOp -> FValue -> m FValue
forall (m :: * -> *).
MonadFEvalValue m =>
UnaryOp -> FValue -> m FValue
evalUOp UnaryOp
uop FValue
v
  F.ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
bop Expression (Analysis a)
le Expression (Analysis a)
re -> do
    -- TODO 2022-08-23 raehik: here is where we would implement
    -- short-circuiting, by inspecting the bop earlier and having special cases
    -- for certain bops
    FValue
lv <- Expression (Analysis a) -> m FValue
forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression (Analysis a) -> m FValue
evalExpr Expression (Analysis a)
le
    FValue
rv <- Expression (Analysis a) -> m FValue
forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression (Analysis a) -> m FValue
evalExpr Expression (Analysis a)
re
    BinaryOp -> FValue -> FValue -> m FValue
forall (m :: * -> *).
MonadFEvalValue m =>
BinaryOp -> FValue -> FValue -> m FValue
evalBOp BinaryOp
bop FValue
lv FValue
rv
  F.ExpFunctionCall Analysis a
_ SrcSpan
_ Expression (Analysis a)
ve AList Argument (Analysis a)
args -> do
    -- same here, could more arg evaluation into op
    [FValue]
evaledArgs <- (Argument (Analysis a) -> m FValue)
-> [Argument (Analysis a)] -> m [FValue]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Argument (Analysis a) -> m FValue
forall (m :: * -> *) a.
MonadFEvalValue m =>
Argument (Analysis a) -> m FValue
evalArg ([Argument (Analysis a)] -> m [FValue])
-> [Argument (Analysis a)] -> m [FValue]
forall a b. (a -> b) -> a -> b
$ AList Argument (Analysis a) -> [Argument (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
F.alistList AList Argument (Analysis a)
args
    String -> [FValue] -> m FValue
forall (m :: * -> *).
MonadFEvalValue m =>
String -> [FValue] -> m FValue
evalFunctionCall (Expression (Analysis a) -> String
forall a. Expression (Analysis a) -> String
forceVarExpr Expression (Analysis a)
ve) [FValue]
evaledArgs
  Expression (Analysis a)
_ -> Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EUnsupported String
"Expression constructor"

forceVarExpr :: F.Expression (FA.Analysis a) -> F.Name
forceVarExpr :: forall a. Expression (Analysis a) -> String
forceVarExpr = \case
  F.ExpValue Analysis a
_ SrcSpan
_ (F.ValVariable String
v) -> String
v
  F.ExpValue Analysis a
_ SrcSpan
_ (F.ValIntrinsic String
v) -> String
v
  Expression (Analysis a)
_ -> ShowS
forall a. HasCallStack => String -> a
error String
"program error, sent me an expr that wasn't a name"

evalLit :: MonadFEvalValue m => F.Value (FA.Analysis a) -> m FScalarValue
evalLit :: forall (m :: * -> *) a.
MonadFEvalValue m =>
Value (Analysis a) -> m FScalarValue
evalLit = \case
  F.ValInteger String
i Maybe (KindParam (Analysis a))
mkp -> do
    FKindLit -> Maybe (KindParam (Analysis a)) -> m FKindLit
forall (m :: * -> *) a.
MonadFEvalValue m =>
FKindLit -> Maybe (KindParam (Analysis a)) -> m FKindLit
evalMKp FKindLit
4 Maybe (KindParam (Analysis a))
mkp m FKindLit -> (FKindLit -> m FScalarValue) -> m FScalarValue
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      FKindLit
4 -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Int32 -> FInt
FInt4 (Int32 -> FInt) -> Int32 -> FInt
forall a b. (a -> b) -> a -> b
$ String -> Int32
forall a. Read a => String -> a
read String
i
      FKindLit
8 -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Int64 -> FInt
FInt8 (Int64 -> FInt) -> Int64 -> FInt
forall a b. (a -> b) -> a -> b
$ String -> Int64
forall a. Read a => String -> a
read String
i
      FKindLit
2 -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Int16 -> FInt
FInt2 (Int16 -> FInt) -> Int16 -> FInt
forall a b. (a -> b) -> a -> b
$ String -> Int16
forall a. Read a => String -> a
read String
i
      FKindLit
1 -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Int8 -> FInt
FInt1 (Int8 -> FInt) -> Int8 -> FInt
forall a b. (a -> b) -> a -> b
$ String -> Int8
forall a. Read a => String -> a
read String
i
      FKindLit
k -> Error -> m FScalarValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FScalarValue) -> Error -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> FKindLit -> Error
ENoSuchKindForType String
"INTEGER" FKindLit
k
  F.ValReal RealLit
r Maybe (KindParam (Analysis a))
mkp -> do
    ExponentLetter -> Maybe (KindParam (Analysis a)) -> m FKindLit
forall (m :: * -> *) a.
MonadFEvalValue m =>
ExponentLetter -> Maybe (KindParam (Analysis a)) -> m FKindLit
evalRealKp (Exponent -> ExponentLetter
F.exponentLetter (RealLit -> Exponent
F.realLitExponent RealLit
r)) Maybe (KindParam (Analysis a))
mkp m FKindLit -> (FKindLit -> m FScalarValue) -> m FScalarValue
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      FKindLit
4 -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal (FReal -> FScalarValue) -> FReal -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Float -> FReal
FReal4 (Float -> FReal) -> Float -> FReal
forall a b. (a -> b) -> a -> b
$ RealLit -> Float
forall a. (Fractional a, Read a) => RealLit -> a
F.readRealLit RealLit
r
      FKindLit
8 -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal (FReal -> FScalarValue) -> FReal -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Double -> FReal
FReal8 (Double -> FReal) -> Double -> FReal
forall a b. (a -> b) -> a -> b
$ RealLit -> Double
forall a. (Fractional a, Read a) => RealLit -> a
F.readRealLit RealLit
r
      FKindLit
k -> Error -> m FScalarValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FScalarValue) -> Error -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> FKindLit -> Error
ENoSuchKindForType String
"REAL" FKindLit
k
  F.ValLogical Bool
b Maybe (KindParam (Analysis a))
mkp -> do
    FKindLit -> Maybe (KindParam (Analysis a)) -> m FKindLit
forall (m :: * -> *) a.
MonadFEvalValue m =>
FKindLit -> Maybe (KindParam (Analysis a)) -> m FKindLit
evalMKp FKindLit
4 Maybe (KindParam (Analysis a))
mkp m FKindLit -> (FKindLit -> m FScalarValue) -> m FScalarValue
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      FKindLit
4 -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVLogical (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Int32 -> FInt
FInt4 (Int32 -> FInt) -> Int32 -> FInt
forall a b. (a -> b) -> a -> b
$ Bool -> Int32
forall a. Num a => Bool -> a
fLogicalNumericFromBool Bool
b
      FKindLit
8 -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVLogical (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Int64 -> FInt
FInt8 (Int64 -> FInt) -> Int64 -> FInt
forall a b. (a -> b) -> a -> b
$ Bool -> Int64
forall a. Num a => Bool -> a
fLogicalNumericFromBool Bool
b
      FKindLit
2 -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVLogical (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Int16 -> FInt
FInt2 (Int16 -> FInt) -> Int16 -> FInt
forall a b. (a -> b) -> a -> b
$ Bool -> Int16
forall a. Num a => Bool -> a
fLogicalNumericFromBool Bool
b
      FKindLit
1 -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVLogical (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Int8 -> FInt
FInt1 (Int8 -> FInt) -> Int8 -> FInt
forall a b. (a -> b) -> a -> b
$ Bool -> Int8
forall a. Num a => Bool -> a
fLogicalNumericFromBool Bool
b
      FKindLit
k -> Error -> m FScalarValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FScalarValue) -> Error -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> FKindLit -> Error
ENoSuchKindForType String
"LOGICAL" FKindLit
k
  F.ValComplex (F.ComplexLit Analysis a
_ SrcSpan
_ ComplexPart (Analysis a)
_cr ComplexPart (Analysis a)
_ci) ->
    -- TODO annoying & tedious. see Fortran 2008 spec 4.4.2.4
    -- 1. evaluate each part
    -- 2. determine kind parameter (largest real, or default if both ints)
    --    - fail here if a named part wasn't real or int
    -- 3. upgrade both parts to that kind
    -- 4. package and return
    Error -> m FScalarValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FScalarValue) -> Error -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EUnsupported String
"COMPLEX literals"
  F.ValString String
s -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ Text -> FScalarValue
FSVString (Text -> FScalarValue) -> Text -> FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
s
  F.ValBoz Boz
boz -> do
    String -> m ()
forall (m :: * -> *). MonadFEval m => String -> m ()
warn String
"requested to evaluate BOZ literal with no context: defaulting to INTEGER(4)"
    FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Int32 -> FInt
FInt4 (Int32 -> FInt) -> Int32 -> FInt
forall a b. (a -> b) -> a -> b
$ Boz -> Int32
forall a. (Num a, Eq a, FiniteBits a) => Boz -> a
F.bozAsTwosComp Boz
boz
  F.ValHollerith String
s -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FScalarValue -> m FScalarValue) -> FScalarValue -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ Text -> FScalarValue
FSVString (Text -> FScalarValue) -> Text -> FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
s
  F.ValIntrinsic{} -> Error -> m FScalarValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FScalarValue) -> Error -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> Error
ESpecial String
"lit was ValIntrinsic{} (intrinsic name)"
  F.ValVariable{}  -> Error -> m FScalarValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FScalarValue) -> Error -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> Error
ESpecial String
"lit was ValVariable{} (variable name)"
  F.ValOperator{}  -> Error -> m FScalarValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FScalarValue) -> Error -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> Error
ESpecial String
"lit was ValOperator{} (custom operator name)"
  Value (Analysis a)
F.ValAssignment  -> Error -> m FScalarValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FScalarValue) -> Error -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> Error
ESpecial String
"lit was ValAssignment (overloaded assignment name)"
  Value (Analysis a)
F.ValStar        -> Error -> m FScalarValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FScalarValue) -> Error -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> Error
ESpecial String
"lit was ValStar"
  Value (Analysis a)
F.ValColon       -> Error -> m FScalarValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FScalarValue) -> Error -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> Error
ESpecial String
"lit was ValColon"
  F.ValType{}      -> Error -> m FScalarValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FScalarValue) -> Error -> m FScalarValue
forall a b. (a -> b) -> a -> b
$ String -> Error
ELazy String
"lit was ValType: not used anywhere, don't know what it is"

err :: MonadError Error m => Error -> m a
err :: forall (m :: * -> *) a. MonadError Error m => Error -> m a
err = Error -> m a
forall a. Error -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

evalKp :: MonadFEvalValue m => F.KindParam (FA.Analysis a) -> m FKindLit
evalKp :: forall (m :: * -> *) a.
MonadFEvalValue m =>
KindParam (Analysis a) -> m FKindLit
evalKp = \case
  F.KindParamInt Analysis a
_ SrcSpan
_ String
k ->
    -- TODO we may wish to check kind param sensibility here
    -- easy check is length (<=3)
    -- to catch the rest, we may need to read to Int16 and check.
    -- slow and unideal so for now let's assume no bad play such as INTEGER(256)
    FKindLit -> m FKindLit
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FKindLit -> m FKindLit) -> FKindLit -> m FKindLit
forall a b. (a -> b) -> a -> b
$ String -> FKindLit
forall a. Read a => String -> a
read String
k
  F.KindParamVar Analysis a
_ SrcSpan
_ String
var ->
    String -> m (Maybe (EvalTo m))
forall (m :: * -> *).
MonadFEval m =>
String -> m (Maybe (EvalTo m))
lookupFVar String
var m (Maybe FValue) -> (Maybe FValue -> m FKindLit) -> m FKindLit
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just FValue
val -> case FValue
val of
        MkFScalarValue (FSVInt FInt
i) ->
          FKindLit -> m FKindLit
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FKindLit -> m FKindLit) -> FKindLit -> m FKindLit
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FInt a => a -> FKindLit) -> FInt -> FKindLit
forall r. (forall a. FKindedC FInt a => a -> r) -> FInt -> r
fIntUOp a -> FKindLit
forall a. FKindedC FInt a => a -> FKindLit
forall a b. (Integral a, Num b) => a -> b
fromIntegral FInt
i
        FValue
_ -> Error -> m FKindLit
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FKindLit) -> Error -> m FKindLit
forall a b. (a -> b) -> a -> b
$ String -> FType -> Error
EKindLitBadType String
var (FValue -> FType
fValueType FValue
val)
      Maybe FValue
Nothing  -> Error -> m FKindLit
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FKindLit) -> Error -> m FKindLit
forall a b. (a -> b) -> a -> b
$ String -> Error
ENoSuchVar String
var

evalMKp :: MonadFEvalValue m => FKindLit -> Maybe (F.KindParam (FA.Analysis a)) -> m FKindLit
evalMKp :: forall (m :: * -> *) a.
MonadFEvalValue m =>
FKindLit -> Maybe (KindParam (Analysis a)) -> m FKindLit
evalMKp FKindLit
kDef = \case
  Maybe (KindParam (Analysis a))
Nothing -> FKindLit -> m FKindLit
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
kDef
  Just KindParam (Analysis a)
kp -> KindParam (Analysis a) -> m FKindLit
forall (m :: * -> *) a.
MonadFEvalValue m =>
KindParam (Analysis a) -> m FKindLit
evalKp KindParam (Analysis a)
kp

-- TODO needs cleanup: internal repetition, common parts with evalKp. also needs
-- a docstring
evalRealKp :: MonadFEvalValue m => F.ExponentLetter -> Maybe (F.KindParam (FA.Analysis a)) -> m FKindLit
evalRealKp :: forall (m :: * -> *) a.
MonadFEvalValue m =>
ExponentLetter -> Maybe (KindParam (Analysis a)) -> m FKindLit
evalRealKp ExponentLetter
l = \case
  Maybe (KindParam (Analysis a))
Nothing ->
    case ExponentLetter
l of
      ExponentLetter
F.ExpLetterE -> FKindLit -> m FKindLit
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
4
      ExponentLetter
F.ExpLetterD -> FKindLit -> m FKindLit
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
8
      ExponentLetter
F.ExpLetterQ -> do
        String -> m ()
forall (m :: * -> *). MonadFEval m => String -> m ()
warn String
"TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"
        FKindLit -> m FKindLit
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
8
  Just KindParam (Analysis a)
kp -> do
    FKindLit
k <- KindParam (Analysis a) -> m FKindLit
forall (m :: * -> *) a.
MonadFEvalValue m =>
KindParam (Analysis a) -> m FKindLit
evalKp KindParam (Analysis a)
kp
    case ExponentLetter
l of
      ExponentLetter
F.ExpLetterE -> -- @1.2E3_8@ syntax is permitted: use @_8@ kind param
        FKindLit -> m FKindLit
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
k
      ExponentLetter
F.ExpLetterD -> do -- @1.2D3_8@ syntax is nonsensical
        String -> m ()
forall (m :: * -> *). MonadFEval m => String -> m ()
warn (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$  String
"TODO exponent letter wasn't E but you gave kind parameter."
             String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\nthis isn't allowed, but we'll default to"
             String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" using kind parameter"
        FKindLit -> m FKindLit
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
k
      ExponentLetter
F.ExpLetterQ -> do
        String -> m ()
forall (m :: * -> *). MonadFEval m => String -> m ()
warn String
"TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"
        FKindLit -> m FKindLit
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
8

evalUOp :: MonadFEvalValue m => F.UnaryOp -> FValue -> m FValue
evalUOp :: forall (m :: * -> *).
MonadFEvalValue m =>
UnaryOp -> FValue -> m FValue
evalUOp UnaryOp
op FValue
v = do
    FScalarValue
v' <- FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
    case UnaryOp
op of
      UnaryOp
F.Plus  -> Either Error FScalarValue -> m FValue
forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp (Either Error FScalarValue -> m FValue)
-> Either Error FScalarValue -> m FValue
forall a b. (a -> b) -> a -> b
$ (forall a. Num a => a -> a)
-> FScalarValue -> Either Error FScalarValue
Op.opIcNumericUOpInplace a -> a
forall a. a -> a
forall a. Num a => a -> a
id     FScalarValue
v'
      UnaryOp
F.Minus -> Either Error FScalarValue -> m FValue
forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp (Either Error FScalarValue -> m FValue)
-> Either Error FScalarValue -> m FValue
forall a b. (a -> b) -> a -> b
$ (forall a. Num a => a -> a)
-> FScalarValue -> Either Error FScalarValue
Op.opIcNumericUOpInplace a -> a
forall a. Num a => a -> a
negate FScalarValue
v'
      UnaryOp
F.Not   -> -- TODO move this to Op (but logicals are a pain)
        case FScalarValue
v' of
          FSVLogical FInt
bi ->
            FValue -> m FValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FValue -> m FValue) -> FValue -> m FValue
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue) -> FScalarValue -> FValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVLogical (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FInt
fLogicalNot FInt
bi
          FScalarValue
_ -> Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ Error -> Error
EOp (Error -> Error) -> Error -> Error
forall a b. (a -> b) -> a -> b
$ [String] -> FScalarType -> Error
Op.EBadArgType1 [String
"LOGICAL"] (FScalarType -> Error) -> FScalarType -> Error
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FScalarType
fScalarValueType FScalarValue
v'
      UnaryOp
_ -> Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EUnsupported (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$ String
"operator: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UnaryOp -> String
forall a. Show a => a -> String
show UnaryOp
op

wrapOp :: MonadFEvalValue m => Either Op.Error a -> m a
wrapOp :: forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp = \case
  Right a
a -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  Left  Error
e -> Error -> m a
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m a) -> Error -> m a
forall a b. (a -> b) -> a -> b
$ Error -> Error
EOp Error
e

-- | Wrap the output of an operation that returns a scalar value into the main
--   evaluator.
wrapSOp :: MonadFEvalValue m => Either Op.Error FScalarValue -> m FValue
wrapSOp :: forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp = \case
  Right FScalarValue
a -> FValue -> m FValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FValue -> m FValue) -> FValue -> m FValue
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue FScalarValue
a
  Left  Error
e -> Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ Error -> Error
EOp Error
e

-- | Evaluate explicit binary operators (ones denoted as such in the AST).
--
-- Note that this does not cover all binary operators -- there are many
-- intrinsics which use function syntax, but are otherwise binary operators.
evalBOp :: MonadFEvalValue m => F.BinaryOp -> FValue -> FValue -> m FValue
evalBOp :: forall (m :: * -> *).
MonadFEvalValue m =>
BinaryOp -> FValue -> FValue -> m FValue
evalBOp BinaryOp
bop FValue
l FValue
r = do
    -- TODO also see evalExpr: implement short-circuit eval here
    FScalarValue
l' <- FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
l
    FScalarValue
r' <- FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
r
    case BinaryOp
bop of
      BinaryOp
F.Addition       -> Either Error FScalarValue -> m FValue
forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp (Either Error FScalarValue -> m FValue)
-> Either Error FScalarValue -> m FValue
forall a b. (a -> b) -> a -> b
$ (forall a. (Num a, Ord a) => a -> a -> a)
-> FScalarValue -> FScalarValue -> Either Error FScalarValue
Op.opIcNumericBOp a -> a -> a
forall a. Num a => a -> a -> a
forall a. (Num a, Ord a) => a -> a -> a
(+) FScalarValue
l' FScalarValue
r'
      BinaryOp
F.Subtraction    -> Either Error FScalarValue -> m FValue
forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp (Either Error FScalarValue -> m FValue)
-> Either Error FScalarValue -> m FValue
forall a b. (a -> b) -> a -> b
$ (forall a. (Num a, Ord a) => a -> a -> a)
-> FScalarValue -> FScalarValue -> Either Error FScalarValue
Op.opIcNumericBOp (-) FScalarValue
l' FScalarValue
r'
      BinaryOp
F.Multiplication -> Either Error FScalarValue -> m FValue
forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp (Either Error FScalarValue -> m FValue)
-> Either Error FScalarValue -> m FValue
forall a b. (a -> b) -> a -> b
$ (forall a. (Num a, Ord a) => a -> a -> a)
-> FScalarValue -> FScalarValue -> Either Error FScalarValue
Op.opIcNumericBOp a -> a -> a
forall a. Num a => a -> a -> a
forall a. (Num a, Ord a) => a -> a -> a
(*) FScalarValue
l' FScalarValue
r'


      -- TODO confirm correct operation (not checked much)
      BinaryOp
F.Division -> Either Error FScalarValue -> m FValue
forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp (Either Error FScalarValue -> m FValue)
-> Either Error FScalarValue -> m FValue
forall a b. (a -> b) -> a -> b
$ (forall a. Integral a => a -> a -> a)
-> (forall a. RealFloat a => a -> a -> a)
-> FScalarValue
-> FScalarValue
-> Either Error FScalarValue
Op.opIcNumericBOpRealIntSep (a -> a -> a
forall a. Integral a => a -> a -> a
div) a -> a -> a
forall a. Fractional a => a -> a -> a
forall a. RealFloat a => a -> a -> a
(/) FScalarValue
l' FScalarValue
r'

      -- TODO basic - ints only. probably should support floats too.
      BinaryOp
F.Exponentiation ->
        case (FScalarValue
l', FScalarValue
r') of
          (FSVInt FInt
li, FSVInt FInt
ri) ->
            FValue -> m FValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FValue -> m FValue) -> FValue -> m FValue
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue) -> FScalarValue -> FValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FInt a => a -> a -> a) -> FInt -> FInt -> FInt
fIntBOpInplace a -> a -> a
forall a. FKindedC FInt a => a -> a -> a
forall a b. (Num a, Integral b) => a -> b -> a
(^) FInt
li FInt
ri
          (FSVReal FReal
lr, FSVReal FReal
ri) ->
            FValue -> m FValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FValue -> m FValue) -> FValue -> m FValue
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue) -> FScalarValue -> FValue
forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal (FReal -> FScalarValue) -> FReal -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (Float -> Float -> Float)
-> (Double -> Double -> Double) -> FReal -> FReal -> FReal
fRealBOpInplace' Float -> Float -> Float
forall a. Floating a => a -> a -> a
(**) Double -> Double -> Double
forall a. Floating a => a -> a -> a
(**) FReal
lr FReal
ri
          (FSVReal FReal
lr, FSVInt FInt
ri) ->
            -- Handle case of a real raised to an integer power.
            FValue -> m FValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FValue -> m FValue) -> FValue -> m FValue
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue) -> FScalarValue -> FValue
forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal (FReal -> FScalarValue) -> FReal -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (Float -> Float -> Float)
-> (Double -> Double -> Double) -> FReal -> FReal -> FReal
fRealBOpInplace' Float -> Float -> Float
forall a. Floating a => a -> a -> a
(**) Double -> Double -> Double
forall a. Floating a => a -> a -> a
(**) FReal
lr (Double -> FReal
FReal8 (Double -> FReal) -> Double -> FReal
forall a b. (a -> b) -> a -> b
$ FInt -> Double
forall a. Num a => FInt -> a
withFInt FInt
ri)

--          _ -> err $ ELazy "exponentiation: unsupported types"

      BinaryOp
F.Concatenation  ->
        case (FScalarValue
l', FScalarValue
r') of
          (FSVString Text
ls, FSVString Text
rs) ->
            FValue -> m FValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FValue -> m FValue) -> FValue -> m FValue
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue) -> FScalarValue -> FValue
forall a b. (a -> b) -> a -> b
$ Text -> FScalarValue
FSVString (Text -> FScalarValue) -> Text -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Text
ls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
rs
          (FScalarValue, FScalarValue)
_ -> Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
ELazy String
"concat strings only please"

      BinaryOp
F.GT  -> Bool -> FValue
defFLogical (Bool -> FValue) -> m Bool -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Bool -> m Bool
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp ((forall a. Ord a => a -> a -> Bool)
-> FScalarValue -> FScalarValue -> Either Error Bool
forall r.
(forall a. Ord a => a -> a -> r)
-> FScalarValue -> FScalarValue -> Either Error r
Op.opIcNumRelBOp a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>)  FScalarValue
l' FScalarValue
r')
      BinaryOp
F.GTE -> Bool -> FValue
defFLogical (Bool -> FValue) -> m Bool -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Bool -> m Bool
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp ((forall a. Ord a => a -> a -> Bool)
-> FScalarValue -> FScalarValue -> Either Error Bool
forall r.
(forall a. Ord a => a -> a -> r)
-> FScalarValue -> FScalarValue -> Either Error r
Op.opIcNumRelBOp a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(>=) FScalarValue
l' FScalarValue
r')
      BinaryOp
F.LT  -> Bool -> FValue
defFLogical (Bool -> FValue) -> m Bool -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Bool -> m Bool
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp ((forall a. Ord a => a -> a -> Bool)
-> FScalarValue -> FScalarValue -> Either Error Bool
forall r.
(forall a. Ord a => a -> a -> r)
-> FScalarValue -> FScalarValue -> Either Error r
Op.opIcNumRelBOp a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<) FScalarValue
l' FScalarValue
r')
      BinaryOp
F.LTE -> Bool -> FValue
defFLogical (Bool -> FValue) -> m Bool -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Bool -> m Bool
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp ((forall a. Ord a => a -> a -> Bool)
-> FScalarValue -> FScalarValue -> Either Error Bool
forall r.
(forall a. Ord a => a -> a -> r)
-> FScalarValue -> FScalarValue -> Either Error r
Op.opIcNumRelBOp a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(<=) FScalarValue
l' FScalarValue
r')
      BinaryOp
F.NE  -> Bool -> FValue
defFLogical (Bool -> FValue) -> m Bool -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Bool -> m Bool
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp ((forall a. Ord a => a -> a -> Bool)
-> FScalarValue -> FScalarValue -> Either Error Bool
forall r.
(forall a. Ord a => a -> a -> r)
-> FScalarValue -> FScalarValue -> Either Error r
Op.opIcNumRelBOp a -> a -> Bool
forall a. Eq a => a -> a -> Bool
forall a. Ord a => a -> a -> Bool
(/=) FScalarValue
l' FScalarValue
r')
      BinaryOp
F.EQ  -> Bool -> FValue
defFLogical (Bool -> FValue) -> m Bool -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Bool -> m Bool
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp (FScalarValue -> FScalarValue -> Either Error Bool
Op.opEq FScalarValue
l' FScalarValue
r')

      BinaryOp
F.And -> Bool -> FValue
defFLogical (Bool -> FValue) -> m Bool -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Bool -> m Bool
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp ((Bool -> Bool -> Bool)
-> FScalarValue -> FScalarValue -> Either Error Bool
forall r.
(Bool -> Bool -> r)
-> FScalarValue -> FScalarValue -> Either Error r
Op.opIcLogicalBOp Bool -> Bool -> Bool
(&&) FScalarValue
l' FScalarValue
r')
      BinaryOp
F.Or  -> Bool -> FValue
defFLogical (Bool -> FValue) -> m Bool -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Bool -> m Bool
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp ((Bool -> Bool -> Bool)
-> FScalarValue -> FScalarValue -> Either Error Bool
forall r.
(Bool -> Bool -> r)
-> FScalarValue -> FScalarValue -> Either Error r
Op.opIcLogicalBOp Bool -> Bool -> Bool
(||) FScalarValue
l' FScalarValue
r')
      BinaryOp
F.XOr -> Bool -> FValue
defFLogical (Bool -> FValue) -> m Bool -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Bool -> m Bool
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp ((Bool -> Bool -> Bool)
-> FScalarValue -> FScalarValue -> Either Error Bool
forall r.
(Bool -> Bool -> r)
-> FScalarValue -> FScalarValue -> Either Error r
Op.opIcLogicalBOp Bool -> Bool -> Bool
boolXor FScalarValue
l' FScalarValue
r')
      BinaryOp
F.Equivalent -> Bool -> FValue
defFLogical (Bool -> FValue) -> m Bool -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Bool -> m Bool
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp ((Bool -> Bool -> Bool)
-> FScalarValue -> FScalarValue -> Either Error Bool
forall r.
(Bool -> Bool -> r)
-> FScalarValue -> FScalarValue -> Either Error r
Op.opIcLogicalBOp Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(==) FScalarValue
l' FScalarValue
r')
      BinaryOp
F.NotEquivalent -> Bool -> FValue
defFLogical (Bool -> FValue) -> m Bool -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Error Bool -> m Bool
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp ((Bool -> Bool -> Bool)
-> FScalarValue -> FScalarValue -> Either Error Bool
forall r.
(Bool -> Bool -> r)
-> FScalarValue -> FScalarValue -> Either Error r
Op.opIcLogicalBOp Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
(/=) FScalarValue
l' FScalarValue
r')

      F.BinCustom{} -> -- TODO
        Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EUnsupported String
"custom binary operators"

boolXor :: Bool -> Bool -> Bool
boolXor :: Bool -> Bool -> Bool
boolXor Bool
True  Bool
False = Bool
True
boolXor Bool
False Bool
True  = Bool
True
boolXor Bool
_     Bool
_     = Bool
False

defFLogical :: Bool -> FValue
defFLogical :: Bool -> FValue
defFLogical =
    FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue)
-> (Bool -> FScalarValue) -> Bool -> FValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FInt -> FScalarValue
FSVLogical (FInt -> FScalarValue) -> (Bool -> FInt) -> Bool -> FScalarValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> FInt
FInt4 (Int32 -> FInt) -> (Bool -> Int32) -> Bool -> FInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int32
forall a. Num a => Bool -> a
fLogicalNumericFromBool

evalFunctionCall :: MonadFEvalValue m => F.Name -> [FValue] -> m FValue
evalFunctionCall :: forall (m :: * -> *).
MonadFEvalValue m =>
String -> [FValue] -> m FValue
evalFunctionCall String
fname [FValue]
args =
    case String
fname of

      String
"kind"  -> do
        [FValue]
args' <- Int -> [FValue] -> m [FValue]
forall (m :: * -> *) a. MonadFEvalValue m => Int -> [a] -> m [a]
forceArgs Int
1 [FValue]
args
        let [FValue
v] = [FValue]
args'
        FScalarValue
v' <- FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
        let t :: FScalarType
t = FScalarValue -> FScalarType
fScalarValueType FScalarValue
v'
        case FScalarType -> Maybe FKindLit
fScalarTypeKind FScalarType
t of
          Maybe FKindLit
Nothing -> Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
ELazy String
"called kind with non-kinded scalar"
          Just FKindLit
k  -> FValue -> m FValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FValue -> m FValue) -> FValue -> m FValue
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue) -> FScalarValue -> FValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Int32 -> FInt
FInt4 (FKindLit -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral FKindLit
k)

      String
"ior"  -> do
        [FValue]
args' <- Int -> [FValue] -> m [FValue]
forall (m :: * -> *) a. MonadFEvalValue m => Int -> [a] -> m [a]
forceArgs Int
2 [FValue]
args
        let [FValue
l, FValue
r] = [FValue]
args'
        FScalarValue
l' <- FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
l
        FScalarValue
r' <- FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
r
        FScalarValue -> FScalarValue -> m FValue
forall (m :: * -> *).
MonadFEvalValue m =>
FScalarValue -> FScalarValue -> m FValue
evalIntrinsicIor FScalarValue
l' FScalarValue
r'

      String
"max"  -> [FValue] -> m FValue
forall (m :: * -> *). MonadFEvalValue m => [FValue] -> m FValue
evalIntrinsicMax [FValue]
args

      String
"char" -> do
        [FValue]
args' <- Int -> [FValue] -> m [FValue]
forall (m :: * -> *) a. MonadFEvalValue m => Int -> [a] -> m [a]
forceArgs Int
1 [FValue]
args
        let [FValue
v] = [FValue]
args'
        FScalarValue
v' <- FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
        case FScalarValue
v' of
          FSVInt FInt
i -> do
            -- TODO better error handling
            let c :: Char
c    = Int -> Char
Data.Char.chr ((forall a. FKindedC FInt a => a -> Int) -> FInt -> Int
forall r. (forall a. FKindedC FInt a => a -> r) -> FInt -> r
fIntUOp a -> Int
forall a. FKindedC FInt a => a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral FInt
i)
            FValue -> m FValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FValue -> m FValue) -> FValue -> m FValue
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue) -> FScalarValue -> FValue
forall a b. (a -> b) -> a -> b
$ Text -> FScalarValue
FSVString (Text -> FScalarValue) -> Text -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Char -> Text
Text.singleton Char
c
          FScalarValue
_ ->
            Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
                String
"char: expected INT(x), got "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>FScalarType -> String
forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
v')

      String
"not"  -> do
        [FValue]
args' <- Int -> [FValue] -> m [FValue]
forall (m :: * -> *) a. MonadFEvalValue m => Int -> [a] -> m [a]
forceArgs Int
1 [FValue]
args
        let [FValue
v] = [FValue]
args'
        FScalarValue
v' <- FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
        case FScalarValue
v' of
          FSVInt FInt
i -> do
            FValue -> m FValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FValue -> m FValue) -> FValue -> m FValue
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue) -> FScalarValue -> FValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FInt a => a -> a) -> FInt -> FInt
fIntUOpInplace a -> a
forall a. Bits a => a -> a
forall a. FKindedC FInt a => a -> a
Data.Bits.complement FInt
i
          FScalarValue
_ ->
            Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
                String
"not: expected INT(x), got "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>FScalarType -> String
forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
v')

      String
"int"  ->
        case [FValue]
args of
          [] -> Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$ String
"int: expected 1 or 2 arguments, got 0"
          [FValue
v] -> do
            -- @INT(x)@ == @INT(x, 4)@ (F2018 16.9.100:23, pg.381)
            (FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue)
-> (Int32 -> FScalarValue) -> Int32 -> FValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FInt -> FScalarValue
FSVInt (FInt -> FScalarValue) -> (Int32 -> FInt) -> Int32 -> FScalarValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> FInt
FInt4) (Int32 -> FValue) -> m Int32 -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FValue -> m Int32
forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int32
evalIntrinsicInt4 FValue
v
          [FValue
v, FValue
vk] -> do
            FScalarValue
vk' <- FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
vk
            case FScalarValue
vk' of
              FSVInt FInt
vkI -> (FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue)
-> (FInt -> FScalarValue) -> FInt -> FValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FInt -> FScalarValue
FSVInt) (FInt -> FValue) -> m FInt -> m FValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FValue -> FInt -> m FInt
forall (m :: * -> *). MonadFEvalValue m => FValue -> FInt -> m FInt
evalIntrinsicInt FValue
v FInt
vkI
              FScalarValue
_ ->
                Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
                    String
"int: kind argument must be INTEGER, got "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>FScalarType -> String
forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
vk')
          [FValue]
_ -> Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$ String
"int: expected 1 or 2 arguments, got >2"

      -- TODO all lies
      String
"int2" -> do
        [FValue]
args' <- Int -> [FValue] -> m [FValue]
forall (m :: * -> *) a. MonadFEvalValue m => Int -> [a] -> m [a]
forceArgs Int
1 [FValue]
args
        let [FValue
v] = [FValue]
args'
        FScalarValue
v' <- FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
        case FScalarValue
v' of
          FSVInt{} ->
            FValue -> m FValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FValue -> m FValue) -> FValue -> m FValue
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue FScalarValue
v'
          FSVReal FReal
r ->
            FValue -> m FValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FValue -> m FValue) -> FValue -> m FValue
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue (FScalarValue -> FValue) -> FScalarValue -> FValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ Int16 -> FInt
FInt2 (Int16 -> FInt) -> Int16 -> FInt
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> Int16) -> FReal -> Int16
forall r. (forall a. FKindedC FReal a => a -> r) -> FReal -> r
fRealUOp a -> Int16
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
forall a. FKindedC FReal a => a -> Int16
truncate FReal
r
          FScalarValue
_ ->
            Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
                String
"int: unsupported or unimplemented type: "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>FScalarType -> String
forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
v')

      String
_      -> Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EUnsupported (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$ String
"function call: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
fname

-- TODO 2023-05-03 raehik: gfortran actually performs some range checks for
-- constants! @int(128, 1)@ errors with "this INT(4) is too big for INT(1)".
-- we don't do that currently. just means more plumbing
evalIntrinsicInt :: MonadFEvalValue m => FValue -> FInt -> m FInt
evalIntrinsicInt :: forall (m :: * -> *). MonadFEvalValue m => FValue -> FInt -> m FInt
evalIntrinsicInt FValue
v = (forall a. FKindedC FInt a => a -> m FInt) -> FInt -> m FInt
forall r. (forall a. FKindedC FInt a => a -> r) -> FInt -> r
fIntUOp a -> m FInt
forall a. FKindedC FInt a => a -> m FInt
forall (m :: * -> *) a.
(MonadFEvalValue m, Num a, Eq a) =>
a -> m FInt
go
  where
    go :: (MonadFEvalValue m, Num a, Eq a) => a -> m FInt
    go :: forall (m :: * -> *) a.
(MonadFEvalValue m, Num a, Eq a) =>
a -> m FInt
go = \case
      a
1 -> Int8 -> FInt
FInt1 (Int8 -> FInt) -> m Int8 -> m FInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FValue -> m Int8
forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int8
evalIntrinsicInt1 FValue
v
      a
2 -> Int16 -> FInt
FInt2 (Int16 -> FInt) -> m Int16 -> m FInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FValue -> m Int16
forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int16
evalIntrinsicInt2 FValue
v
      a
4 -> Int32 -> FInt
FInt4 (Int32 -> FInt) -> m Int32 -> m FInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FValue -> m Int32
forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int32
evalIntrinsicInt4 FValue
v
      a
8 -> Int64 -> FInt
FInt8 (Int64 -> FInt) -> m Int64 -> m FInt
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FValue -> m Int64
forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int64
evalIntrinsicInt8 FValue
v
      a
_ -> Error -> m FInt
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FInt) -> Error -> m FInt
forall a b. (a -> b) -> a -> b
$ String -> Error
ELazy String
"int: kind argument wasn't 1, 2, 4 or 8"

-- | @INT(a, 1)@
evalIntrinsicInt1 :: MonadFEvalValue m => FValue -> m Int8
evalIntrinsicInt1 :: forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int8
evalIntrinsicInt1 = (FInt -> Int8) -> FValue -> m Int8
forall r (m :: * -> *).
(MonadFEvalValue m, Integral r) =>
(FInt -> r) -> FValue -> m r
evalIntrinsicIntXCoerce FInt -> Int8
coerceToI1
  where coerceToI1 :: FInt -> Int8
coerceToI1 = (Int8 -> Int8)
-> (Int16 -> Int8)
-> (Int32 -> Int8)
-> (Int64 -> Int8)
-> FInt
-> Int8
forall r.
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt -> r
fIntUOp' Int8 -> Int8
forall a. a -> a
id Int16 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | @INT(a, 2)@
evalIntrinsicInt2 :: MonadFEvalValue m => FValue -> m Int16
evalIntrinsicInt2 :: forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int16
evalIntrinsicInt2 = (FInt -> Int16) -> FValue -> m Int16
forall r (m :: * -> *).
(MonadFEvalValue m, Integral r) =>
(FInt -> r) -> FValue -> m r
evalIntrinsicIntXCoerce FInt -> Int16
coerceToI2
  where coerceToI2 :: FInt -> Int16
coerceToI2 = (Int8 -> Int16)
-> (Int16 -> Int16)
-> (Int32 -> Int16)
-> (Int64 -> Int16)
-> FInt
-> Int16
forall r.
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt -> r
fIntUOp' Int8 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16 -> Int16
forall a. a -> a
id Int32 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | @INT(a, 4)@, @INT(a)@
evalIntrinsicInt4 :: MonadFEvalValue m => FValue -> m Int32
evalIntrinsicInt4 :: forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int32
evalIntrinsicInt4 = (FInt -> Int32) -> FValue -> m Int32
forall r (m :: * -> *).
(MonadFEvalValue m, Integral r) =>
(FInt -> r) -> FValue -> m r
evalIntrinsicIntXCoerce FInt -> Int32
coerceToI4
  where coerceToI4 :: FInt -> Int32
coerceToI4 = (Int8 -> Int32)
-> (Int16 -> Int32)
-> (Int32 -> Int32)
-> (Int64 -> Int32)
-> FInt
-> Int32
forall r.
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt -> r
fIntUOp' Int8 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32 -> Int32
forall a. a -> a
id Int64 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | @INT(a, 8)@
evalIntrinsicInt8 :: MonadFEvalValue m => FValue -> m Int64
evalIntrinsicInt8 :: forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int64
evalIntrinsicInt8 = (FInt -> Int64) -> FValue -> m Int64
forall r (m :: * -> *).
(MonadFEvalValue m, Integral r) =>
(FInt -> r) -> FValue -> m r
evalIntrinsicIntXCoerce FInt -> Int64
coerceToI8
  where coerceToI8 :: FInt -> Int64
coerceToI8 = (Int8 -> Int64)
-> (Int16 -> Int64)
-> (Int32 -> Int64)
-> (Int64 -> Int64)
-> FInt
-> Int64
forall r.
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt -> r
fIntUOp' Int8 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64 -> Int64
forall a. a -> a
id

evalIntrinsicIntXCoerce
    :: forall r m
    .  (MonadFEvalValue m, Integral r) => (FInt -> r) -> FValue -> m r
evalIntrinsicIntXCoerce :: forall r (m :: * -> *).
(MonadFEvalValue m, Integral r) =>
(FInt -> r) -> FValue -> m r
evalIntrinsicIntXCoerce FInt -> r
coerceToIX FValue
v = do
    FScalarValue
v' <- FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
    case FScalarValue
v' of
      FSVInt  FInt
i -> r -> m r
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r -> m r) -> r -> m r
forall a b. (a -> b) -> a -> b
$ FInt -> r
coerceToIX FInt
i
      FSVReal FReal
r -> r -> m r
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (r -> m r) -> r -> m r
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> r) -> FReal -> r
forall r. (forall a. FKindedC FReal a => a -> r) -> FReal -> r
fRealUOp a -> r
forall b. Integral b => a -> b
forall a b. (RealFrac a, Integral b) => a -> b
forall a. FKindedC FReal a => a -> r
truncate FReal
r
      FScalarValue
_ ->
        Error -> m r
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m r) -> Error -> m r
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
            String
"int: unsupported or unimplemented type: "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>FScalarType -> String
forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
v')

evalArg :: MonadFEvalValue m => F.Argument (FA.Analysis a) -> m FValue
evalArg :: forall (m :: * -> *) a.
MonadFEvalValue m =>
Argument (Analysis a) -> m FValue
evalArg (F.Argument Analysis a
_ SrcSpan
_ Maybe String
_ ArgumentExpression (Analysis a)
ae) =
    case ArgumentExpression (Analysis a)
ae of
      F.ArgExpr        Expression (Analysis a)
e -> Expression (Analysis a) -> m FValue
forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression (Analysis a) -> m FValue
evalExpr Expression (Analysis a)
e
      F.ArgExprVar Analysis a
_ SrcSpan
_ String
v -> String -> m FValue
forall (m :: * -> *). MonadFEvalValue m => String -> m FValue
evalVar  String
v

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

-- exists because we used to support arrays (now stripped)
forceScalar :: MonadFEvalValue m => FValue -> m FScalarValue
forceScalar :: forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar = \case
  MkFScalarValue FScalarValue
v' -> FScalarValue -> m FScalarValue
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FScalarValue
v'

forceUnconsArg :: MonadFEvalValue m => [a] -> m (a, [a])
forceUnconsArg :: forall (m :: * -> *) a. MonadFEvalValue m => [a] -> m (a, [a])
forceUnconsArg = \case
  []   -> Error -> m (a, [a])
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m (a, [a])) -> Error -> m (a, [a])
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError String
"not enough arguments"
  a
a:[a]
as -> (a, [a]) -> m (a, [a])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
a, [a]
as)

-- TODO can I use vector-sized to improve safety here? lol
-- it's just convenience either way
forceArgs :: MonadFEvalValue m => Int -> [a] -> m [a]
forceArgs :: forall (m :: * -> *) a. MonadFEvalValue m => Int -> [a] -> m [a]
forceArgs Int
numArgs [a]
l =
    if   [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
numArgs
    then [a] -> m [a]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
l
    else Error -> m [a]
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m [a]) -> Error -> m [a]
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
            String
"expected "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>Int -> String
forall a. Show a => a -> String
show Int
numArgsString -> ShowS
forall a. Semigroup a => a -> a -> a
<>String
" arguments; got "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>Int -> String
forall a. Show a => a -> String
show ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l)

evalIntrinsicIor
    :: MonadFEvalValue m => FScalarValue -> FScalarValue -> m FValue
evalIntrinsicIor :: forall (m :: * -> *).
MonadFEvalValue m =>
FScalarValue -> FScalarValue -> m FValue
evalIntrinsicIor FScalarValue
l FScalarValue
r = case (FScalarValue
l, FScalarValue
r) of
  (FSVInt FInt
li, FSVInt FInt
ri) -> Either Error FScalarValue -> m FValue
forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp (Either Error FScalarValue -> m FValue)
-> Either Error FScalarValue -> m FValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt (FInt -> FScalarValue)
-> Either Error FInt -> Either Error FScalarValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FInt -> FInt -> Either Error FInt
Op.opIor FInt
li FInt
ri
  (FScalarValue, FScalarValue)
_ -> Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
ELazy String
"ior: bad args"

-- https://gcc.gnu.org/onlinedocs/gfortran/MAX.html
-- TODO should support arrays! at least for >=F2010
evalIntrinsicMax
    :: MonadFEvalValue m => [FValue] -> m FValue
evalIntrinsicMax :: forall (m :: * -> *). MonadFEvalValue m => [FValue] -> m FValue
evalIntrinsicMax = \case
  []   -> Error -> m FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> m FValue) -> Error -> m FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError String
"max intrinsic expects at least 1 argument"
  FValue
v:[FValue]
vs -> do
    FScalarValue
v' <- FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
    [FScalarValue]
vs' <- (FValue -> m FScalarValue) -> [FValue] -> m [FScalarValue]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse FValue -> m FScalarValue
forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar [FValue]
vs
    FScalarValue -> [FScalarValue] -> m FValue
forall {f :: * -> *}.
(EvalTo f ~ FValue, MonadFEval f, MonadError Error f) =>
FScalarValue -> [FScalarValue] -> f FValue
go FScalarValue
v' [FScalarValue]
vs'
  where
    go :: FScalarValue -> [FScalarValue] -> f FValue
go FScalarValue
vCurMax [] = FValue -> f FValue
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FValue -> f FValue) -> FValue -> f FValue
forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue FScalarValue
vCurMax
    go FScalarValue
vCurMax (FScalarValue
v:[FScalarValue]
vs) =
        case FScalarValue
vCurMax of
          FSVInt{} ->
            case FScalarValue
v of
              FSVInt{} -> do
                FScalarValue
vNewMax <- Either Error FScalarValue -> f FScalarValue
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp (Either Error FScalarValue -> f FScalarValue)
-> Either Error FScalarValue -> f FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. (Num a, Ord a) => a -> a -> a)
-> FScalarValue -> FScalarValue -> Either Error FScalarValue
Op.opIcNumericBOp a -> a -> a
forall a. (Num a, Ord a) => a -> a -> a
forall a. Ord a => a -> a -> a
max FScalarValue
vCurMax FScalarValue
v
                FScalarValue -> [FScalarValue] -> f FValue
go FScalarValue
vNewMax [FScalarValue]
vs
              FScalarValue
_ ->
                Error -> f FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> f FValue) -> Error -> f FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
                    String
"max: expected INT(x), got "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>FScalarType -> String
forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
v)
          FSVReal{} ->
            case FScalarValue
v of
              FSVReal{} -> do
                FScalarValue
vNewMax <- Either Error FScalarValue -> f FScalarValue
forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp (Either Error FScalarValue -> f FScalarValue)
-> Either Error FScalarValue -> f FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. (Num a, Ord a) => a -> a -> a)
-> FScalarValue -> FScalarValue -> Either Error FScalarValue
Op.opIcNumericBOp a -> a -> a
forall a. (Num a, Ord a) => a -> a -> a
forall a. Ord a => a -> a -> a
max FScalarValue
vCurMax FScalarValue
v
                FScalarValue -> [FScalarValue] -> f FValue
go FScalarValue
vNewMax [FScalarValue]
vs
              FScalarValue
_ ->
                Error -> f FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> f FValue) -> Error -> f FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
                    String
"max: expected REAL(x), got "String -> ShowS
forall a. Semigroup a => a -> a -> a
<>FScalarType -> String
forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
v)
          FScalarValue
_ ->
            Error -> f FValue
forall (m :: * -> *) a. MonadError Error m => Error -> m a
err (Error -> f FValue) -> Error -> f FValue
forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError (String -> Error) -> String -> Error
forall a b. (a -> b) -> a -> b
$
                String
"max: unsupported type: "String -> ShowS
forall a. Semigroup a => a -> a -> a
<> FScalarType -> String
forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
vCurMax)

-- | Evaluate a constant expression (F2018 10.1.12).
evalConstExpr :: MonadFEvalValue m => F.Expression (FA.Analysis a) -> m FValue
evalConstExpr :: forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression (Analysis a) -> m FValue
evalConstExpr = Expression (Analysis a) -> m FValue
forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression (Analysis a) -> m FValue
evalExpr