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

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

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
(Int -> Error -> ShowS)
-> (Error -> String) -> ([Error] -> ShowS) -> Show Error
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Error -> ShowS
showsPrec :: Int -> Error -> ShowS
$cshow :: Error -> String
show :: Error -> String
$cshowList :: [Error] -> ShowS
showList :: [Error] -> ShowS
Show, Error -> Error -> Bool
(Error -> Error -> Bool) -> (Error -> Error -> Bool) -> Eq Error
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
/= :: Error -> Error -> Bool
Eq)

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

eBadArgType1 :: [String] -> FScalarValue -> Either Error a
eBadArgType1 :: forall a. [String] -> FScalarValue -> Either Error a
eBadArgType1 [String]
expected = Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a)
-> (FScalarValue -> Error) -> FScalarValue -> Either Error a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> FScalarType -> Error
EBadArgType1 [String]
expected (FScalarType -> Error)
-> (FScalarValue -> FScalarType) -> FScalarValue -> Error
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 =
    Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a) -> Error -> Either Error a
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 = Error -> Either Error a
forall a b. a -> Either a b
Left (Error -> Either Error a)
-> (String -> Error) -> String -> Either Error a
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 FInt
l) (FSVInt FInt
r) = FScalarValue -> Either Error FScalarValue
forall a b. b -> Either a b
Right (FScalarValue -> Either Error FScalarValue)
-> FScalarValue -> Either Error FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FInt a => a -> a -> a) -> FInt -> FInt -> FInt
fIntBOpInplace a -> a -> a
forall a. (Num a, Ord a) => a -> a -> a
forall a. FKindedC FInt a => a -> a -> a
bop FInt
l FInt
r
    go (FSVInt FInt
l) (FSVReal FReal
r) =
        FScalarValue -> Either Error FScalarValue
forall a b. b -> Either a b
Right (FScalarValue -> Either Error FScalarValue)
-> FScalarValue -> Either Error FScalarValue
forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal (FReal -> FScalarValue) -> FReal -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> a) -> FReal -> FReal
fRealUOpInplace (\a
x -> FInt -> a
forall a. Num a => FInt -> a
withFInt FInt
l a -> a -> a
forall a. (Num a, Ord a) => a -> a -> a
`bop` a
x) FReal
r
    -- TODO int complex
    go (FSVReal FReal
l) (FSVReal FReal
r) = FScalarValue -> Either Error FScalarValue
forall a b. b -> Either a b
Right (FScalarValue -> Either Error FScalarValue)
-> FScalarValue -> Either Error FScalarValue
forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal (FReal -> FScalarValue) -> FReal -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> a -> a)
-> FReal -> FReal -> FReal
fRealBOpInplace a -> a -> a
forall a. (Num a, Ord a) => a -> a -> a
forall a. FKindedC FReal a => a -> a -> a
bop FReal
l FReal
r
    go (FSVReal FReal
l) (FSVInt FInt
r) = FScalarValue -> FScalarValue -> Either Error FScalarValue
go (FInt -> FScalarValue
FSVInt FInt
r) (FReal -> FScalarValue
FSVReal FReal
l)
    go (FSVReal FReal
l) (FSVComplex FComplex
r) =
        FScalarValue -> Either Error FScalarValue
forall a b. b -> Either a b
Right (FScalarValue -> Either Error FScalarValue)
-> FScalarValue -> Either Error FScalarValue
forall a b. (a -> b) -> a -> b
$ FComplex -> FScalarValue
FSVComplex (FComplex -> FScalarValue) -> FComplex -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FComplex a => a -> a -> a)
-> FComplex -> FComplex -> FComplex
fComplexBOpInplace a -> a -> a
forall a. (Num a, Ord a) => a -> a -> a
forall a. FKindedC FComplex a => a -> a -> a
bop (FReal -> FComplex
fComplexFromReal FReal
l) 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 FInt
l) (FSVInt FInt
r) = FScalarValue -> Either Error FScalarValue
forall a b. b -> Either a b
Right (FScalarValue -> Either Error FScalarValue)
-> FScalarValue -> Either Error FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FInt a => a -> a -> a) -> FInt -> FInt -> FInt
fIntBOpInplace a -> a -> a
forall a. Integral a => a -> a -> a
forall a. FKindedC FInt a => a -> a -> a
bopInt FInt
l FInt
r
    go (FSVInt FInt
l) (FSVReal FReal
r) =
        FScalarValue -> Either Error FScalarValue
forall a b. b -> Either a b
Right (FScalarValue -> Either Error FScalarValue)
-> FScalarValue -> Either Error FScalarValue
forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal (FReal -> FScalarValue) -> FReal -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> a) -> FReal -> FReal
fRealUOpInplace (\a
x -> FInt -> a
forall a. Num a => FInt -> a
withFInt FInt
l a -> a -> a
forall a. RealFloat a => a -> a -> a
`bopReal` a
x) FReal
r
    -- TODO int complex
    go (FSVReal FReal
l) (FSVReal FReal
r) = FScalarValue -> Either Error FScalarValue
forall a b. b -> Either a b
Right (FScalarValue -> Either Error FScalarValue)
-> FScalarValue -> Either Error FScalarValue
forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal (FReal -> FScalarValue) -> FReal -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> a -> a)
-> FReal -> FReal -> FReal
fRealBOpInplace a -> a -> a
forall a. RealFloat a => a -> a -> a
forall a. FKindedC FReal a => a -> a -> a
bopReal FReal
l FReal
r
    go (FSVReal FReal
l) (FSVInt FInt
r) = FScalarValue -> FScalarValue -> Either Error FScalarValue
go (FInt -> FScalarValue
FSVInt FInt
r) (FReal -> FScalarValue
FSVReal FReal
l)
    go (FSVReal FReal
l) (FSVComplex FComplex
r) =
        FScalarValue -> Either Error FScalarValue
forall a b. b -> Either a b
Right (FScalarValue -> Either Error FScalarValue)
-> FScalarValue -> Either Error FScalarValue
forall a b. (a -> b) -> a -> b
$ FComplex -> FScalarValue
FSVComplex (FComplex -> FScalarValue) -> FComplex -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FComplex a => a -> a -> a)
-> FComplex -> FComplex -> FComplex
fComplexBOpInplace a -> a -> a
forall a. RealFloat a => a -> a -> a
forall a. FKindedC FComplex a => a -> a -> a
bopReal (FReal -> FComplex
fComplexFromReal FReal
l) 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 FInt
l) (FSVInt FInt
r) = r -> Either Error r
forall a b. b -> Either a b
Right (r -> Either Error r) -> r -> Either Error r
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FInt a => a -> a -> r) -> FInt -> FInt -> r
forall r.
(forall a. FKindedC FInt a => a -> a -> r) -> FInt -> FInt -> r
fIntBOp a -> a -> r
forall a. Ord a => a -> a -> r
forall a. FKindedC FInt a => a -> a -> r
bop FInt
l FInt
r
    go (FSVInt FInt
l) (FSVReal FReal
r) =
        r -> Either Error r
forall a b. b -> Either a b
Right (r -> Either Error r) -> r -> Either Error r
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> r) -> FReal -> r
forall r. (forall a. FKindedC FReal a => a -> r) -> FReal -> r
fRealUOp (\a
x -> FInt -> a
forall a. Num a => FInt -> a
withFInt FInt
l a -> a -> r
forall a. Ord a => a -> a -> r
`bop` a
x) FReal
r
    -- TODO int complex
    go (FSVReal FReal
l) (FSVReal FReal
r) = r -> Either Error r
forall a b. b -> Either a b
Right (r -> Either Error r) -> r -> Either Error r
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> a -> r) -> FReal -> FReal -> r
forall r.
(forall a. FKindedC FReal a => a -> a -> r) -> FReal -> FReal -> r
fRealBOp a -> a -> r
forall a. Ord a => a -> a -> r
forall a. FKindedC FReal a => a -> a -> r
bop FReal
l FReal
r
    go (FSVReal FReal
l) (FSVInt FInt
r) = FScalarValue -> FScalarValue -> Either Error r
go (FInt -> FScalarValue
FSVInt FInt
r) (FReal -> FScalarValue
FSVReal FReal
l)
    -- TODO real complex
    go (FSVString Text
l) (FSVString Text
r) = r -> Either Error r
forall a b. b -> Either a b
Right (r -> Either Error r) -> r -> Either Error r
forall a b. (a -> b) -> a -> b
$ Text
l Text -> Text -> r
forall a. Ord a => a -> a -> r
`bop` Text
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  FInt
v -> FScalarValue -> Either Error FScalarValue
forall a b. b -> Either a b
Right (FScalarValue -> Either Error FScalarValue)
-> FScalarValue -> Either Error FScalarValue
forall a b. (a -> b) -> a -> b
$ FInt -> FScalarValue
FSVInt  (FInt -> FScalarValue) -> FInt -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FInt a => a -> a) -> FInt -> FInt
fIntUOpInplace  a -> a
forall a. Num a => a -> a
forall a. FKindedC FInt a => a -> a
uop FInt
v
  FSVReal FReal
v -> FScalarValue -> Either Error FScalarValue
forall a b. b -> Either a b
Right (FScalarValue -> Either Error FScalarValue)
-> FScalarValue -> Either Error FScalarValue
forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal (FReal -> FScalarValue) -> FReal -> FScalarValue
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> a) -> FReal -> FReal
fRealUOpInplace a -> a
forall a. Num a => a -> a
forall a. FKindedC FReal a => a -> a
uop FReal
v
  FScalarValue
v -> [String] -> FScalarValue -> Either Error FScalarValue
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 FInt
l) (FSVLogical FInt
r) =
        r -> Either Error r
forall a b. b -> Either a b
Right (r -> Either Error r) -> r -> Either Error r
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> r
bop (FInt -> Bool
fLogicalToBool FInt
l) (FInt -> Bool
fLogicalToBool FInt
r)
    go FScalarValue
l FScalarValue
r = [String] -> FScalarValue -> FScalarValue -> Either Error 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 = FScalarValue -> FScalarValue -> Either Error Bool
forall {a}. FScalarValue -> FScalarValue -> Either a Bool
go
  where
    go :: FScalarValue -> FScalarValue -> Either a Bool
go (FSVInt  FInt
l) (FSVInt  FInt
r) = Bool -> Either a Bool
forall a b. b -> Either a b
Right (Bool -> Either a Bool) -> Bool -> Either a Bool
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FInt a => a -> a -> Bool)
-> FInt -> FInt -> Bool
forall r.
(forall a. FKindedC FInt a => a -> a -> r) -> FInt -> FInt -> r
fIntBOp  a -> a -> Bool
forall a. Eq a => a -> a -> Bool
forall a. FKindedC FInt a => a -> a -> Bool
(==) FInt
l FInt
r
    go (FSVReal FReal
l) (FSVReal FReal
r) = Bool -> Either a Bool
forall a b. b -> Either a b
Right (Bool -> Either a Bool) -> Bool -> Either a Bool
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> a -> Bool)
-> FReal -> FReal -> Bool
forall r.
(forall a. FKindedC FReal a => a -> a -> r) -> FReal -> FReal -> r
fRealBOp a -> a -> Bool
forall a. Eq a => a -> a -> Bool
forall a. FKindedC FReal a => a -> a -> Bool
(==) FReal
l FReal
r
    go (FSVInt FInt
i) (FSVReal FReal
r) =
        Bool -> Either a Bool
forall a b. b -> Either a b
Right (Bool -> Either a Bool) -> Bool -> Either a Bool
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> Bool) -> FReal -> Bool
forall r. (forall a. FKindedC FReal a => a -> r) -> FReal -> r
fRealUOp (\a
x -> FInt -> a
forall a. Num a => FInt -> a
withFInt FInt
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x) FReal
r
    go (FSVReal FReal
r) (FSVInt FInt
i) =
        Bool -> Either a Bool
forall a b. b -> Either a b
Right (Bool -> Either a Bool) -> Bool -> Either a Bool
forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> Bool) -> FReal -> Bool
forall r. (forall a. FKindedC FReal a => a -> r) -> FReal -> r
fRealUOp (\a
x -> FInt -> a
forall a. Num a => FInt -> a
withFInt FInt
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x) FReal
r
    go (FSVString Text
l) (FSVString Text
r) = Bool -> Either a Bool
forall a b. b -> Either a b
Right (Bool -> Either a Bool) -> Bool -> Either a Bool
forall a b. (a -> b) -> a -> b
$ Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
r

-- | According to gfortran spec and F2010 spec, same kind required.
opIor' :: FInt -> FInt -> FInt
opIor' :: FInt -> FInt -> FInt
opIor' = (forall a. FKindedC FInt a => a -> a -> a) -> FInt -> FInt -> FInt
fIntBOpInplace a -> a -> a
forall a. Bits a => a -> a -> a
forall a. FKindedC FInt a => a -> a -> a
(.|.)

opIor :: FInt -> FInt -> Either Error FInt
opIor :: FInt -> FInt -> Either Error FInt
opIor FInt
l FInt
r =
    case (FInt
l, FInt
r) of
      (FInt4{}, FInt4{}) -> FInt -> Either Error FInt
forall a b. b -> Either a b
Right (FInt -> Either Error FInt) -> FInt -> Either Error FInt
forall a b. (a -> b) -> a -> b
$ FInt -> FInt -> FInt
opIor' FInt
l FInt
r
      (FInt8{}, FInt8{}) -> FInt -> Either Error FInt
forall a b. b -> Either a b
Right (FInt -> Either Error FInt) -> FInt -> Either Error FInt
forall a b. (a -> b) -> a -> b
$ FInt -> FInt -> FInt
opIor' FInt
l FInt
r
      (FInt2{}, FInt2{}) -> FInt -> Either Error FInt
forall a b. b -> Either a b
Right (FInt -> Either Error FInt) -> FInt -> Either Error FInt
forall a b. (a -> b) -> a -> b
$ FInt -> FInt -> FInt
opIor' FInt
l FInt
r
      (FInt1{}, FInt1{}) -> FInt -> Either Error FInt
forall a b. b -> Either a b
Right (FInt -> Either Error FInt) -> FInt -> Either Error FInt
forall a b. (a -> b) -> a -> b
$ FInt -> FInt -> FInt
opIor' FInt
l FInt
r
      (FInt, FInt)
_ -> Error -> Either Error FInt
forall a b. a -> Either a b
Left (Error -> Either Error FInt) -> Error -> Either Error FInt
forall a b. (a -> b) -> a -> b
$ String -> Error
EGeneric String
"bad args to ior"