-- | 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
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
opIcDble :: FScalarValue -> Either Error FReal
opIcDble = \case
  FSVComplex FComplex
c -> case FComplex
c of
    FComplex8  Float
r Float
_i -> forall {a}. Double -> Either a FReal
rfr8 forall a b. (a -> b) -> a -> b
$ Float -> Double
float2Double Float
r
    FComplex16 Double
r Double
_i -> forall {a}. Double -> Either a FReal
rfr8 Double
r
  FSVReal FReal
r -> case FReal
r of
    FReal4 Float
r'   -> forall {a}. Double -> Either a FReal
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
r
  FSVInt FInt
i -> forall {a}. Double -> Either a FReal
rfr8 forall a b. (a -> b) -> a -> b
$ forall a. Num a => FInt -> a
withFInt FInt
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
rfr8 = forall a b. b -> Either a b
Right 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 = 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 FInt
l) (FSVInt FInt
r) = forall a b. b -> Either a b
Right 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. (Num a, Ord a) => a -> a -> a
bop FInt
l FInt
r
    go (FSVInt FInt
l) (FSVReal FReal
r) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> a) -> FReal -> FReal
fRealUOpInplace (\a
x -> forall a. Num a => FInt -> a
withFInt FInt
l forall a. (Num a, Ord a) => a -> a -> a
`bop` a
x) FReal
r
    -- TODO int complex
    go (FSVReal FReal
l) (FSVReal FReal
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> a -> a)
-> FReal -> FReal -> FReal
fRealBOpInplace forall a. (Num a, Ord 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) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FComplex -> FScalarValue
FSVComplex forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FComplex a => a -> a -> a)
-> FComplex -> FComplex -> FComplex
fComplexBOpInplace forall a. (Num a, Ord 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) = forall a b. b -> Either a b
Right 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. Integral a => a -> a -> a
bopInt FInt
l FInt
r
    go (FSVInt FInt
l) (FSVReal FReal
r) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> a) -> FReal -> FReal
fRealUOpInplace (\a
x -> forall a. Num a => FInt -> a
withFInt FInt
l forall a. RealFloat a => a -> a -> a
`bopReal` a
x) FReal
r
    -- TODO int complex
    go (FSVReal FReal
l) (FSVReal FReal
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> a -> a)
-> FReal -> FReal -> FReal
fRealBOpInplace forall a. RealFloat 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) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FComplex -> FScalarValue
FSVComplex forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FComplex a => a -> a -> a)
-> FComplex -> FComplex -> FComplex
fComplexBOpInplace forall a. RealFloat 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) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r.
(forall a. FKindedC FInt a => a -> a -> r) -> FInt -> FInt -> r
fIntBOp forall a. Ord a => a -> a -> r
bop FInt
l FInt
r
    go (FSVInt FInt
l) (FSVReal FReal
r) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r. (forall a. FKindedC FReal a => a -> r) -> FReal -> r
fRealUOp (\a
x -> forall a. Num a => FInt -> a
withFInt FInt
l forall a. Ord a => a -> a -> r
`bop` a
x) FReal
r
    -- TODO int complex
    go (FSVReal FReal
l) (FSVReal FReal
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r.
(forall a. FKindedC FReal a => a -> a -> r) -> FReal -> FReal -> r
fRealBOp forall a. Ord 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) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text
l 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 -> forall a b. b -> Either a b
Right 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. Num a => a -> a
uop FInt
v
  FSVReal FReal
v -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FReal -> FScalarValue
FSVReal forall a b. (a -> b) -> a -> b
$ (forall a. FKindedC FReal a => a -> a) -> FReal -> FReal
fRealUOpInplace forall a. Num a => a -> a
uop FReal
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 FInt
l) (FSVLogical FInt
r) =
        forall a b. b -> Either a b
Right 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 = 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  FInt
l) (FSVInt  FInt
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r.
(forall a. FKindedC FInt a => a -> a -> r) -> FInt -> FInt -> r
fIntBOp  forall a. Eq a => a -> a -> Bool
(==) FInt
l FInt
r
    go (FSVReal FReal
l) (FSVReal FReal
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r.
(forall a. FKindedC FReal a => a -> a -> r) -> FReal -> FReal -> r
fRealBOp forall a. Eq a => a -> a -> Bool
(==) FReal
l FReal
r
    go (FSVInt FInt
i) (FSVReal FReal
r) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r. (forall a. FKindedC FReal a => a -> r) -> FReal -> r
fRealUOp (\a
x -> forall a. Num a => FInt -> a
withFInt FInt
i forall a. Eq a => a -> a -> Bool
== a
x) FReal
r
    go (FSVReal FReal
r) (FSVInt FInt
i) =
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall r. (forall a. FKindedC FReal a => a -> r) -> FReal -> r
fRealUOp (\a
x -> forall a. Num a => FInt -> a
withFInt FInt
i forall a. Eq a => a -> a -> Bool
== a
x) FReal
r
    go (FSVString Text
l) (FSVString Text
r) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text
l 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 forall a. Bits 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{}) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FInt -> FInt -> FInt
opIor' FInt
l FInt
r
      (FInt8{}, FInt8{}) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FInt -> FInt -> FInt
opIor' FInt
l FInt
r
      (FInt2{}, FInt2{}) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FInt -> FInt -> FInt
opIor' FInt
l FInt
r
      (FInt1{}, FInt1{}) -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ FInt -> FInt -> FInt
opIor' FInt
l FInt
r
      (FInt, FInt)
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Error
EGeneric String
"bad args to ior"