-- | Evaluate operations between values in the value representation.

module Language.Fortran.Repr.Eval.Value.Op where

import Language.Fortran.Repr.Eval.Value.Op.Some

import Language.Fortran.Repr.Value.Scalar.Machine
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.Complex
import Language.Fortran.Repr.Value.Scalar.Logical.Machine
import Language.Fortran.Repr.Value.Scalar.String
import Language.Fortran.Repr.Type.Scalar
import Language.Fortran.Repr.Type.Scalar.Real
import GHC.Float ( float2Double )
import Data.Int

import Data.Bits

import Data.Singletons

-- | Operation TODO
data Error
  = EBadArgType1 [String] FScalarType
  | EBadArgType2 [String] FScalarType FScalarType
  | EGeneric String
    deriving stock (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)

-- https://gcc.gnu.org/onlinedocs/gfortran/DBLE.html#DBLE
opIcDble :: FScalarValue -> Either Error (FReal 'FTReal8)
opIcDble :: FScalarValue -> Either Error (FReal 'FTReal8)
opIcDble = \case
  FSVComplex (SomeFKinded FComplex fk
c) -> case FComplex fk
c of
    FComplex8  Float
r Float
_i -> forall {a}. Double -> Either a (FReal 'FTReal8)
rfr8 forall a b. (a -> b) -> a -> b
$ Float -> Double
float2Double Float
r
    FComplex16 Double
r Double
_i -> forall {a}. Double -> Either a (FReal 'FTReal8)
rfr8 Double
r
  FSVReal (SomeFKinded FReal fk
r) -> case FReal fk
r of
    FReal4 Float
r'   -> forall {a}. Double -> Either a (FReal 'FTReal8)
rfr8 forall a b. (a -> b) -> a -> b
$ Float -> Double
float2Double Float
r'
    FReal8 Double
_r'  -> forall a b. b -> Either a b
Right FReal fk
r
  FSVInt (SomeFKinded FInt fk
i) -> forall {a}. Double -> Either a (FReal 'FTReal8)
rfr8 forall a b. (a -> b) -> a -> b
$ forall a (k :: FTInt). Num a => FInt k -> a
withFInt FInt fk
i
  FScalarValue
v -> forall a. [String] -> FScalarValue -> Either Error a
eBadArgType1 [String
"COMPLEX", String
"REAL", String
"INT"] FScalarValue
v
  where rfr8 :: Double -> Either a (FReal 'FTReal8)
rfr8 = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> FReal 'FTReal8
FReal8

eBadArgType1 :: [String] -> FScalarValue -> Either Error a
eBadArgType1 :: forall a. [String] -> FScalarValue -> Either Error a
eBadArgType1 [String]
expected = forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> FScalarType -> Error
EBadArgType1 [String]
expected forall b c a. (b -> c) -> (a -> b) -> a -> c
. FScalarValue -> FScalarType
fScalarValueType

eBadArgType2 :: [String] -> FScalarValue -> FScalarValue -> Either Error a
eBadArgType2 :: forall a.
[String] -> FScalarValue -> FScalarValue -> Either Error a
eBadArgType2 [String]
expected FScalarValue
l FScalarValue
r =
    forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [String] -> FScalarType -> FScalarType -> Error
EBadArgType2 [String]
expected (FScalarValue -> FScalarType
fScalarValueType FScalarValue
l) (FScalarValue -> FScalarType
fScalarValueType FScalarValue
r)

eGeneric :: String -> Either Error a
eGeneric :: forall a. String -> Either Error a
eGeneric = forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Error
EGeneric

opIcNumericBOp
    :: (forall a. (Num a, Ord a) => a -> a -> a)
    -> FScalarValue -> FScalarValue -> Either Error FScalarValue
opIcNumericBOp :: (forall a. (Num a, Ord a) => a -> a -> a)
-> FScalarValue -> FScalarValue -> Either Error FScalarValue
opIcNumericBOp forall a. (Num a, Ord a) => a -> a -> a
bop = FScalarValue -> FScalarValue -> Either Error FScalarValue
go
  where
    go :: FScalarValue -> FScalarValue -> Either Error FScalarValue
go (FSVInt SomeFKinded FTInt FInt
l) (FSVInt SomeFKinded FTInt FInt
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SomeFKinded FTInt FInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ (forall a. IsFInt a => a -> a -> a)
-> SomeFKinded FTInt FInt
-> SomeFKinded FTInt FInt
-> SomeFKinded FTInt FInt
someFIntBOpWrap forall a. (Num a, Ord a) => a -> a -> a
bop SomeFKinded FTInt FInt
l SomeFKinded FTInt FInt
r
    go (FSVInt (SomeFKinded FInt fk
l)) (FSVReal SomeFKinded FTReal FReal
r) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SomeFKinded FTReal FReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ (forall a. RealFloat a => a -> a)
-> SomeFKinded FTReal FReal -> SomeFKinded FTReal FReal
someFRealUOpWrap (\a
x -> forall a (k :: FTInt). Num a => FInt k -> a
withFInt FInt fk
l forall a. (Num a, Ord a) => a -> a -> a
`bop` a
x) SomeFKinded FTReal FReal
r
    -- TODO int complex
    go (FSVReal SomeFKinded FTReal FReal
l) (FSVReal SomeFKinded FTReal FReal
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SomeFKinded FTReal FReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ (forall a. RealFloat a => a -> a -> a)
-> SomeFKinded FTReal FReal
-> SomeFKinded FTReal FReal
-> SomeFKinded FTReal FReal
someFRealBOpWrap forall a. (Num a, Ord a) => a -> a -> a
bop SomeFKinded FTReal FReal
l SomeFKinded FTReal FReal
r
    go (FSVReal SomeFKinded FTReal FReal
l) (FSVInt SomeFKinded FTInt FInt
r) = FScalarValue -> FScalarValue -> Either Error FScalarValue
go (SomeFKinded FTInt FInt -> FScalarValue
FSVInt SomeFKinded FTInt FInt
r) (SomeFKinded FTReal FReal -> FScalarValue
FSVReal SomeFKinded FTReal FReal
l)
    go (FSVReal SomeFKinded FTReal FReal
l) (FSVComplex SomeFKinded FTReal FComplex
r) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SomeFKinded FTReal FComplex -> FScalarValue
FSVComplex forall a b. (a -> b) -> a -> b
$ (forall a. RealFloat a => a -> a -> a)
-> SomeFKinded FTReal FComplex
-> SomeFKinded FTReal FComplex
-> SomeFKinded FTReal FComplex
someFComplexBOpWrap forall a. (Num a, Ord a) => a -> a -> a
bop (SomeFKinded FTReal FReal -> SomeFKinded FTReal FComplex
someFComplexFromReal SomeFKinded FTReal FReal
l) SomeFKinded FTReal FComplex
r

opIcNumericBOpRealIntSep
    :: (forall a. Integral  a => a -> a -> a)
    -> (forall a. RealFloat a => a -> a -> a)
    -> FScalarValue -> FScalarValue -> Either Error FScalarValue
opIcNumericBOpRealIntSep :: (forall a. Integral a => a -> a -> a)
-> (forall a. RealFloat a => a -> a -> a)
-> FScalarValue
-> FScalarValue
-> Either Error FScalarValue
opIcNumericBOpRealIntSep forall a. Integral a => a -> a -> a
bopInt forall a. RealFloat a => a -> a -> a
bopReal = FScalarValue -> FScalarValue -> Either Error FScalarValue
go
  where
    go :: FScalarValue -> FScalarValue -> Either Error FScalarValue
go (FSVInt SomeFKinded FTInt FInt
l) (FSVInt SomeFKinded FTInt FInt
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SomeFKinded FTInt FInt -> FScalarValue
FSVInt forall a b. (a -> b) -> a -> b
$ (forall a. IsFInt a => a -> a -> a)
-> SomeFKinded FTInt FInt
-> SomeFKinded FTInt FInt
-> SomeFKinded FTInt FInt
someFIntBOpWrap forall a. Integral a => a -> a -> a
bopInt SomeFKinded FTInt FInt
l SomeFKinded FTInt FInt
r
    go (FSVInt (SomeFKinded FInt fk
l)) (FSVReal SomeFKinded FTReal FReal
r) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SomeFKinded FTReal FReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ (forall a. RealFloat a => a -> a)
-> SomeFKinded FTReal FReal -> SomeFKinded FTReal FReal
someFRealUOpWrap (\a
x -> forall a (k :: FTInt). Num a => FInt k -> a
withFInt FInt fk
l forall a. RealFloat a => a -> a -> a
`bopReal` a
x) SomeFKinded FTReal FReal
r
    -- TODO int complex
    go (FSVReal SomeFKinded FTReal FReal
l) (FSVReal SomeFKinded FTReal FReal
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SomeFKinded FTReal FReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ (forall a. RealFloat a => a -> a -> a)
-> SomeFKinded FTReal FReal
-> SomeFKinded FTReal FReal
-> SomeFKinded FTReal FReal
someFRealBOpWrap forall a. RealFloat a => a -> a -> a
bopReal SomeFKinded FTReal FReal
l SomeFKinded FTReal FReal
r
    go (FSVReal SomeFKinded FTReal FReal
l) (FSVInt SomeFKinded FTInt FInt
r) = FScalarValue -> FScalarValue -> Either Error FScalarValue
go (SomeFKinded FTInt FInt -> FScalarValue
FSVInt SomeFKinded FTInt FInt
r) (SomeFKinded FTReal FReal -> FScalarValue
FSVReal SomeFKinded FTReal FReal
l)
    go (FSVReal SomeFKinded FTReal FReal
l) (FSVComplex SomeFKinded FTReal FComplex
r) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SomeFKinded FTReal FComplex -> FScalarValue
FSVComplex forall a b. (a -> b) -> a -> b
$ (forall a. RealFloat a => a -> a -> a)
-> SomeFKinded FTReal FComplex
-> SomeFKinded FTReal FComplex
-> SomeFKinded FTReal FComplex
someFComplexBOpWrap forall a. RealFloat a => a -> a -> a
bopReal (SomeFKinded FTReal FReal -> SomeFKinded FTReal FComplex
someFComplexFromReal SomeFKinded FTReal FReal
l) SomeFKinded FTReal FComplex
r

opIcNumRelBOp
    :: (forall a. Ord a => a -> a -> r)
    -> FScalarValue -> FScalarValue -> Either Error r
opIcNumRelBOp :: forall r.
(forall a. Ord a => a -> a -> r)
-> FScalarValue -> FScalarValue -> Either Error r
opIcNumRelBOp forall a. Ord a => a -> a -> r
bop = FScalarValue -> FScalarValue -> Either Error r
go
  where
    go :: FScalarValue -> FScalarValue -> Either Error r
go (FSVInt SomeFKinded FTInt FInt
l) (FSVInt SomeFKinded FTInt FInt
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r.
(forall a. IsFInt a => a -> a -> r)
-> SomeFKinded FTInt FInt -> SomeFKinded FTInt FInt -> r
someFIntBOp forall a. Ord a => a -> a -> r
bop SomeFKinded FTInt FInt
l SomeFKinded FTInt FInt
r
    go (FSVInt (SomeFKinded FInt fk
l)) (FSVReal SomeFKinded FTReal FReal
r) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r.
(forall a. RealFloat a => a -> r) -> SomeFKinded FTReal FReal -> r
someFRealUOp (\a
x -> forall a (k :: FTInt). Num a => FInt k -> a
withFInt FInt fk
l forall a. Ord a => a -> a -> r
`bop` a
x) SomeFKinded FTReal FReal
r
    -- TODO int complex
    go (FSVReal SomeFKinded FTReal FReal
l) (FSVReal SomeFKinded FTReal FReal
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r.
(forall a. RealFloat a => a -> a -> r)
-> SomeFKinded FTReal FReal -> SomeFKinded FTReal FReal -> r
someFRealBOp forall a. Ord a => a -> a -> r
bop SomeFKinded FTReal FReal
l SomeFKinded FTReal FReal
r
    go (FSVReal SomeFKinded FTReal FReal
l) (FSVInt SomeFKinded FTInt FInt
r) = FScalarValue -> FScalarValue -> Either Error r
go (SomeFKinded FTInt FInt -> FScalarValue
FSVInt SomeFKinded FTInt FInt
r) (SomeFKinded FTReal FReal -> FScalarValue
FSVReal SomeFKinded FTReal FReal
l)
    -- TODO real complex
    go (FSVString SomeFString
l) (FSVString SomeFString
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r. (Text -> Text -> r) -> SomeFString -> SomeFString -> r
someFStringBOp forall a. Ord a => a -> a -> r
bop SomeFString
l SomeFString
r

-- plus, minus
opIcNumericUOpInplace
    :: (forall a. Num a => a -> a)
    -> FScalarValue -> Either Error FScalarValue
opIcNumericUOpInplace :: (forall a. Num a => a -> a)
-> FScalarValue -> Either Error FScalarValue
opIcNumericUOpInplace forall a. Num a => a -> a
uop = \case
  FSVInt  (SomeFKinded FInt fk
v) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SomeFKinded FTInt FInt -> 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. Num a => a -> a
uop FInt fk
v
  FSVReal (SomeFKinded FReal fk
v) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ SomeFKinded FTReal FReal -> 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
$ forall (k :: FTReal).
(forall a. RealFloat a => a -> a) -> FReal k -> FReal k
fRealUOpInplace forall a. Num a => a -> a
uop FReal fk
v
  FScalarValue
v -> forall a. [String] -> FScalarValue -> Either Error a
eBadArgType1 [String
"INT", String
"REAL"] FScalarValue
v

-- and, or, eqv, neqv
opIcLogicalBOp
    :: (Bool -> Bool -> r)
    -> FScalarValue -> FScalarValue -> Either Error r
opIcLogicalBOp :: forall r.
(Bool -> Bool -> r)
-> FScalarValue -> FScalarValue -> Either Error r
opIcLogicalBOp Bool -> Bool -> r
bop = FScalarValue -> FScalarValue -> Either Error r
go
  where
    go :: FScalarValue -> FScalarValue -> Either Error r
go (FSVLogical (SomeFKinded FInt fk
l)) (FSVLogical (SomeFKinded FInt fk
r)) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> r
bop (forall (k :: FTInt). FInt k -> Bool
fLogicalToBool FInt fk
l) (forall (k :: FTInt). FInt k -> Bool
fLogicalToBool FInt fk
r)
    go FScalarValue
l FScalarValue
r = forall a.
[String] -> FScalarValue -> FScalarValue -> Either Error a
eBadArgType2 [String
"LOGICAL"] FScalarValue
l FScalarValue
r

opEq :: FScalarValue -> FScalarValue -> Either Error Bool
opEq :: FScalarValue -> FScalarValue -> Either Error Bool
opEq = forall {a}. FScalarValue -> FScalarValue -> Either a Bool
go
  where
    go :: FScalarValue -> FScalarValue -> Either a Bool
go (FSVInt  SomeFKinded FTInt FInt
l) (FSVInt  SomeFKinded FTInt FInt
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r.
(forall a. IsFInt a => a -> a -> r)
-> SomeFKinded FTInt FInt -> SomeFKinded FTInt FInt -> r
someFIntBOp  forall a. Eq a => a -> a -> Bool
(==) SomeFKinded FTInt FInt
l SomeFKinded FTInt FInt
r
    go (FSVReal SomeFKinded FTReal FReal
l) (FSVReal SomeFKinded FTReal FReal
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r.
(forall a. RealFloat a => a -> a -> r)
-> SomeFKinded FTReal FReal -> SomeFKinded FTReal FReal -> r
someFRealBOp forall a. Eq a => a -> a -> Bool
(==) SomeFKinded FTReal FReal
l SomeFKinded FTReal FReal
r
    go (FSVInt (SomeFKinded FInt fk
l)) (FSVReal SomeFKinded FTReal FReal
r) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r.
(forall a. RealFloat a => a -> r) -> SomeFKinded FTReal FReal -> r
someFRealUOp (\a
x -> forall a (k :: FTInt). Num a => FInt k -> a
withFInt FInt fk
l forall a. Eq a => a -> a -> Bool
== a
x) SomeFKinded FTReal FReal
r
    go (FSVReal SomeFKinded FTReal FReal
l) (FSVInt SomeFKinded FTInt FInt
r) = FScalarValue -> FScalarValue -> Either a Bool
go (SomeFKinded FTInt FInt -> FScalarValue
FSVInt SomeFKinded FTInt FInt
r) (SomeFKinded FTReal FReal -> FScalarValue
FSVReal SomeFKinded FTReal FReal
l)
    go (FSVString SomeFString
l) (FSVString SomeFString
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r. (Text -> Text -> r) -> SomeFString -> SomeFString -> r
someFStringBOp forall a. Eq a => a -> a -> Bool
(==) SomeFString
l SomeFString
r

-- | According to gfortran spec and F2010 spec, same kind required.
opIor' :: FInt k -> FInt k -> FInt k
opIor' :: forall (k :: FTInt). FInt k -> FInt k -> FInt k
opIor' = forall (kl :: FTInt) (kr :: FTInt).
(forall a. IsFInt a => a -> a -> a)
-> FInt kl -> FInt kr -> FInt (FTIntCombine kl kr)
fIntBOpInplace forall a. Bits a => a -> a -> a
(.|.)

opIor :: FScalarValue -> FScalarValue -> Either Error SomeFInt
opIor :: FScalarValue
-> FScalarValue -> Either Error (SomeFKinded FTInt FInt)
opIor (FSVInt (SomeFKinded FInt fk
l)) (FSVInt (SomeFKinded FInt fk
r)) =
    case (FInt fk
l, FInt fk
r) of
      (FInt4{}, FInt4{}) -> do
        let out :: FInt fk
out = forall (k :: FTInt). FInt k -> FInt k -> FInt k
opIor' FInt fk
l FInt fk
r
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded FInt fk
out
      (FInt8{}, FInt8{}) -> do
        let out :: FInt fk
out = forall (k :: FTInt). FInt k -> FInt k -> FInt k
opIor' FInt fk
l FInt fk
r
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded FInt fk
out
      (FInt2{}, FInt2{}) -> do
        let out :: FInt fk
out = forall (k :: FTInt). FInt k -> FInt k -> FInt k
opIor' FInt fk
l FInt fk
r
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded FInt fk
out
      (FInt1{}, FInt1{}) -> do
        let out :: FInt fk
out = forall (k :: FTInt). FInt k -> FInt k -> FInt k
opIor' FInt fk
l FInt fk
r
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k (ft :: k -> *) (fk :: k).
(SingKind k, SingI fk) =>
ft fk -> SomeFKinded k ft
SomeFKinded FInt fk
out
opIor FScalarValue
l FScalarValue
r = forall a.
[String] -> FScalarValue -> FScalarValue -> Either Error a
eBadArgType2 [String
"INT", String
"INT"] FScalarValue
l FScalarValue
r