{-# LANGUAGE UndecidableInstances #-}

-- | Provides the 'Positive' type for enforcing a positive invariant.
--
-- @since 0.1
module Numeric.Data.Positive.Internal
  ( -- * Type
    Positive (MkPositive, UnsafePositive),

    -- * Creation
    unsafePositive,

    -- * Misc
    errMsg,
  )
where

import Control.DeepSeq (NFData)
import Data.Bifunctor (Bifunctor (bimap))
import Data.Bounds (UpperBounded (upperBound), UpperBoundless)
import Data.Kind (Type)
import Data.Text.Display (Display, ShowInstance (ShowInstance))
import GHC.Generics (Generic)
import GHC.Records (HasField (getField))
import GHC.Stack (HasCallStack)
import Language.Haskell.TH.Syntax (Lift)
import Numeric.Algebra.Additive.ASemigroup (ASemigroup ((.+.)))
import Numeric.Algebra.Multiplicative.MEuclidean (MEuclidean (mdivMod))
import Numeric.Algebra.Multiplicative.MGroup (MGroup ((.%.)))
import Numeric.Algebra.Multiplicative.MMonoid (MMonoid (one))
import Numeric.Algebra.Multiplicative.MSemigroup (MSemigroup ((.*.)))
import Numeric.Algebra.Normed (Normed (norm))
import Numeric.Class.Division (Division (divide))
import Numeric.Literal.Integer (FromInteger (afromInteger))
import Numeric.Literal.Rational (FromRational (afromRational))
import Optics.Core (A_Getter, LabelOptic (labelOptic), to)

-- $setup
-- >>> :set -XTemplateHaskell
-- >>> :set -XPostfixOperators

-- | Newtype wrapper that attaches a 'Positive' invariant to some @a@.
-- 'Positive' is an 'Numeric.Algebra.Additive.ASemigroup.ASemigroup' and
-- 'Numeric.Algebra.Multiplicative.MGroup.MGroup' i.e. supports addition,
-- multiplication, and division.
--
-- @since 0.1
type Positive :: Type -> Type
newtype Positive a = UnsafePositive a
  deriving stock
    ( -- | @since 0.1
      Positive a -> Positive a -> Bool
(Positive a -> Positive a -> Bool)
-> (Positive a -> Positive a -> Bool) -> Eq (Positive a)
forall a. Eq a => Positive a -> Positive a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Positive a -> Positive a -> Bool
== :: Positive a -> Positive a -> Bool
$c/= :: forall a. Eq a => Positive a -> Positive a -> Bool
/= :: Positive a -> Positive a -> Bool
Eq,
      -- | @since 0.1
      (forall x. Positive a -> Rep (Positive a) x)
-> (forall x. Rep (Positive a) x -> Positive a)
-> Generic (Positive a)
forall x. Rep (Positive a) x -> Positive a
forall x. Positive a -> Rep (Positive a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Positive a) x -> Positive a
forall a x. Positive a -> Rep (Positive a) x
$cfrom :: forall a x. Positive a -> Rep (Positive a) x
from :: forall x. Positive a -> Rep (Positive a) x
$cto :: forall a x. Rep (Positive a) x -> Positive a
to :: forall x. Rep (Positive a) x -> Positive a
Generic,
      -- | @since 0.1
      (forall (m :: Type -> Type). Quote m => Positive a -> m Exp)
-> (forall (m :: Type -> Type).
    Quote m =>
    Positive a -> Code m (Positive a))
-> Lift (Positive a)
forall a (m :: Type -> Type).
(Lift a, Quote m) =>
Positive a -> m Exp
forall a (m :: Type -> Type).
(Lift a, Quote m) =>
Positive a -> Code m (Positive a)
forall t.
(forall (m :: Type -> Type). Quote m => t -> m Exp)
-> (forall (m :: Type -> Type). Quote m => t -> Code m t) -> Lift t
forall (m :: Type -> Type). Quote m => Positive a -> m Exp
forall (m :: Type -> Type).
Quote m =>
Positive a -> Code m (Positive a)
$clift :: forall a (m :: Type -> Type).
(Lift a, Quote m) =>
Positive a -> m Exp
lift :: forall (m :: Type -> Type). Quote m => Positive a -> m Exp
$cliftTyped :: forall a (m :: Type -> Type).
(Lift a, Quote m) =>
Positive a -> Code m (Positive a)
liftTyped :: forall (m :: Type -> Type).
Quote m =>
Positive a -> Code m (Positive a)
Lift,
      -- | @since 0.1
      Eq (Positive a)
Eq (Positive a) =>
(Positive a -> Positive a -> Ordering)
-> (Positive a -> Positive a -> Bool)
-> (Positive a -> Positive a -> Bool)
-> (Positive a -> Positive a -> Bool)
-> (Positive a -> Positive a -> Bool)
-> (Positive a -> Positive a -> Positive a)
-> (Positive a -> Positive a -> Positive a)
-> Ord (Positive a)
Positive a -> Positive a -> Bool
Positive a -> Positive a -> Ordering
Positive a -> Positive a -> Positive a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Positive a)
forall a. Ord a => Positive a -> Positive a -> Bool
forall a. Ord a => Positive a -> Positive a -> Ordering
forall a. Ord a => Positive a -> Positive a -> Positive a
$ccompare :: forall a. Ord a => Positive a -> Positive a -> Ordering
compare :: Positive a -> Positive a -> Ordering
$c< :: forall a. Ord a => Positive a -> Positive a -> Bool
< :: Positive a -> Positive a -> Bool
$c<= :: forall a. Ord a => Positive a -> Positive a -> Bool
<= :: Positive a -> Positive a -> Bool
$c> :: forall a. Ord a => Positive a -> Positive a -> Bool
> :: Positive a -> Positive a -> Bool
$c>= :: forall a. Ord a => Positive a -> Positive a -> Bool
>= :: Positive a -> Positive a -> Bool
$cmax :: forall a. Ord a => Positive a -> Positive a -> Positive a
max :: Positive a -> Positive a -> Positive a
$cmin :: forall a. Ord a => Positive a -> Positive a -> Positive a
min :: Positive a -> Positive a -> Positive a
Ord,
      -- | @since 0.1
      Int -> Positive a -> ShowS
[Positive a] -> ShowS
Positive a -> String
(Int -> Positive a -> ShowS)
-> (Positive a -> String)
-> ([Positive a] -> ShowS)
-> Show (Positive a)
forall a. Show a => Int -> Positive a -> ShowS
forall a. Show a => [Positive a] -> ShowS
forall a. Show a => Positive a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Positive a -> ShowS
showsPrec :: Int -> Positive a -> ShowS
$cshow :: forall a. Show a => Positive a -> String
show :: Positive a -> String
$cshowList :: forall a. Show a => [Positive a] -> ShowS
showList :: [Positive a] -> ShowS
Show
    )
  deriving anyclass
    ( -- | @since 0.1
      Positive a -> ()
(Positive a -> ()) -> NFData (Positive a)
forall a. NFData a => Positive a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => Positive a -> ()
rnf :: Positive a -> ()
NFData,
      -- | @since 0.1
      UpperBoundless (Positive a)
forall a. UpperBoundless a
UpperBoundless
    )
  deriving
    ( -- | @since 0.1
      Int -> Positive a -> Builder
[Positive a] -> Builder
Positive a -> Builder
(Positive a -> Builder)
-> ([Positive a] -> Builder)
-> (Int -> Positive a -> Builder)
-> Display (Positive a)
forall a. Show a => Int -> Positive a -> Builder
forall a. Show a => [Positive a] -> Builder
forall a. Show a => Positive a -> Builder
forall a.
(a -> Builder)
-> ([a] -> Builder) -> (Int -> a -> Builder) -> Display a
$cdisplayBuilder :: forall a. Show a => Positive a -> Builder
displayBuilder :: Positive a -> Builder
$cdisplayList :: forall a. Show a => [Positive a] -> Builder
displayList :: [Positive a] -> Builder
$cdisplayPrec :: forall a. Show a => Int -> Positive a -> Builder
displayPrec :: Int -> Positive a -> Builder
Display
    )
    via (ShowInstance a)

-- | @since 0.1
instance HasField "unPositive" (Positive a) a where
  getField :: Positive a -> a
getField (UnsafePositive a
x) = a
x

-- | @since 0.1
instance
  ( k ~ A_Getter,
    x ~ a,
    y ~ a
  ) =>
  LabelOptic "unPositive" k (Positive a) (Positive a) x y
  where
  labelOptic :: Optic k NoIx (Positive a) (Positive a) x y
labelOptic = (Positive a -> x) -> Getter (Positive a) x
forall s a. (s -> a) -> Getter s a
to (\(UnsafePositive a
x) -> x
a
x)
  {-# INLINE labelOptic #-}

-- | Unidirectional pattern synonym for 'Positive'. This allows us to pattern
-- match on a positive term without exposing the unsafe internal details.
--
-- @since 0.1
pattern MkPositive :: a -> Positive a
pattern $mMkPositive :: forall {r} {a}. Positive a -> (a -> r) -> ((# #) -> r) -> r
MkPositive x <- UnsafePositive x

{-# COMPLETE MkPositive #-}

-- | @since 0.1
instance (Bounded a) => UpperBounded (Positive a) where
  upperBound :: Positive a
upperBound = a -> Positive a
forall a. a -> Positive a
UnsafePositive a
forall a. Bounded a => a
maxBound
  {-# INLINEABLE upperBound #-}

-- | @since 0.1
instance (Num a) => ASemigroup (Positive a) where
  UnsafePositive a
x .+. :: Positive a -> Positive a -> Positive a
.+. UnsafePositive a
y = a -> Positive a
forall a. a -> Positive a
UnsafePositive (a -> Positive a) -> a -> Positive a
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> a
forall a. Num a => a -> a -> a
+ a
y
  {-# INLINEABLE (.+.) #-}

-- | @since 0.1
instance (Num a) => MSemigroup (Positive a) where
  UnsafePositive a
x .*. :: Positive a -> Positive a -> Positive a
.*. UnsafePositive a
y = a -> Positive a
forall a. a -> Positive a
UnsafePositive (a -> Positive a) -> a -> Positive a
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
y
  {-# INLINEABLE (.*.) #-}

-- | @since 0.1
instance (Num a) => MMonoid (Positive a) where
  one :: Positive a
one = a -> Positive a
forall a. a -> Positive a
UnsafePositive a
1
  {-# INLINEABLE one #-}

-- | @since 0.1
instance (Division a, Num a) => MGroup (Positive a) where
  UnsafePositive a
x .%. :: Positive a -> Positive a -> Positive a
.%. (UnsafePositive a
d) = a -> Positive a
forall a. a -> Positive a
UnsafePositive (a -> Positive a) -> a -> Positive a
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> a
forall a. Division a => a -> a -> a
`divide` a
d
  {-# INLINEABLE (.%.) #-}

-- | @since 0.1
instance (Division a, Integral a) => MEuclidean (Positive a) where
  UnsafePositive a
x mdivMod :: Positive a -> Positive a -> (Positive a, Positive a)
`mdivMod` (UnsafePositive a
d) =
    (a -> Positive a)
-> (a -> Positive a) -> (a, a) -> (Positive a, Positive a)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: Type -> Type -> Type) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> Positive a
forall a. a -> Positive a
UnsafePositive a -> Positive a
forall a. a -> Positive a
UnsafePositive ((a, a) -> (Positive a, Positive a))
-> (a, a) -> (Positive a, Positive a)
forall a b. (a -> b) -> a -> b
$ a
x a -> a -> (a, a)
forall a. Integral a => a -> a -> (a, a)
`divMod` a
d
  {-# INLINEABLE mdivMod #-}

-- | @since 0.1
instance Normed (Positive a) where
  norm :: Positive a -> Positive a
norm = Positive a -> Positive a
forall a. a -> a
id
  {-# INLINEABLE norm #-}

-- | __WARNING: Partial__
--
-- @since 0.1
instance (Num a, Ord a, Show a) => FromInteger (Positive a) where
  afromInteger :: HasCallStack => Integer -> Positive a
afromInteger = a -> Positive a
forall a. (HasCallStack, Num a, Ord a, Show a) => a -> Positive a
unsafePositive (a -> Positive a) -> (Integer -> a) -> Integer -> Positive a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> a
forall a. Num a => Integer -> a
fromInteger
  {-# INLINEABLE afromInteger #-}

-- | __WARNING: Partial__
--
-- @since 0.1
instance (Fractional a, Ord a, Show a) => FromRational (Positive a) where
  afromRational :: HasCallStack => Rational -> Positive a
afromRational = a -> Positive a
forall a. (HasCallStack, Num a, Ord a, Show a) => a -> Positive a
unsafePositive (a -> Positive a) -> (Rational -> a) -> Rational -> Positive a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> a
forall a. Fractional a => Rational -> a
fromRational
  {-# INLINEABLE afromRational #-}

-- | Throws an error when given a value <= 0.
--
-- __WARNING: Partial__
--
-- ==== __Examples__
-- >>> unsafePositive 7
-- UnsafePositive 7
--
-- @since 0.1
unsafePositive :: (HasCallStack, Num a, Ord a, Show a) => a -> Positive a
unsafePositive :: forall a. (HasCallStack, Num a, Ord a, Show a) => a -> Positive a
unsafePositive a
x
  | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 = a -> Positive a
forall a. a -> Positive a
UnsafePositive a
x
  | Bool
otherwise =
      String -> Positive a
forall a. HasCallStack => String -> a
error (String -> Positive a) -> String -> Positive a
forall a b. (a -> b) -> a -> b
$
        String -> a -> String
forall a. Show a => String -> a -> String
errMsg String
"unsafePositive" a
x
{-# INLINEABLE unsafePositive #-}

-- | @since 0.1
errMsg :: (Show a) => String -> a -> String
errMsg :: forall a. Show a => String -> a -> String
errMsg String
fn a
x =
  [String] -> String
forall a. Monoid a => [a] -> a
mconcat
    [ String
"Numeric.Data.Positive.",
      String
fn,
      String
": Received value <= zero: ",
      a -> String
forall a. Show a => a -> String
show a
x
    ]