{-# LANGUAGE NoImplicitPrelude #-}
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)
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 "'"
)
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
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
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
fromIntegralOverflowing :: (Integral a, Num b) => a -> b
fromIntegralOverflowing :: a -> b
fromIntegralOverflowing = a -> b
forall a b. (Integral a, Num b) => a -> b
Universum.fromIntegral
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