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

    -- * Creation
    mkPositiveTH,
    mkPositive,
    Internal.unsafePositive,
    (+!),
    reallyUnsafePositive,

    -- * Elimination
    unPositive,

    -- * Functions
    positiveToNonZero,

    -- * Optics
    -- $optics
    _MkPositive,
    rmatching,
  )
where

import GHC.Stack (HasCallStack)
import Language.Haskell.TH (Code, Q)
import Language.Haskell.TH.Syntax (Lift (liftTyped))
import Numeric.Algebra.Additive.AMonoid (AMonoid (zero))
import Numeric.Data.NonZero (NonZero, reallyUnsafeNonZero, rmatching)
import Numeric.Data.Positive.Internal (Positive (MkPositive, UnsafePositive))
import Numeric.Data.Positive.Internal qualified as Internal
import Optics.Core
  ( ReversedPrism',
    ReversibleOptic (re),
    prism,
  )

-- $setup
-- >>> :set -XTemplateHaskell
-- >>> :set -XPostfixOperators
-- >>> import Numeric.Data.Positive.Internal (unsafePositive)

-- | Template haskell for creating a 'Positive' at compile-time.
--
-- ==== __Examples__
-- >>> $$(mkPositiveTH 1)
-- UnsafePositive 1
--
-- @since 0.1
mkPositiveTH :: (AMonoid a, Lift a, Ord a, Show a) => a -> Code Q (Positive a)
mkPositiveTH :: forall a.
(AMonoid a, Lift a, Ord a, Show a) =>
a -> Code Q (Positive a)
mkPositiveTH a
x = Code Q (Positive a)
-> (Positive a -> Code Q (Positive a))
-> Maybe (Positive a)
-> Code Q (Positive a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Code Q (Positive a)
forall a. HasCallStack => [Char] -> a
error [Char]
err) Positive a -> Code Q (Positive a)
forall t (m :: Type -> Type). (Lift t, Quote m) => t -> Code m t
forall (m :: Type -> Type).
Quote m =>
Positive a -> Code m (Positive a)
liftTyped (Maybe (Positive a) -> Code Q (Positive a))
-> Maybe (Positive a) -> Code Q (Positive a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe (Positive a)
forall a. (AMonoid a, Ord a) => a -> Maybe (Positive a)
mkPositive a
x
  where
    err :: [Char]
err = [Char] -> a -> [Char]
forall a. Show a => [Char] -> a -> [Char]
Internal.errMsg [Char]
"mkPositiveTH" a
x
{-# INLINEABLE mkPositiveTH #-}

-- | Smart constructor for 'Positive'. Returns 'Nothing' if the second
-- parameter is @<= 0@.
--
-- ==== __Examples__
-- >>> mkPositive 7
-- Just (UnsafePositive 7)
--
-- >>> mkPositive 0
-- Nothing
--
-- @since 0.1
mkPositive :: (AMonoid a, Ord a) => a -> Maybe (Positive a)
mkPositive :: forall a. (AMonoid a, Ord a) => a -> Maybe (Positive a)
mkPositive a
x
  | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
forall m. AMonoid m => m
zero = Positive a -> Maybe (Positive a)
forall a. a -> Maybe a
Just (a -> Positive a
forall a. a -> Positive a
UnsafePositive a
x)
  | Bool
otherwise = Maybe (Positive a)
forall a. Maybe a
Nothing
{-# INLINEABLE mkPositive #-}

-- | Postfix operator for 'Internal.unsafePositive'.
--
-- __WARNING: Partial__
--
-- ==== __Examples__
--
-- >>> (7 +!)
-- UnsafePositive 7
--
-- @since 0.1
(+!) :: (AMonoid a, HasCallStack, Ord a, Show a) => a -> Positive a
+! :: forall a.
(AMonoid a, HasCallStack, Ord a, Show a) =>
a -> Positive a
(+!) = a -> Positive a
forall a.
(AMonoid a, HasCallStack, Ord a, Show a) =>
a -> Positive a
Internal.unsafePositive
{-# INLINE (+!) #-}

infixl 7 +!

-- | This function is an alias for the unchecked constructor @UnsafePositive@
-- i.e. it allows us to construct a 'Positive' __without__ checking the
-- invariant. This is intended only for when we absolutely know the invariant
-- holds and a branch (i.e. 'Internal.unsafePositive') is undesirable for
-- performance reasons. Exercise extreme caution.
--
-- @since 0.1
reallyUnsafePositive :: a -> Positive a
reallyUnsafePositive :: forall a. a -> Positive a
reallyUnsafePositive = a -> Positive a
forall a. a -> Positive a
UnsafePositive
{-# INLINEABLE reallyUnsafePositive #-}

-- | Convenience function for adding a 'NonZero' proof to our 'Positive'.
--
-- ==== __Examples__
-- >>> positiveToNonZero $ unsafePositive 3
-- UnsafeNonZero (UnsafePositive 3)
--
-- @since 0.1
positiveToNonZero :: Positive a -> NonZero (Positive a)
positiveToNonZero :: forall a. Positive a -> NonZero (Positive a)
positiveToNonZero = Positive a -> NonZero (Positive a)
forall a. a -> NonZero a
reallyUnsafeNonZero
{-# INLINEABLE positiveToNonZero #-}

-- | @since 0.1
unPositive :: Positive a -> a
unPositive :: forall a. Positive a -> a
unPositive (UnsafePositive a
x) = a
x
{-# INLINE unPositive #-}

-- $optics
-- We provide a 'ReversedPrism'' '_MkPositive' that allows for total
-- elimination and partial construction, along with a 'Optics.Core.LabelOptic' 'Optics.Core.Getter'
-- for @#unPositive@.
--
-- ==== __Examples__
--
-- >>> :set -XOverloadedLabels
-- >>> import Optics.Core (view)
-- >>> let n = $$(mkPositiveTH 2)
-- >>> view #unPositive n
-- 2

-- | 'ReversedPrism'' that enables total elimination and partial construction.
--
-- ==== __Examples__
-- >>> import Optics.Core (view)
-- >>> pos = $$(mkPositiveTH 2)
-- >>> view _MkPositive pos
-- 2
--
-- >>> rmatching _MkPositive 3
-- Right (UnsafePositive 3)
--
-- >>> rmatching _MkPositive 0
-- Left 0
--
-- @since 0.1
_MkPositive :: (AMonoid a, Ord a) => ReversedPrism' (Positive a) a
_MkPositive :: forall a. (AMonoid a, Ord a) => ReversedPrism' (Positive a) a
_MkPositive = Optic A_Prism NoIx a a (Positive a) (Positive a)
-> Optic (ReversedOptic A_Prism) NoIx (Positive a) (Positive a) a a
forall (is :: IxList) s t a b.
AcceptsEmptyIndices "re" is =>
Optic A_Prism is s t a b
-> Optic (ReversedOptic A_Prism) is b a t s
forall k (is :: IxList) s t a b.
(ReversibleOptic k, AcceptsEmptyIndices "re" is) =>
Optic k is s t a b -> Optic (ReversedOptic k) is b a t s
re ((Positive a -> a)
-> (a -> Either a (Positive a))
-> Optic A_Prism NoIx a a (Positive a) (Positive a)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism Positive a -> a
forall a. Positive a -> a
unPositive a -> Either a (Positive a)
forall {a}. (AMonoid a, Ord a) => a -> Either a (Positive a)
g)
  where
    g :: a -> Either a (Positive a)
g a
x = case a -> Maybe (Positive a)
forall a. (AMonoid a, Ord a) => a -> Maybe (Positive a)
mkPositive a
x of
      Maybe (Positive a)
Nothing -> a -> Either a (Positive a)
forall a b. a -> Either a b
Left a
x
      Just Positive a
x' -> Positive a -> Either a (Positive a)
forall a b. b -> Either a b
Right Positive a
x'
{-# INLINEABLE _MkPositive #-}