{-# LANGUAGE ConstraintKinds #-}

-- | 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.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 Control.Monad.Except

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

-- | A convenience type over 'MonadEval' bringing all requirements into scope.
type MonadEvalValue m = (MonadEval m, EvalTo m ~ FValue, MonadError Error m)

-- | Value evaluation error.
data Error
  = ENoSuchVar F.Name
  | EKindLitBadType F.Name FType
  | ENoSuchKindForType String KindLit
  | EUnsupported String
  | EOp Op.Error
  | EOpTypeError String
  | 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)

-- TODO best for temp KPs: String, Integer, Text? Word8??
type KindLit = String

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

-- | A simple pure interpreter for Fortran value evaluation programs.
type EvalValueSimple = WriterT [String] (ExceptT Error (Reader (Map F.Name FValue)))

instance MonadEval EvalValueSimple where
    type EvalTo EvalValueSimple = FValue
    warn :: String -> EvalValueSimple ()
warn String
msg = forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [String
msg]
    lookupFVar :: String -> EvalValueSimple (Maybe (EvalTo EvalValueSimple))
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

runEvalValueSimple
    :: Map F.Name FValue
    -> EvalValueSimple a -> Either Error (a, [String])
runEvalValueSimple :: forall a.
Map String FValue
-> EvalValueSimple a -> Either Error (a, [String])
runEvalValueSimple 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

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

evalVar :: MonadEvalValue m => F.Name -> m FValue
evalVar :: forall (m :: * -> *). MonadEvalValue m => String -> m FValue
evalVar String
name =
    forall (m :: * -> *). MonadEval 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 (m :: * -> *) a. Monad m => a -> m a
return FValue
val

evalExpr :: MonadEvalValue m => F.Expression a -> m FValue
evalExpr :: forall (m :: * -> *) a.
MonadEvalValue 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 :: * -> *). MonadEvalValue 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.
MonadEvalValue m =>
Value a -> m FScalarValue
evalLit Value a
astVal
  F.ExpUnary  a
_ SrcSpan
_ UnaryOp
uop Expression a
e   -> do
    FValue
v <- forall (m :: * -> *) a.
MonadEvalValue m =>
Expression a -> m FValue
evalExpr Expression a
e
    forall (m :: * -> *).
MonadEvalValue 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.
MonadEvalValue m =>
Expression a -> m FValue
evalExpr Expression a
le
    FValue
rv <- forall (m :: * -> *) a.
MonadEvalValue m =>
Expression a -> m FValue
evalExpr Expression a
re
    forall (m :: * -> *).
MonadEvalValue 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. MonadEvalValue 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 :: * -> *).
MonadEvalValue 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 :: MonadEvalValue m => F.Value a -> m FScalarValue
evalLit :: forall (m :: * -> *) a.
MonadEvalValue m =>
Value a -> m FScalarValue
evalLit = \case
  F.ValInteger String
i Maybe (KindParam a)
mkp -> do
    forall (m :: * -> *) a.
MonadEvalValue m =>
String -> Maybe (KindParam a) -> m String
evalKp String
"4" Maybe (KindParam a)
mkp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      String
"4" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Int32 -> FInt 'FTInt4
FInt4 forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> a
read String
i
      String
"8" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Int64 -> FInt 'FTInt8
FInt8 forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> a
read String
i
      String
"2" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Int16 -> FInt 'FTInt2
FInt2 forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> a
read String
i
      String
"1" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Int8 -> FInt 'FTInt1
FInt1 forall a b. (a -> b) -> a -> b
$ forall a. Read a => String -> a
read String
i
      String
k   -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> String -> Error
ENoSuchKindForType String
"INTEGER" String
k
  F.ValReal RealLit
r Maybe (KindParam a)
mkp -> do
    forall (m :: * -> *) a.
MonadEvalValue m =>
ExponentLetter -> Maybe (KindParam a) -> m String
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
      String
"4" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Float -> FReal 'FTReal4
FReal4 forall a b. (a -> b) -> a -> b
$ forall a. (Fractional a, Read a) => RealLit -> a
F.readRealLit RealLit
r
      String
"8" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Double -> FReal 'FTReal8
FReal8 forall a b. (a -> b) -> a -> b
$ forall a. (Fractional a, Read a) => RealLit -> a
F.readRealLit RealLit
r
      String
k   -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> String -> Error
ENoSuchKindForType String
"REAL" String
k
  F.ValLogical Bool
b Maybe (KindParam a)
mkp -> do
    forall (m :: * -> *) a.
MonadEvalValue m =>
String -> Maybe (KindParam a) -> m String
evalKp String
"4" Maybe (KindParam a)
mkp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      String
"4" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFInt -> FScalarValue
FSVLogical forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Int32 -> FInt 'FTInt4
FInt4 forall a b. (a -> b) -> a -> b
$ forall a. Num a => Bool -> a
fLogicalNumericFromBool Bool
b
      String
"8" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFInt -> FScalarValue
FSVLogical forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Int64 -> FInt 'FTInt8
FInt8 forall a b. (a -> b) -> a -> b
$ forall a. Num a => Bool -> a
fLogicalNumericFromBool Bool
b
      String
"2" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFInt -> FScalarValue
FSVLogical forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Int16 -> FInt 'FTInt2
FInt2 forall a b. (a -> b) -> a -> b
$ forall a. Num a => Bool -> a
fLogicalNumericFromBool Bool
b
      String
"1" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFInt -> FScalarValue
FSVLogical forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Int8 -> FInt 'FTInt1
FInt1 forall a b. (a -> b) -> a -> b
$ forall a. Num a => Bool -> a
fLogicalNumericFromBool Bool
b
      String
k   -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> String -> Error
ENoSuchKindForType String
"LOGICAL" String
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 (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFString -> FScalarValue
FSVString forall a b. (a -> b) -> a -> b
$ Text -> SomeFString
someFString forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
s
  F.ValBoz Boz
boz -> do
    forall (m :: * -> *). MonadEval m => String -> m ()
warn String
"requested to evaluate BOZ literal with no context: defaulting to INTEGER(4)"
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Int32 -> FInt 'FTInt4
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 (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ SomeFString -> FScalarValue
FSVString forall a b. (a -> b) -> a -> b
$ Text -> SomeFString
someFString forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack String
s
  F.ValIntrinsic{} -> forall a. HasCallStack => String -> a
error String
"you tried to evaluate a lit, but it was an intrinsic name"
  F.ValVariable{} ->  forall a. HasCallStack => String -> a
error String
"you tried to evaluate a lit, but it was a variable name"
  F.ValOperator{} ->  forall a. HasCallStack => String -> a
error String
"you tried to evaluate a lit, but it was a custom operator name"
  Value a
F.ValAssignment ->  forall a. HasCallStack => String -> a
error String
"you tried to evaluate a lit, but it was an overloaded assignment name"
  Value a
F.ValStar       ->  forall a. HasCallStack => String -> a
error String
"you tried to evaluate a lit, but it was a star"
  Value a
F.ValColon      ->  forall a. HasCallStack => String -> a
error String
"you tried to evaluate a lit, but it was a colon"
  F.ValType{}     ->  forall a. HasCallStack => String -> a
error String
"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 :: MonadEvalValue m => KindLit -> Maybe (F.KindParam a) -> m KindLit
evalKp :: forall (m :: * -> *) a.
MonadEvalValue m =>
String -> Maybe (KindParam a) -> m String
evalKp String
kDef = \case
  Maybe (KindParam a)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return String
kDef
  Just KindParam a
kp -> case KindParam a
kp of
    F.KindParamInt a
_ SrcSpan
_ String
k -> forall (m :: * -> *) a. Monad m => a -> m a
return String
k
    F.KindParamVar a
_ SrcSpan
_ String
var ->
      forall (m :: * -> *). MonadEval 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 (SomeFKinded FInt fk
i)) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall r (k :: FTInt).
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt k -> r
fIntUOp' forall a. Show a => a -> String
show forall a. Show a => a -> String
show forall a. Show a => a -> String
show forall a. Show a => a -> String
show FInt fk
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

-- TODO needs cleanup: internal repetition, common parts with evalKp. also needs
-- a docstring
evalRealKp :: MonadEvalValue m => F.ExponentLetter -> Maybe (F.KindParam a) -> m KindLit
evalRealKp :: forall (m :: * -> *) a.
MonadEvalValue m =>
ExponentLetter -> Maybe (KindParam a) -> m String
evalRealKp ExponentLetter
l Maybe (KindParam a)
mkp =
    m (Maybe String)
kindViaKindParam forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe String
Nothing ->
        case ExponentLetter
l of
          ExponentLetter
F.ExpLetterE -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"4"
          ExponentLetter
F.ExpLetterD -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"8"
          ExponentLetter
F.ExpLetterQ -> do
            forall (m :: * -> *). MonadEval m => String -> m ()
warn String
"TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"
            forall (m :: * -> *) a.
MonadEvalValue m =>
ExponentLetter -> Maybe (KindParam a) -> m String
evalRealKp ExponentLetter
F.ExpLetterD Maybe (KindParam a)
mkp
      Just String
kkp ->
        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 String
kkp
          ExponentLetter
F.ExpLetterD -> do -- @1.2D3_8@ syntax is nonsensical
            forall (m :: * -> *). MonadEval 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 String
kkp
          ExponentLetter
F.ExpLetterQ -> do
            forall (m :: * -> *). MonadEval m => String -> m ()
warn String
"TODO 1.2Q3 REAL literals not supported; defaulting to REAL(8)"
            forall (m :: * -> *) a.
MonadEvalValue m =>
ExponentLetter -> Maybe (KindParam a) -> m String
evalRealKp ExponentLetter
F.ExpLetterD Maybe (KindParam a)
mkp
  where
    kindViaKindParam :: m (Maybe String)
kindViaKindParam =
        case Maybe (KindParam a)
mkp of
          Maybe (KindParam a)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          Just KindParam a
kp -> case KindParam a
kp of
            F.KindParamInt a
_ SrcSpan
_ String
k -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just String
k
            F.KindParamVar a
_ SrcSpan
_ String
var ->
              forall (m :: * -> *). MonadEval 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 (SomeFKinded FInt fk
i)) ->
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall r (k :: FTInt).
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt k -> r
fIntUOp' forall a. Show a => a -> String
show forall a. Show a => a -> String
show forall a. Show a => a -> String
show forall a. Show a => a -> String
show FInt fk
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

evalUOp :: MonadEvalValue m => F.UnaryOp -> FValue -> m FValue
evalUOp :: forall (m :: * -> *).
MonadEvalValue m =>
UnaryOp -> FValue -> m FValue
evalUOp UnaryOp
op FValue
v = do
    FScalarValue
v' <- forall (m :: * -> *). MonadEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
    case UnaryOp
op of
      UnaryOp
F.Plus  -> forall (m :: * -> *).
MonadEvalValue 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 :: * -> *).
MonadEvalValue 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 (SomeFKinded FInt fk
bi) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue forall a b. (a -> b) -> a -> b
$ SomeFInt -> FScalarValue
FSVLogical forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ forall (k :: FTInt). FInt k -> FInt k
fLogicalNot FInt fk
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 :: MonadEvalValue m => Either Op.Error a -> m a
wrapOp :: forall (m :: * -> *) a. MonadEvalValue m => Either Error a -> m a
wrapOp = \case
  Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: MonadEvalValue m => Either Op.Error FScalarValue -> m FValue
wrapSOp :: forall (m :: * -> *).
MonadEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp = \case
  Right FScalarValue
a -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 :: MonadEvalValue m => F.BinaryOp -> FValue -> FValue -> m FValue
evalBOp :: forall (m :: * -> *).
MonadEvalValue 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 :: * -> *). MonadEvalValue m => FValue -> m FScalarValue
forceScalar FValue
l
    FScalarValue
r' <- forall (m :: * -> *). MonadEvalValue m => FValue -> m FScalarValue
forceScalar FValue
r
    case BinaryOp
bop of
      BinaryOp
F.Addition       -> forall (m :: * -> *).
MonadEvalValue 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 :: * -> *).
MonadEvalValue 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 :: * -> *).
MonadEvalValue 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 :: * -> *).
MonadEvalValue 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'

      BinaryOp
F.Exponentiation -> -- TODO not looked, certainly custom
        forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EUnsupported String
"exponentiation"

      BinaryOp
F.Concatenation  ->
        case (FScalarValue
l', FScalarValue
r') of
          (FSVString SomeFString
ls, FSVString SomeFString
rs) ->
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ FScalarValue -> FValue
MkFScalarValue forall a b. (a -> b) -> a -> b
$ SomeFString -> FScalarValue
FSVString forall a b. (a -> b) -> a -> b
$ SomeFString -> SomeFString -> SomeFString
concatSomeFString SomeFString
ls SomeFString
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. MonadEvalValue 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. MonadEvalValue 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. MonadEvalValue 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. MonadEvalValue 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. MonadEvalValue 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. MonadEvalValue 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. MonadEvalValue 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. MonadEvalValue 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. MonadEvalValue 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. MonadEvalValue 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. MonadEvalValue 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
. SomeFInt -> FScalarValue
FSVLogical forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> FInt 'FTInt4
FInt4 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => Bool -> a
fLogicalNumericFromBool

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

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

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

      String
"char" -> do
        [FValue]
args' <- forall (m :: * -> *) a. MonadEvalValue m => Int -> [a] -> m [a]
forceArgs Int
1 [FValue]
args
        let [FValue
v] = [FValue]
args'
        FScalarValue
v' <- forall (m :: * -> *). MonadEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
        case FScalarValue
v' of
          FSVInt (SomeFKinded FInt fk
i) -> do
            -- TODO better error handling
            let c :: Char
c    = Int -> Char
Data.Char.chr (forall r (k :: FTInt).
(forall a. IsFInt a => a -> r) -> FInt k -> r
fIntUOp forall a b. (Integral a, Num b) => a -> b
fromIntegral FInt fk
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
$ SomeFString -> FScalarValue
FSVString forall a b. (a -> b) -> a -> b
$ Text -> SomeFString
someFString 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. MonadEvalValue m => Int -> [a] -> m [a]
forceArgs Int
1 [FValue]
args
        let [FValue
v] = [FValue]
args'
        FScalarValue
v' <- forall (m :: * -> *). MonadEvalValue m => FValue -> m FScalarValue
forceScalar FValue
v
        case FScalarValue
v' of
          FSVInt (SomeFKinded FInt fk
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
$ SomeFInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ forall (k :: FTInt).
(forall a. IsFInt a => a -> a) -> FInt k -> FInt k
fIntUOpInplace forall a. Bits a => a -> a
Data.Bits.complement FInt fk
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"  -> do
        -- TODO a real pain. just implementing common bits for now
        -- TODO gfortran actually performs some range checks for constants!
        -- @int(128, 1)@ errors with "this INT(4) is too big for INT(1)".
        [FValue]
args' <- forall (m :: * -> *) a. MonadEvalValue m => Int -> [a] -> m [a]
forceArgs Int
1 [FValue]
args
        let [FValue
v] = [FValue]
args'
        FScalarValue
v' <- forall (m :: * -> *). MonadEvalValue 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 (SomeFKinded FReal fk
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
$ SomeFInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Int32 -> FInt 'FTInt4
FInt4 forall a b. (a -> b) -> a -> b
$ forall r (k :: FTReal).
(forall a. RealFloat a => a -> r) -> FReal k -> r
fRealUOp forall a b. (RealFrac a, Integral b) => a -> b
truncate FReal fk
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')

      -- TODO all lies
      String
"int2" -> do
        [FValue]
args' <- forall (m :: * -> *) a. MonadEvalValue m => Int -> [a] -> m [a]
forceArgs Int
1 [FValue]
args
        let [FValue
v] = [FValue]
args'
        FScalarValue
v' <- forall (m :: * -> *). MonadEvalValue 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 (SomeFKinded FReal fk
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
$ SomeFInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded forall a b. (a -> b) -> a -> b
$ Int16 -> FInt 'FTInt2
FInt2 forall a b. (a -> b) -> a -> b
$ forall r (k :: FTReal).
(forall a. RealFloat a => a -> r) -> FReal k -> r
fRealUOp forall a b. (RealFrac a, Integral b) => a -> b
truncate FReal fk
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

evalArg :: MonadEvalValue m => F.Argument a -> m FValue
evalArg :: forall (m :: * -> *) a. MonadEvalValue 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.
MonadEvalValue m =>
Expression a -> m FValue
evalExpr Expression a
e
      F.ArgExprVar a
_ SrcSpan
_ String
v -> forall (m :: * -> *). MonadEvalValue m => String -> m FValue
evalVar  String
v

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

forceScalar :: MonadEvalValue m => FValue -> m FScalarValue
forceScalar :: forall (m :: * -> *). MonadEvalValue m => FValue -> m FScalarValue
forceScalar = \case
  MkFArrayValue{} -> forall (m :: * -> *) a. MonadError Error m => Error -> m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
EUnsupported String
"no array values in eval for now thx"
  MkFScalarValue FScalarValue
v' -> forall (m :: * -> *) a. Monad m => a -> m a
return FScalarValue
v'

forceUnconsArg :: MonadEvalValue m => [a] -> m (a, [a])
forceUnconsArg :: forall (m :: * -> *) a. MonadEvalValue 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 (m :: * -> *) a. Monad m => a -> m a
return (a
a, [a]
as)

-- TODO can I use vector-sized to improve safety here? lol
-- it's just convenience either way
forceArgs :: MonadEvalValue m => Int -> [a] -> m [a]
forceArgs :: forall (m :: * -> *) a. MonadEvalValue 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 (m :: * -> *) a. Monad m => a -> m a
return [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
    :: MonadEvalValue m => FScalarValue -> FScalarValue -> m FValue
evalIntrinsicIor :: forall (m :: * -> *).
MonadEvalValue m =>
FScalarValue -> FScalarValue -> m FValue
evalIntrinsicIor FScalarValue
l FScalarValue
r = forall (m :: * -> *).
MonadEvalValue m =>
Either Error FScalarValue -> m FValue
wrapSOp forall a b. (a -> b) -> a -> b
$ SomeFInt -> FScalarValue
FSVInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FScalarValue -> FScalarValue -> Either Error SomeFInt
Op.opIor FScalarValue
l FScalarValue
r

-- https://gcc.gnu.org/onlinedocs/gfortran/MAX.html
-- TODO should support arrays! at least for >=F2010
evalIntrinsicMax
    :: MonadEvalValue m => [FValue] -> m FValue
evalIntrinsicMax :: forall (m :: * -> *). MonadEvalValue 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 :: * -> *). MonadEvalValue 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 :: * -> *). MonadEvalValue m => FValue -> m FScalarValue
forceScalar [FValue]
vs
    forall {f :: * -> *}.
(EvalTo f ~ FValue, MonadEval 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. MonadEvalValue 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. MonadEvalValue 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)