{-# LANGUAGE NoImplicitPrelude #-}
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)
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
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, 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
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