{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DerivingVia #-}
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 )
import Control.Monad.Reader
import Control.Monad.Writer
import qualified Data.Map as Map
import Data.Map ( Map )
data Error
= ENoSuchVar F.Name
| EKindLitBadType F.Name FType
| ENoSuchKindForType String FKindLit
| EUnsupported String
| EOp Op.Error
| EOpTypeError String
| ESpecial String
| ELazy String
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)
type MonadFEvalValue m = (MonadFEval m, EvalTo m ~ FValue, MonadError Error m)
type FEvalValuePureT = WriterT [String] (ExceptT Error (Reader (Map F.Name FValue)))
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
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
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
[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) ->
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 ->
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
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 ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure FKindLit
k
ExponentLetter
F.ExpLetterD -> do
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 ->
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
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
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
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'
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'
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{} ->
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
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
(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"
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
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"
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
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
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
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
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)
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"
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)
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