-- 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 = 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 = 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 = fromRational . (% 1) . 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 = 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 = do
  b <- tryFromIntegral a
  case compare (toInteger a) (toInteger b) of
    EQ -> Right b
    LT -> Left Underflow
    GT -> Left Overflow
  where
    tryFromIntegral x = unsafePerformIO $
      (let !y = Universum.fromIntegral x in pure (Right y))
      `catch` \case
        Overflow -> pure $ Left Overflow
        Underflow -> pure $ Left Underflow
        e -> throwM e