{-# LANGUAGE ConstraintKinds #-}
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
import Control.Monad.Reader
import Control.Monad.Writer
import qualified Data.Map as Map
import Data.Map ( Map )
type MonadEvalValue m = (MonadEval m, EvalTo m ~ FValue, MonadError Error m)
data Error
= ENoSuchVar F.Name
| EKindLitBadType F.Name FType
| ENoSuchKindForType String KindLit
| EUnsupported String
| EOp Op.Error
| EOpTypeError 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 KindLit = String
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
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
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
[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) ->
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
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 ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
kkp
ExponentLetter
F.ExpLetterD -> do
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 ->
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
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
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
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'
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 ->
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{} ->
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
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
[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')
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)
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
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)