{- | Machine Fortran INTEGER values.

This module stores Fortran INTEGER values in a matching Haskell machine integer
type. For example, an @INT(4)@ would be stored in an 'Int32'. This way, we get
both efficient operations and common overflow behaviour (which hopefully matches
most Fortran compilers), and explicitly encode kinding semantics via promoting
integral types.
-}

module Language.Fortran.Repr.Value.Scalar.Int.Machine where

import Language.Fortran.Repr.Type.Scalar.Int
import Language.Fortran.Repr.Value.Scalar.Common
import Data.Int

import Data.Bits ( Bits )

import GHC.Generics ( Generic )
import Data.Data ( Data )
import Data.Binary ( Binary )
import Text.PrettyPrint.GenericPretty ( Out )
import Text.PrettyPrint.GenericPretty.Orphans()

-- | A Fortran integer value, type @INTEGER(k)@.
data FInt
  = FInt1 {- ^ @INTEGER(1)@ -} Int8
  | FInt2 {- ^ @INTEGER(2)@ -} Int16
  | FInt4 {- ^ @INTEGER(4)@ -} Int32
  | FInt8 {- ^ @INTEGER(8)@ -} Int64
    deriving stock (Int -> FInt -> ShowS
[FInt] -> ShowS
FInt -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FInt] -> ShowS
$cshowList :: [FInt] -> ShowS
show :: FInt -> String
$cshow :: FInt -> String
showsPrec :: Int -> FInt -> ShowS
$cshowsPrec :: Int -> FInt -> ShowS
Show, forall x. Rep FInt x -> FInt
forall x. FInt -> Rep FInt x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FInt x -> FInt
$cfrom :: forall x. FInt -> Rep FInt x
Generic, Typeable FInt
FInt -> DataType
FInt -> Constr
(forall b. Data b => b -> b) -> FInt -> FInt
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> FInt -> u
forall u. (forall d. Data d => d -> u) -> FInt -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> FInt -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> FInt -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> FInt -> m FInt
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FInt -> m FInt
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FInt
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FInt -> c FInt
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FInt)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c FInt)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FInt -> m FInt
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FInt -> m FInt
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FInt -> m FInt
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> FInt -> m FInt
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> FInt -> m FInt
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> FInt -> m FInt
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> FInt -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> FInt -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> FInt -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> FInt -> [u]
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> FInt -> r
$cgmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> FInt -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> FInt -> r
$cgmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> FInt -> r
gmapT :: (forall b. Data b => b -> b) -> FInt -> FInt
$cgmapT :: (forall b. Data b => b -> b) -> FInt -> FInt
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c FInt)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c FInt)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FInt)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c FInt)
dataTypeOf :: FInt -> DataType
$cdataTypeOf :: FInt -> DataType
toConstr :: FInt -> Constr
$ctoConstr :: FInt -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FInt
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c FInt
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FInt -> c FInt
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> FInt -> c FInt
Data)
    deriving anyclass (Get FInt
[FInt] -> Put
FInt -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [FInt] -> Put
$cputList :: [FInt] -> Put
get :: Get FInt
$cget :: Get FInt
put :: FInt -> Put
$cput :: FInt -> Put
Binary, Int -> FInt -> Doc
[FInt] -> Doc
FInt -> Doc
forall a. (Int -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
docList :: [FInt] -> Doc
$cdocList :: [FInt] -> Doc
doc :: FInt -> Doc
$cdoc :: FInt -> Doc
docPrec :: Int -> FInt -> Doc
$cdocPrec :: Int -> FInt -> Doc
Out)

instance FKinded FInt where
    type FKindedT FInt = FTInt
    type FKindedC FInt a = (Integral a, Bits a)
    fKind :: FInt -> FKindedT FInt
fKind = \case
      FInt1{} -> FTInt
FTInt1
      FInt2{} -> FTInt
FTInt2
      FInt4{} -> FTInt
FTInt4
      FInt8{} -> FTInt
FTInt8

instance Eq FInt where == :: FInt -> FInt -> Bool
(==) = forall r.
(forall a. FKindedC FInt a => a -> a -> r) -> FInt -> FInt -> r
fIntBOp forall a. Eq a => a -> a -> Bool
(==)

withFInt :: Num a => FInt -> a
withFInt :: forall a. Num a => FInt -> a
withFInt = forall r. (forall a. FKindedC FInt a => a -> r) -> FInt -> r
fIntUOp forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- Pattern matches are ordered to match more common ops earlier.
fIntUOp'
    :: (Int8  -> r)
    -> (Int16 -> r)
    -> (Int32 -> r)
    -> (Int64 -> r)
    -> FInt -> r
fIntUOp' :: forall r.
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt -> r
fIntUOp' Int8 -> r
k1f Int16 -> r
k2f Int32 -> r
k4f Int64 -> r
k8f = \case
  FInt4 Int32
i32 -> Int32 -> r
k4f Int32
i32
  FInt8 Int64
i64 -> Int64 -> r
k8f Int64
i64
  FInt2 Int16
i16 -> Int16 -> r
k2f Int16
i16
  FInt1 Int8
i8  -> Int8 -> r
k1f Int8
i8

-- Pattern matches are ordered to match more common ops earlier.
fIntBOp'
    :: (Int8  -> Int8  -> r)
    -> (Int16 -> Int16 -> r)
    -> (Int32 -> Int32 -> r)
    -> (Int64 -> Int64 -> r)
    -> FInt -> FInt -> r
fIntBOp' :: forall r.
(Int8 -> Int8 -> r)
-> (Int16 -> Int16 -> r)
-> (Int32 -> Int32 -> r)
-> (Int64 -> Int64 -> r)
-> FInt
-> FInt
-> r
fIntBOp' Int8 -> Int8 -> r
k1f Int16 -> Int16 -> r
k2f Int32 -> Int32 -> r
k4f Int64 -> Int64 -> r
k8f FInt
il FInt
ir = case (FInt
il, FInt
ir) of
  (FInt4 Int32
l32, FInt4 Int32
r32) -> Int32 -> Int32 -> r
k4f Int32
l32 Int32
r32
  (FInt8 Int64
l64, FInt8 Int64
r64) -> Int64 -> Int64 -> r
k8f Int64
l64 Int64
r64

  (FInt4 Int32
l32, FInt8 Int64
r64) -> Int64 -> Int64 -> r
k8f (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
l32) Int64
r64
  (FInt8 Int64
l64, FInt4 Int32
r32) -> Int64 -> Int64 -> r
k8f Int64
l64 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
r32)

  (FInt4 Int32
l32, FInt2 Int16
r16) -> Int32 -> Int32 -> r
k4f Int32
l32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
r16)
  (FInt2 Int16
l16, FInt4 Int32
r32) -> Int32 -> Int32 -> r
k4f (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
l16) Int32
r32

  (FInt4 Int32
l32, FInt1 Int8
r8)  -> Int32 -> Int32 -> r
k4f Int32
l32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
r8)
  (FInt1 Int8
l8,  FInt4 Int32
r32) -> Int32 -> Int32 -> r
k4f (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
l8) Int32
r32

  (FInt8 Int64
l64, FInt2 Int16
r16) -> Int64 -> Int64 -> r
k8f Int64
l64 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
r16)
  (FInt2 Int16
l16, FInt8 Int64
r64) -> Int64 -> Int64 -> r
k8f (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
l16) Int64
r64

  (FInt8 Int64
l64, FInt1 Int8
r8)  -> Int64 -> Int64 -> r
k8f Int64
l64 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
r8)
  (FInt1 Int8
l8,  FInt8 Int64
r64) -> Int64 -> Int64 -> r
k8f (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
l8) Int64
r64

  (FInt2 Int16
l16, FInt2 Int16
r16) -> Int16 -> Int16 -> r
k2f Int16
l16 Int16
r16
  (FInt2 Int16
l16, FInt1 Int8
r8)  -> Int16 -> Int16 -> r
k2f Int16
l16 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
r8)
  (FInt1 Int8
l8,  FInt2 Int16
r16) -> Int16 -> Int16 -> r
k2f (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
l8) Int16
r16

  (FInt1 Int8
l8,  FInt1 Int8
r8)  -> Int8 -> Int8 -> r
k1f Int8
l8 Int8
r8

fIntUOpInplace'
    :: (Int8  -> Int8)
    -> (Int16 -> Int16)
    -> (Int32 -> Int32)
    -> (Int64 -> Int64)
    -> FInt -> FInt
fIntUOpInplace' :: (Int8 -> Int8)
-> (Int16 -> Int16)
-> (Int32 -> Int32)
-> (Int64 -> Int64)
-> FInt
-> FInt
fIntUOpInplace' Int8 -> Int8
k1f Int16 -> Int16
k2f Int32 -> Int32
k4f Int64 -> Int64
k8f =
    forall r.
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt -> r
fIntUOp' (Int8 -> FInt
FInt1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Int8
k1f) (Int16 -> FInt
FInt2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Int16
k2f) (Int32 -> FInt
FInt4 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int32
k4f) (Int64 -> FInt
FInt8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64
k8f)

fIntBOpInplace'
    :: (Int8  -> Int8  -> Int8)
    -> (Int16 -> Int16 -> Int16)
    -> (Int32 -> Int32 -> Int32)
    -> (Int64 -> Int64 -> Int64)
    -> FInt -> FInt -> FInt
fIntBOpInplace' :: (Int8 -> Int8 -> Int8)
-> (Int16 -> Int16 -> Int16)
-> (Int32 -> Int32 -> Int32)
-> (Int64 -> Int64 -> Int64)
-> FInt
-> FInt
-> FInt
fIntBOpInplace' Int8 -> Int8 -> Int8
k1f Int16 -> Int16 -> Int16
k2f Int32 -> Int32 -> Int32
k4f Int64 -> Int64 -> Int64
k8f =
    forall r.
(Int8 -> Int8 -> r)
-> (Int16 -> Int16 -> r)
-> (Int32 -> Int32 -> r)
-> (Int64 -> Int64 -> r)
-> FInt
-> FInt
-> r
fIntBOp' (forall {a} {b} {t} {t}. (a -> b) -> (t -> t -> a) -> t -> t -> b
f Int8 -> FInt
FInt1 Int8 -> Int8 -> Int8
k1f) (forall {a} {b} {t} {t}. (a -> b) -> (t -> t -> a) -> t -> t -> b
f Int16 -> FInt
FInt2 Int16 -> Int16 -> Int16
k2f) (forall {a} {b} {t} {t}. (a -> b) -> (t -> t -> a) -> t -> t -> b
f Int32 -> FInt
FInt4 Int32 -> Int32 -> Int32
k4f) (forall {a} {b} {t} {t}. (a -> b) -> (t -> t -> a) -> t -> t -> b
f Int64 -> FInt
FInt8 Int64 -> Int64 -> Int64
k8f)
  where f :: (a -> b) -> (t -> t -> a) -> t -> t -> b
f a -> b
cstr t -> t -> a
bop t
l t
r = a -> b
cstr forall a b. (a -> b) -> a -> b
$ t -> t -> a
bop t
l t
r

fIntUOp :: (forall a. FKindedC FInt a => a -> r) -> FInt -> r
fIntUOp :: forall r. (forall a. FKindedC FInt a => a -> r) -> FInt -> r
fIntUOp forall a. FKindedC FInt a => a -> r
f = forall r.
(Int8 -> r)
-> (Int16 -> r) -> (Int32 -> r) -> (Int64 -> r) -> FInt -> r
fIntUOp' forall a. FKindedC FInt a => a -> r
f forall a. FKindedC FInt a => a -> r
f forall a. FKindedC FInt a => a -> r
f forall a. FKindedC FInt a => a -> r
f

fIntUOpInplace :: (forall a. FKindedC FInt a => a -> a) -> FInt -> FInt
fIntUOpInplace :: (forall a. FKindedC FInt a => a -> a) -> FInt -> FInt
fIntUOpInplace forall a. FKindedC FInt a => a -> a
f = (Int8 -> Int8)
-> (Int16 -> Int16)
-> (Int32 -> Int32)
-> (Int64 -> Int64)
-> FInt
-> FInt
fIntUOpInplace' forall a. FKindedC FInt a => a -> a
f forall a. FKindedC FInt a => a -> a
f forall a. FKindedC FInt a => a -> a
f forall a. FKindedC FInt a => a -> a
f

fIntBOp :: (forall a. FKindedC FInt a => a -> a -> r) -> FInt -> FInt -> r
fIntBOp :: forall r.
(forall a. FKindedC FInt a => a -> a -> r) -> FInt -> FInt -> r
fIntBOp forall a. FKindedC FInt a => a -> a -> r
f = forall r.
(Int8 -> Int8 -> r)
-> (Int16 -> Int16 -> r)
-> (Int32 -> Int32 -> r)
-> (Int64 -> Int64 -> r)
-> FInt
-> FInt
-> r
fIntBOp' forall a. FKindedC FInt a => a -> a -> r
f forall a. FKindedC FInt a => a -> a -> r
f forall a. FKindedC FInt a => a -> a -> r
f forall a. FKindedC FInt a => a -> a -> r
f

fIntBOpInplace :: (forall a. FKindedC FInt a => a -> a -> a) -> FInt -> FInt -> FInt
fIntBOpInplace :: (forall a. FKindedC FInt a => a -> a -> a) -> FInt -> FInt -> FInt
fIntBOpInplace forall a. FKindedC FInt a => a -> a -> a
f = (Int8 -> Int8 -> Int8)
-> (Int16 -> Int16 -> Int16)
-> (Int32 -> Int32 -> Int32)
-> (Int64 -> Int64 -> Int64)
-> FInt
-> FInt
-> FInt
fIntBOpInplace' forall a. FKindedC FInt a => a -> a -> a
f forall a. FKindedC FInt a => a -> a -> a
f forall a. FKindedC FInt a => a -> a -> a
f forall a. FKindedC FInt a => a -> a -> a
f

{-

-- TODO improve: always return answer, plus a flag indicating if there was an
-- error, plus this should be in eval instead and this should be simpler
-- (shouldn't be wrapping in Either)
fIntCoerceChecked :: FTInt -> FInt -> Either String FInt
fIntCoerceChecked ty = fIntUOp $ \n ->
    if fromIntegral n > fIntMax @kout then
        Left "too large for new size"
    else if fromIntegral n < fIntMin @kout then
        Left "too small for new size"
    else
        case ty of
          FTInt1  -> Right $ FInt1 $ fromIntegral n
          FTInt2  -> Right $ FInt2 $ fromIntegral n
          FTInt4  -> Right $ FInt4 $ fromIntegral n
          FTInt8  -> Right $ FInt8 $ fromIntegral n
          FTInt16 -> Left "can't represent INTEGER(16) yet, sorry"

-}