{-# 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
  ( MaybeLowerBounded (maybeLowerBound),
    MaybeUpperBounded (maybeUpperBound),
    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 (AMonoid)
import Numeric.Algebra.Additive.AMonoid (AMonoid (zero))
import Numeric.Algebra.Additive.ASemigroup (ASemigroup ((.+.)))
import Numeric.Algebra.MetricSpace (MetricSpace (diffR))
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, sgn))
import Numeric.Convert.Integer (FromInteger (fromZ), ToInteger (toZ))
import Numeric.Convert.Rational (FromRational (fromQ), ToRational (toQ))
import Numeric.Convert.Real (FromReal (fromR), ToReal (toR))
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 (UpperBounded a) => UpperBounded (Positive a) where
  upperBound :: Positive a
upperBound = a -> Positive a
forall a. a -> Positive a
UnsafePositive a
forall a. UpperBounded a => a
upperBound
  {-# INLINEABLE upperBound #-}

-- | @since 0.1
instance MaybeLowerBounded (Positive a) where
  maybeLowerBound :: Maybe (Positive a)
maybeLowerBound = Maybe (Positive a)
forall a. Maybe a
Nothing
  {-# INLINEABLE maybeLowerBound #-}

-- | @since 0.1
instance (MaybeUpperBounded a) => MaybeUpperBounded (Positive a) where
  maybeUpperBound :: Maybe (Positive a)
maybeUpperBound = a -> Positive a
forall a. a -> Positive a
UnsafePositive (a -> Positive a) -> Maybe a -> Maybe (Positive a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
forall a. MaybeUpperBounded a => Maybe a
maybeUpperBound
  {-# INLINEABLE maybeUpperBound #-}

-- | @since 0.1
instance (ASemigroup a) => ASemigroup (Positive a) where
  .+. :: Positive a -> Positive a -> Positive a
(.+.) = (a -> a -> a) -> Positive a -> Positive a -> Positive a
forall a. (a -> a -> a) -> Positive a -> Positive a -> Positive a
liftPositive2 a -> a -> a
forall s. ASemigroup s => s -> s -> s
(.+.)
  {-# INLINEABLE (.+.) #-}

-- | @since 0.1
instance (MSemigroup a) => MSemigroup (Positive a) where
  .*. :: Positive a -> Positive a -> Positive a
(.*.) = (a -> a -> a) -> Positive a -> Positive a -> Positive a
forall a. (a -> a -> a) -> Positive a -> Positive a -> Positive a
liftPositive2 a -> a -> a
forall s. MSemigroup s => s -> s -> s
(.*.)
  {-# INLINEABLE (.*.) #-}

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

-- | @since 0.1
instance (MGroup a) => MGroup (Positive a) where
  .%. :: Positive a -> Positive a -> Positive a
(.%.) = (a -> a -> a) -> Positive a -> Positive a -> Positive a
forall a. (a -> a -> a) -> Positive a -> Positive a -> Positive a
liftPositive2 a -> a -> a
forall g. MGroup g => g -> g -> g
(.%.)
  {-# INLINEABLE (.%.) #-}

-- | @since 0.1
instance (MEuclidean 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 g. MEuclidean g => g -> g -> (g, g)
`mdivMod` a
d
  {-# INLINEABLE mdivMod #-}

-- | @since 0.1
instance (MetricSpace a) => MetricSpace (Positive a) where
  diffR :: Positive a -> Positive a -> Double
diffR = (a -> a -> Double) -> Positive a -> Positive a -> Double
forall a r. (a -> a -> r) -> Positive a -> Positive a -> r
applyPositive2 a -> a -> Double
forall s. MetricSpace s => s -> s -> Double
diffR
  {-# INLINEABLE diffR #-}

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

  sgn :: Positive a -> Positive a
sgn (UnsafePositive a
x) = a -> Positive a
forall a. a -> Positive a
UnsafePositive (a -> Positive a) -> a -> Positive a
forall a b. (a -> b) -> a -> b
$ a -> a
forall s. Normed s => s -> s
sgn a
x
  {-# INLINEABLE sgn #-}

-- | __WARNING: Partial__
--
-- @since 0.1
instance (AMonoid a, FromInteger a, Ord a, Show a) => FromInteger (Positive a) where
  fromZ :: HasCallStack => Integer -> Positive a
fromZ = a -> Positive a
forall a.
(AMonoid a, HasCallStack, 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. (FromInteger a, HasCallStack) => Integer -> a
fromZ
  {-# INLINEABLE fromZ #-}

-- | @since 0.1
instance (ToInteger a) => ToInteger (Positive a) where
  toZ :: HasCallStack => Positive a -> Integer
toZ (UnsafePositive a
x) = a -> Integer
forall a. (ToInteger a, HasCallStack) => a -> Integer
toZ a
x
  {-# INLINEABLE toZ #-}

-- | __WARNING: Partial__
--
-- @since 0.1
instance (AMonoid a, FromRational a, Ord a, Show a) => FromRational (Positive a) where
  fromQ :: HasCallStack => Rational -> Positive a
fromQ = a -> Positive a
forall a.
(AMonoid a, HasCallStack, 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. (FromRational a, HasCallStack) => Rational -> a
fromQ
  {-# INLINEABLE fromQ #-}

-- | @since 0.1
instance (ToRational a) => ToRational (Positive a) where
  toQ :: HasCallStack => Positive a -> Rational
toQ (UnsafePositive a
x) = a -> Rational
forall a. (ToRational a, HasCallStack) => a -> Rational
toQ a
x
  {-# INLINEABLE toQ #-}

-- | __WARNING: Partial__
--
-- @since 0.1
instance (AMonoid a, FromReal a, Ord a, Show a) => FromReal (Positive a) where
  fromR :: HasCallStack => Double -> Positive a
fromR = a -> Positive a
forall a.
(AMonoid a, HasCallStack, Ord a, Show a) =>
a -> Positive a
unsafePositive (a -> Positive a) -> (Double -> a) -> Double -> Positive a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> a
forall a. (FromReal a, HasCallStack) => Double -> a
fromR
  {-# INLINEABLE fromR #-}

-- | @since 0.1
instance (ToReal a) => ToReal (Positive a) where
  toR :: HasCallStack => Positive a -> Double
toR (UnsafePositive a
x) = a -> Double
forall a. (ToReal a, HasCallStack) => a -> Double
toR a
x
  {-# INLINEABLE toR #-}

-- | Throws an error when given a value <= 0.
--
-- __WARNING: Partial__
--
-- ==== __Examples__
-- >>> unsafePositive 7
-- UnsafePositive 7
--
-- @since 0.1
unsafePositive :: (AMonoid a, HasCallStack, Ord a, Show a) => a -> Positive a
unsafePositive :: forall a.
(AMonoid a, HasCallStack, Ord a, Show a) =>
a -> Positive a
unsafePositive a
x
  | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
forall m. AMonoid m => m
zero = 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
    ]

liftPositive2 ::
  forall a.
  (a -> a -> a) ->
  Positive a ->
  Positive a ->
  Positive a
liftPositive2 :: forall a. (a -> a -> a) -> Positive a -> Positive a -> Positive a
liftPositive2 a -> a -> a
f Positive a
x = a -> Positive a
forall a. a -> Positive a
UnsafePositive (a -> Positive a) -> (Positive a -> a) -> Positive a -> Positive a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a) -> Positive a -> Positive a -> a
forall a r. (a -> a -> r) -> Positive a -> Positive a -> r
applyPositive2 a -> a -> a
f Positive a
x

applyPositive2 ::
  (a -> a -> r) ->
  Positive a ->
  Positive a ->
  r
applyPositive2 :: forall a r. (a -> a -> r) -> Positive a -> Positive a -> r
applyPositive2 a -> a -> r
f (UnsafePositive a
x) (UnsafePositive a
y) = a -> a -> r
f a
x a
y