-- SPDX-FileCopyrightText: 2021 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{-# LANGUAGE NoImplicitPrelude #-}

-- | Safe(r) converters from @Integral@ types
module Morley.Prelude.FromIntegral
  ( IntBaseType
  , IsIntSubType
  , fromIntegral
  , fromIntegralMaybe
  , fromIntegralNoOverflow
  , fromIntegralOverflowing
  , fromIntegralToRealFrac
  ) where

import Control.Exception (ArithException(..))
import Data.Bits (Bits)
import Data.IntCast (IntBaseType, IsIntSubType, intCast, intCastMaybe)
import Data.Ratio ((%))
import System.IO.Unsafe (unsafePerformIO)
import Universum hiding (fromInteger, fromIntegral)
import qualified Universum (fromIntegral)

-- | Statically safe converter between 'Integral'
-- types, which is just 'intCast' under the hood.
--
-- It is used to turn the value of type @a@ into
-- the value of type @b@ such that @a@ is subtype
-- of @b@. It is needed to prevent silent unsafe
-- conversions.
fromIntegral :: (Integral a, Integral b, IsIntSubType a b ~ 'True) => a -> b
fromIntegral :: a -> b
fromIntegral = a -> b
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast

-- | Statically safe converter between 'Integral'
-- types, which is just 'intCastMaybe' under the
-- hood. Unlike 'fromIntegral' accept any @a@ and
-- @b@. Return @Just value@ if conversion is
-- possible at runtime and @Nothing@ otherwise.
fromIntegralMaybe :: (Integral a, Integral b, Bits a, Bits b) => a -> Maybe b
fromIntegralMaybe :: a -> Maybe b
fromIntegralMaybe = a -> Maybe b
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
intCastMaybe

-- | Statically safe converter between 'Integral'
-- and 'RealFrac' types. Could be applied to cast
-- common types like @Float@, @Double@ and @Scientific@.
--
-- It is primarily needed to replace usages of
-- 'Unsafe.fromIntegral', which are safe actually
-- as integral numbers are being casted to
-- fractional ones.
fromIntegralToRealFrac :: (Integral a, RealFrac b, IsIntSubType a Integer ~ 'True) => a -> b
fromIntegralToRealFrac :: a -> b
fromIntegralToRealFrac = Rational -> b
forall a. Fractional a => Rational -> a
fromRational (Rational -> b) -> (a -> Rational) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
1) (Integer -> Rational) -> (a -> Integer) -> a -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Integer
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
fromIntegral

{- | Runtime-safe converter between 'Integral' types, which is just
'Universum.fromIntegral' under the hood.

It is needed to semantically distinguish usages, where overflow is intended,
from those that have to fail on overflow. E.g. @Int8 -> Word8@ with intended
bits reinterpretation from lossy @Integer -> Int@.

>>> fromIntegralOverflowing @Int8 @Word8 (-1)
255
>>> fromIntegralOverflowing @Natural @Int8 450
-62

Please note that like @fromIntegral@ from @base@, this will throw on some
conversions!

>>> fromIntegralOverflowing @Int @Natural (-1)
*** Exception: arithmetic underflow

See 'fromIntegralNoOverflow' for an alternative that doesn't throw.
-}
fromIntegralOverflowing :: (Integral a, Num b) => a -> b
fromIntegralOverflowing :: a -> b
fromIntegralOverflowing = a -> b
forall a b. (Integral a, Num b) => a -> b
Universum.fromIntegral

{- | Statically safe converter between 'Integral' types
checking for overflow/underflow. Returns @Right value@ if conversion does not
produce overflow/underflow and @Left ArithException@ with corresponding
'ArithException' (@Overflow@/@Underflow@) otherwise.

Note the function is strict in its argument.

>>> fromIntegralNoOverflow @Int @Word 123
Right 123
>>> fromIntegralNoOverflow @Int @Word (-123)
Left arithmetic underflow
>>> fromIntegralNoOverflow @Int @Integer (-123)
Right (-123)
>>> fromIntegralNoOverflow @Int @Natural (-123)
Left arithmetic underflow
>>> fromIntegralNoOverflow @Int @Int8 127
Right 127
>>> fromIntegralNoOverflow @Int @Int8 128
Left arithmetic overflow
-}
fromIntegralNoOverflow :: (Integral a, Integral b) => a -> Either ArithException b
fromIntegralNoOverflow :: a -> Either ArithException b
fromIntegralNoOverflow !a
a = do
  b
b <- a -> Either ArithException b
forall a b. (Integral a, Num b) => a -> Either ArithException b
tryFromIntegral a
a
  case Integer -> Integer -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> Integer
forall a. Integral a => a -> Integer
toInteger a
a) (b -> Integer
forall a. Integral a => a -> Integer
toInteger b
b) of
    Ordering
EQ -> b -> Either ArithException b
forall a b. b -> Either a b
Right b
b
    Ordering
LT -> ArithException -> Either ArithException b
forall a b. a -> Either a b
Left ArithException
Underflow
    Ordering
GT -> ArithException -> Either ArithException b
forall a b. a -> Either a b
Left ArithException
Overflow
  where
    tryFromIntegral :: a -> Either ArithException b
tryFromIntegral a
x = IO (Either ArithException b) -> Either ArithException b
forall a. IO a -> a
unsafePerformIO (IO (Either ArithException b) -> Either ArithException b)
-> IO (Either ArithException b) -> Either ArithException b
forall a b. (a -> b) -> a -> b
$
      (let !y :: b
y = a -> b
forall a b. (Integral a, Num b) => a -> b
Universum.fromIntegral a
x in Either ArithException b -> IO (Either ArithException b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Either ArithException b
forall a b. b -> Either a b
Right b
y))
      IO (Either ArithException b)
-> (ArithException -> IO (Either ArithException b))
-> IO (Either ArithException b)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \case
        ArithException
Overflow -> Either ArithException b -> IO (Either ArithException b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ArithException b -> IO (Either ArithException b))
-> Either ArithException b -> IO (Either ArithException b)
forall a b. (a -> b) -> a -> b
$ ArithException -> Either ArithException b
forall a b. a -> Either a b
Left ArithException
Overflow
        ArithException
Underflow -> Either ArithException b -> IO (Either ArithException b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ArithException b -> IO (Either ArithException b))
-> Either ArithException b -> IO (Either ArithException b)
forall a b. (a -> b) -> a -> b
$ ArithException -> Either ArithException b
forall a b. a -> Either a b
Left ArithException
Underflow
        ArithException
e -> ArithException -> IO (Either ArithException b)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM ArithException
e