{-# 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 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. 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
$cto :: forall x. Rep Error x -> Error
$cfrom :: forall x. Error -> Rep Error x
Generic, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
Show, Error -> Error -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: 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 -> 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
<$ :: forall a b. a -> FEvalValuePure b -> FEvalValuePure a
$c<$ :: forall a b. a -> FEvalValuePure b -> FEvalValuePure a
fmap :: forall a b. (a -> b) -> FEvalValuePure a -> FEvalValuePure b
$cfmap :: forall a b. (a -> b) -> FEvalValuePure a -> FEvalValuePure b
Functor, Functor 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
<* :: forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure a
$c<* :: forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure a
*> :: forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure b
$c*> :: forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure b
liftA2 :: forall a b c.
(a -> b -> c)
-> FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure c
<*> :: forall a b.
FEvalValuePure (a -> b) -> FEvalValuePure a -> FEvalValuePure b
$c<*> :: forall a b.
FEvalValuePure (a -> b) -> FEvalValuePure a -> FEvalValuePure b
pure :: forall a. a -> FEvalValuePure a
$cpure :: forall a. a -> FEvalValuePure a
Applicative, Applicative 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
return :: forall a. a -> FEvalValuePure a
$creturn :: forall a. a -> FEvalValuePure a
>> :: forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure b
$c>> :: forall a b.
FEvalValuePure a -> FEvalValuePure b -> FEvalValuePure b
>>= :: forall a b.
FEvalValuePure a -> (a -> FEvalValuePure b) -> FEvalValuePure b
$c>>= :: forall a b.
FEvalValuePure a -> (a -> FEvalValuePure b) -> FEvalValuePure b
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 = 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 <- forall r (m :: * -> *). MonadReader r m => m r
ask
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 =
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r a. Reader r a -> r -> a
runReader Map String FValue
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
    forall (m :: * -> *).
MonadFEval m =>
String -> m (Maybe (EvalTo m))
lookupFVar String
name forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe FValue
Nothing  -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
ENoSuchVar String
name
      Just FValue
val -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FValue
val

evalExpr :: MonadFEvalValue m => F.Expression a -> m FValue
evalExpr :: forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression a -> m FValue
evalExpr = \case
  F.ExpValue a
_ SrcSpan
_ Value a
astVal ->
    case Value a
astVal of
      F.ValVariable String
name -> forall (m :: * -> *). MonadFEvalValue m => String -> m FValue
evalVar String
name
      -- TODO: Do same with ValIntrinsic??? idk...
      Value a
_ -> FScalarValue -> FValue
MkFScalarValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
MonadFEvalValue m =>
Value a -> m FScalarValue
evalLit Value a
astVal
  F.ExpUnary  a
_ SrcSpan
_ UnaryOp
uop Expression a
e   -> do
    FValue
v <- forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression a -> m FValue
evalExpr Expression a
e
    forall (m :: * -> *).
MonadFEvalValue m =>
UnaryOp -> FValue -> m FValue
evalUOp UnaryOp
uop FValue
v
  F.ExpBinary a
_ SrcSpan
_ BinaryOp
bop Expression a
le Expression 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 <- forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression a -> m FValue
evalExpr Expression a
le
    FValue
rv <- forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression a -> m FValue
evalExpr Expression a
re
    forall (m :: * -> *).
MonadFEvalValue m =>
BinaryOp -> FValue -> FValue -> m FValue
evalBOp BinaryOp
bop FValue
lv FValue
rv
  F.ExpFunctionCall a
_ SrcSpan
_ Expression a
ve AList Argument a
args -> do
    -- same here, could more arg evaluation into op
    [FValue]
evaledArgs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) a. MonadFEvalValue m => Argument a -> m FValue
evalArg forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. AList t a -> [t a]
F.alistList AList Argument a
args
    forall (m :: * -> *).
MonadFEvalValue m =>
String -> [FValue] -> m FValue
evalFunctionCall (forall a. Expression a -> String
forceVarExpr Expression a
ve) [FValue]
evaledArgs
  Expression a
_ -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EUnsupported String
"Expression constructor"

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

evalLit :: MonadFEvalValue m => F.Value a -> m FScalarValue
evalLit :: forall (m :: * -> *) a.
MonadFEvalValue m =>
Value a -> m FScalarValue
evalLit = \case
  F.ValInteger String
i Maybe (KindParam a)
mkp -> do
    forall (m :: * -> *) a.
MonadFEvalValue m =>
FKindLit -> Maybe (KindParam a) -> m FKindLit
evalMKp FKindLit
4 Maybe (KindParam a)
mkp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      FKindLit
4 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ Int32 -> FInt
FInt4 forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> a
read String
i
      FKindLit
8 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ Int64 -> FInt
FInt8 forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> a
read String
i
      FKindLit
2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ Int16 -> FInt
FInt2 forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> a
read String
i
      FKindLit
1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ Int8 -> FInt
FInt1 forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> a
read String
i
      FKindLit
k -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> FKindLit -> Error
ENoSuchKindForType String
"INTEGER" FKindLit
k
  F.ValReal RealLit
r Maybe (KindParam a)
mkp -> do
    forall (m :: * -> *) a.
MonadFEvalValue m =>
ExponentLetter -> Maybe (KindParam a) -> m FKindLit
evalRealKp (Exponent -> ExponentLetter
F.exponentLetter (RealLit -> Exponent
F.realLitExponent RealLit
r)) Maybe (KindParam a)
mkp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      FKindLit
4 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ Float -> FReal
FReal4 forall a b. (a -> b) -> a -> b
$ forall a. (Fractional a, Read a) => RealLit -> a
F.readRealLit RealLit
r
      FKindLit
8 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ Double -> FReal
FReal8 forall a b. (a -> b) -> a -> b
$ forall a. (Fractional a, Read a) => RealLit -> a
F.readRealLit RealLit
r
      FKindLit
k -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> FKindLit -> Error
ENoSuchKindForType String
"REAL" FKindLit
k
  F.ValLogical Bool
b Maybe (KindParam a)
mkp -> do
    forall (m :: * -> *) a.
MonadFEvalValue m =>
FKindLit -> Maybe (KindParam a) -> m FKindLit
evalMKp FKindLit
4 Maybe (KindParam a)
mkp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      FKindLit
4 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVLogical forall a b. (a -> b) -> a -> b
$ Int32 -> FInt
FInt4 forall a b. (a -> b) -> a -> b
$ forall a. Num a => Bool -> a
fLogicalNumericFromBool Bool
b
      FKindLit
8 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVLogical forall a b. (a -> b) -> a -> b
$ Int64 -> FInt
FInt8 forall a b. (a -> b) -> a -> b
$ forall a. Num a => Bool -> a
fLogicalNumericFromBool Bool
b
      FKindLit
2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVLogical forall a b. (a -> b) -> a -> b
$ Int16 -> FInt
FInt2 forall a b. (a -> b) -> a -> b
$ forall a. Num a => Bool -> a
fLogicalNumericFromBool Bool
b
      FKindLit
1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVLogical forall a b. (a -> b) -> a -> b
$ Int8 -> FInt
FInt1 forall a b. (a -> b) -> a -> b
$ forall a. Num a => Bool -> a
fLogicalNumericFromBool Bool
b
      FKindLit
k -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> FKindLit -> Error
ENoSuchKindForType String
"LOGICAL" FKindLit
k
  F.ValComplex (F.ComplexLit a
_ SrcSpan
_ ComplexPart a
_cr ComplexPart 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
    forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EUnsupported String
"COMPLEX literals"
  F.ValString String
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> FScalarValue
FSVString forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
s
  F.ValBoz Boz
boz -> do
    forall (m :: * -> *). MonadFEval m => String -> m ()
warn String
"requested to evaluate BOZ literal with no context: defaulting to INTEGER(4)"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ Int32 -> FInt
FInt4 forall a b. (a -> b) -> a -> b
$ forall a. (Num a, Eq a, FiniteBits a) => Boz -> a
F.bozAsTwosComp Boz
boz
  F.ValHollerith String
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> FScalarValue
FSVString forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
s
  F.ValIntrinsic{} -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
ESpecial String
"lit was ValIntrinsic{} (intrinsic name)"
  F.ValVariable{}  -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
ESpecial String
"lit was ValVariable{} (variable name)"
  F.ValOperator{}  -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
ESpecial String
"lit was ValOperator{} (custom operator name)"
  Value a
F.ValAssignment  -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
ESpecial String
"lit was ValAssignment (overloaded assignment name)"
  Value a
F.ValStar        -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
ESpecial String
"lit was ValStar"
  Value a
F.ValColon       -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
ESpecial String
"lit was ValColon"
  F.ValType{}      -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err 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 = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError

evalKp :: MonadFEvalValue m => F.KindParam a -> m FKindLit
evalKp :: forall (m :: * -> *) a.
MonadFEvalValue m =>
KindParam a -> m FKindLit
evalKp = \case
  F.KindParamInt 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)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> a
read String
k
  F.KindParamVar a
_ SrcSpan
_ String
var ->
    forall (m :: * -> *).
MonadFEval m =>
String -> m (Maybe (EvalTo m))
lookupFVar String
var 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) ->
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. (forall a. FKindedC FInt a => a -> r) -> FInt -> r
fIntUOp forall a b. (Integral a, Num b) => a -> b
fromIntegral FInt
i
        FValue
_ -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> FType -> Error
EKindLitBadType String
var (FValue -> FType
fValueType FValue
val)
      Maybe FValue
Nothing  -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
ENoSuchVar String
var

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

-- TODO needs cleanup: internal repetition, common parts with evalKp. also needs
-- a docstring
evalRealKp :: MonadFEvalValue m => F.ExponentLetter -> Maybe (F.KindParam a) -> m FKindLit
evalRealKp :: forall (m :: * -> *) a.
MonadFEvalValue m =>
ExponentLetter -> Maybe (KindParam a) -> m FKindLit
evalRealKp ExponentLetter
l = \case
  Maybe (KindParam a)
Nothing ->
    case ExponentLetter
l of
      ExponentLetter
F.ExpLetterE -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
4
      ExponentLetter
F.ExpLetterD -> forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
8
      ExponentLetter
F.ExpLetterQ -> do
        forall (m :: * -> *). MonadFEval m => String -> m ()
warn String
"TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"
        forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
8
  Just KindParam a
kp -> do
    FKindLit
k <- forall (m :: * -> *) a.
MonadFEvalValue m =>
KindParam a -> m FKindLit
evalKp KindParam a
kp
    case ExponentLetter
l of
      ExponentLetter
F.ExpLetterE -> -- @1.2E3_8@ syntax is permitted: use @_8@ kind param
        forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
k
      ExponentLetter
F.ExpLetterD -> do -- @1.2D3_8@ syntax is nonsensical
        forall (m :: * -> *). MonadFEval m => String -> m ()
warn forall a b. (a -> b) -> a -> b
$  String
"TODO exponent letter wasn't E but you gave kind parameter."
             forall a. Semigroup a => a -> a -> a
<> String
"\nthis isn't allowed, but we'll default to"
             forall a. Semigroup a => a -> a -> a
<> String
" using kind parameter"
        forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
k
      ExponentLetter
F.ExpLetterQ -> do
        forall (m :: * -> *). MonadFEval m => String -> m ()
warn String
"TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"
        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' <- forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
    case UnaryOp
op of
      UnaryOp
F.Plus  -> forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp forall a b. (a -> b) -> a -> b
$ (forall a. Num a => a -> a)
-> FScalarValue -> Either Error FScalarValue
Op.opIcNumericUOpInplace forall a. a -> a
id     FScalarValue
v'
      UnaryOp
F.Minus -> forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp forall a b. (a -> b) -> a -> b
$ (forall a. Num a => a -> a)
-> FScalarValue -> Either Error FScalarValue
Op.opIcNumericUOpInplace 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 ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVLogical forall a b. (a -> b) -> a -> b
$ FInt -> FInt
fLogicalNot FInt
bi
          FScalarValue
_ -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ Error -> Error
EOp forall a b. (a -> b) -> a -> b
$ [String] -> FScalarType -> Error
Op.EBadArgType1 [String
"LOGICAL"] forall a b. (a -> b) -> a -> b
$ FScalarValue -> FScalarType
fScalarValueType FScalarValue
v'
      UnaryOp
_ -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EUnsupported forall a b. (a -> b) -> a -> b
$ String
"operator: " forall a. Semigroup a => a -> a -> a
<> 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  Left  Error
e -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue FScalarValue
a
  Left  Error
e -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err 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' <- forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
l
    FScalarValue
r' <- forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
r
    case BinaryOp
bop of
      BinaryOp
F.Addition       -> forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp forall a b. (a -> b) -> a -> b
$ (forall a. (Num a, Ord a) => a -> a -> a)
-> FScalarValue -> FScalarValue -> Either Error FScalarValue
Op.opIcNumericBOp forall a. Num a => a -> a -> a
(+) FScalarValue
l' FScalarValue
r'
      BinaryOp
F.Subtraction    -> forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp 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 -> forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp forall a b. (a -> b) -> a -> b
$ (forall a. (Num a, Ord a) => a -> a -> a)
-> FScalarValue -> FScalarValue -> Either Error FScalarValue
Op.opIcNumericBOp forall a. Num a => a -> a -> a
(*) FScalarValue
l' FScalarValue
r'


      -- TODO confirm correct operation (not checked much)
      BinaryOp
F.Division -> forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp 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 (forall a. Integral a => a -> a -> a
div) forall a. Fractional 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) ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FInt a => a -> a -> a) -> FInt -> FInt -> FInt
fIntBOpInplace forall a b. (Num a, Integral b) => a -> b -> a
(^) FInt
li FInt
ri

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

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

      F.BinCustom{} -> -- TODO
        forall (m :: * -> *) a. MonadError Error m => Error -> m a
err 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FInt -> FScalarValue
FSVLogical forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> FInt
FInt4 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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' <- forall (m :: * -> *) a. MonadFEvalValue m => Int -> [a] -> m [a]
forceArgs Int
1 [FValue]
args
        let [FValue
v] = [FValue]
args'
        FScalarValue
v' <- 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 -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
ELazy String
"called kind with non-kinded scalar"
          Just FKindLit
k  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ Int32 -> FInt
FInt4 (forall a b. (Integral a, Num b) => a -> b
fromIntegral FKindLit
k)

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

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

      String
"char" -> do
        [FValue]
args' <- forall (m :: * -> *) a. MonadFEvalValue m => Int -> [a] -> m [a]
forceArgs Int
1 [FValue]
args
        let [FValue
v] = [FValue]
args'
        FScalarValue
v' <- 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 r. (forall a. FKindedC FInt a => a -> r) -> FInt -> r
fIntUOp forall a b. (Integral a, Num b) => a -> b
fromIntegral FInt
i)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue forall a b. (a -> b) -> a -> b
$ Text -> FScalarValue
FSVString forall a b. (a -> b) -> a -> b
$ Char -> Text
Text.singleton Char
c
          FScalarValue
_ ->
            forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError forall a b. (a -> b) -> a -> b
$
                String
"char: expected INT(x), got "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
v')

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

      String
"int"  ->
        case [FValue]
args of
          [] -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. FInt -> FScalarValue
FSVInt forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> FInt
FInt4) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int32
evalIntrinsicInt4 FValue
v
          [FValue
v, FValue
vk] -> do
            FScalarValue
vk' <- forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
vk
            case FScalarValue
vk' of
              FSVInt FInt
vkI -> (FScalarValue -> FValue
MkFScalarValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. FInt -> FScalarValue
FSVInt) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadFEvalValue m => FValue -> FInt -> m FInt
evalIntrinsicInt FValue
v FInt
vkI
              FScalarValue
_ ->
                forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError forall a b. (a -> b) -> a -> b
$
                    String
"int: kind argument must be INTEGER, got "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
vk')
          [FValue]
_ -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError forall a b. (a -> b) -> a -> b
$ String
"int: expected 1 or 2 arguments, got >2"

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

      String
_      -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EUnsupported forall a b. (a -> b) -> a -> b
$ String
"function call: " 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 r. (forall a. FKindedC FInt a => a -> r) -> FInt -> r
fIntUOp 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int8
evalIntrinsicInt1 FValue
v
      a
2 -> Int16 -> FInt
FInt2 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int16
evalIntrinsicInt2 FValue
v
      a
4 -> Int32 -> FInt
FInt4 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int32
evalIntrinsicInt4 FValue
v
      a
8 -> Int64 -> FInt
FInt8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadFEvalValue m => FValue -> m Int64
evalIntrinsicInt8 FValue
v
      a
_ -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err 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 = forall r (m :: * -> *).
(MonadFEvalValue m, Integral r) =>
(FInt -> r) -> FValue -> m r
evalIntrinsicIntXCoerce FInt -> Int8
coerceToI1
  where coerceToI1 :: FInt -> Int8
coerceToI1 = forall r.
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt -> r
fIntUOp' forall a. a -> a
id forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 = forall r (m :: * -> *).
(MonadFEvalValue m, Integral r) =>
(FInt -> r) -> FValue -> m r
evalIntrinsicIntXCoerce FInt -> Int16
coerceToI2
  where coerceToI2 :: FInt -> Int16
coerceToI2 = forall r.
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt -> r
fIntUOp' forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a. a -> a
id forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 = forall r (m :: * -> *).
(MonadFEvalValue m, Integral r) =>
(FInt -> r) -> FValue -> m r
evalIntrinsicIntXCoerce FInt -> Int32
coerceToI4
  where coerceToI4 :: FInt -> Int32
coerceToI4 = forall r.
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt -> r
fIntUOp' forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a. a -> a
id 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 = forall r (m :: * -> *).
(MonadFEvalValue m, Integral r) =>
(FInt -> r) -> FValue -> m r
evalIntrinsicIntXCoerce FInt -> Int64
coerceToI8
  where coerceToI8 :: FInt -> Int64
coerceToI8 = forall r.
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt -> r
fIntUOp' forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (Integral a, Num b) => a -> b
fromIntegral 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' <- forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
    case FScalarValue
v' of
      FSVInt  FInt
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ FInt -> r
coerceToIX FInt
i
      FSVReal FReal
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall r. (forall a. FKindedC FReal a => a -> r) -> FReal -> r
fRealUOp forall a b. (RealFrac a, Integral b) => a -> b
truncate FReal
r
      FScalarValue
_ ->
        forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError forall a b. (a -> b) -> a -> b
$
            String
"int: unsupported or unimplemented type: "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
v')

evalArg :: MonadFEvalValue m => F.Argument a -> m FValue
evalArg :: forall (m :: * -> *) a. MonadFEvalValue m => Argument a -> m FValue
evalArg (F.Argument a
_ SrcSpan
_ Maybe String
_ ArgumentExpression a
ae) =
    case ArgumentExpression a
ae of
      F.ArgExpr        Expression a
e -> forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression a -> m FValue
evalExpr Expression a
e
      F.ArgExprVar a
_ SrcSpan
_ String
v -> 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' -> 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
  []   -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError String
"not enough arguments"
  a
a:[a]
as -> 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   forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l forall a. Eq a => a -> a -> Bool
== Int
numArgs
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
l
    else forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError forall a b. (a -> b) -> a -> b
$
            String
"expected "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show Int
numArgsforall a. Semigroup a => a -> a -> a
<>String
" arguments; got "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show (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) -> forall (m :: * -> *).
MonadFEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt 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)
_ -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err 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
  []   -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err 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' <- forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
    [FScalarValue]
vs' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *). MonadFEvalValue m => FValue -> m FScalarValue
forceScalar [FValue]
vs
    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 [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 <- forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp forall a b. (a -> b) -> a -> b
$ (forall a. (Num a, Ord a) => a -> a -> a)
-> FScalarValue -> FScalarValue -> Either Error FScalarValue
Op.opIcNumericBOp forall a. Ord a => a -> a -> a
max FScalarValue
vCurMax FScalarValue
v
                FScalarValue -> [FScalarValue] -> f FValue
go FScalarValue
vNewMax [FScalarValue]
vs
              FScalarValue
_ ->
                forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError forall a b. (a -> b) -> a -> b
$
                    String
"max: expected INT(x), got "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
v)
          FSVReal{} ->
            case FScalarValue
v of
              FSVReal{} -> do
                FScalarValue
vNewMax <- forall (m :: * -> *) a. MonadFEvalValue m => Either Error a -> m a
wrapOp forall a b. (a -> b) -> a -> b
$ (forall a. (Num a, Ord a) => a -> a -> a)
-> FScalarValue -> FScalarValue -> Either Error FScalarValue
Op.opIcNumericBOp forall a. Ord a => a -> a -> a
max FScalarValue
vCurMax FScalarValue
v
                FScalarValue -> [FScalarValue] -> f FValue
go FScalarValue
vNewMax [FScalarValue]
vs
              FScalarValue
_ ->
                forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError forall a b. (a -> b) -> a -> b
$
                    String
"max: expected REAL(x), got "forall a. Semigroup a => a -> a -> a
<>forall a. Show a => a -> String
show (FScalarValue -> FScalarType
fScalarValueType FScalarValue
v)
          FScalarValue
_ ->
            forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EOpTypeError forall a b. (a -> b) -> a -> b
$
                String
"max: unsupported type: "forall a. Semigroup a => a -> a -> a
<> 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 a -> m FValue
evalConstExpr :: forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression a -> m FValue
evalConstExpr = forall (m :: * -> *) a.
MonadFEvalValue m =>
Expression a -> m FValue
evalExpr