-- | 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.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 :: (Integral a, Lift a, Show a) => a -> Code Q (Positive a)
mkPositiveTH :: forall a. (Integral a, Lift 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. (Num 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 :: (Num a, Ord a) => a -> Maybe (Positive a)
mkPositive :: forall a. (Num a, Ord a) => a -> Maybe (Positive a)
mkPositive a
x
  | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 = 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
(+!) :: (HasCallStack, Num a, Ord a, Show a) => a -> Positive a
+! :: forall a. (HasCallStack, Num a, Ord a, Show a) => a -> Positive a
(+!) = a -> Positive a
forall a. (HasCallStack, Num a, 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 :: (Num a, Ord a) => ReversedPrism' (Positive a) a
_MkPositive :: forall a. (Num 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}. (Num 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. (Num 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 #-}