-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# LANGUAGE NoImplicitPrelude #-}

-- | Safe(r) converters from @Integral@ types
module Morley.Prelude.FromIntegral
  ( IntBaseType
  , CheckIntSubType
  , 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 GHC.TypeLits (ErrorMessage(..), TypeError)
import System.IO.Unsafe (unsafePerformIO)
import Universum hiding (fromInteger, fromIntegral)
import Universum qualified (fromIntegral)

-- | Constraint synonym equivalent to @'IsIntSubType' a b ~ 'True@, but with
-- better error messages
type CheckIntSubType a b =
  ( CheckIntSubTypeErrors a b (IsIntSubType a b)
  , IsIntSubType a b ~ 'True )

type family CheckIntSubTypeErrors a b (z :: Bool) :: Constraint where
  CheckIntSubTypeErrors _ _ 'True = ()
  CheckIntSubTypeErrors a b 'False =
    TypeError ('Text "Can not safely cast '"
         ':<>: 'ShowType a ':<>: 'Text "' to '" ':<>: 'ShowType b ':<>: 'Text "':"
         ':$$: 'Text "'" ':<>: 'ShowType a ':<>: 'Text "' is not a subtype of '" ':<>: 'ShowType b
         ':<>: 'Text "'"
         )

{- | 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 @Int @Word 1
...
... error:
... Can not safely cast 'Int' to 'Word':
... 'Int' is not a subtype of 'Word'
...
>>> fromIntegral @Word @Natural 1
1
-}
fromIntegral :: (Integral a, Integral b, CheckIntSubType a b) => 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, CheckIntSubType a Integer) => 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, CheckIntSubType a b) => 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