{-# OPTIONS_GHC -Wno-redundant-constraints #-}

-- | Provides the 'Fraction' type, a safer alternative to 'GHC.Real.Ratio'.
--
-- @since 0.1
module Numeric.Data.Fraction
  ( -- * Type
    Fraction ((:%:), (:%!)),

    -- * Creation
    mkFraction,
    mkFractionTH,
    (%%),
    Internal.unsafeFraction,
    (Internal.%!),

    -- * Elimination
    Internal.numerator,
    Internal.denominator,

    -- * Functions
    Internal.reduce,
    unsafeLiftFraction,
    unsafeLiftFraction2,
    unsafeLiftFraction3,

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

import Data.Bifunctor (Bifunctor (first))
import Data.Bounds
  ( UpperBoundless,
  )
import GHC.Stack.Types (HasCallStack)
import Language.Haskell.TH (Code, Q)
import Language.Haskell.TH.Syntax (Lift)
import Numeric.Algebra.Additive.AMonoid (pattern NonZero, pattern Zero)
import Numeric.Algebra.Multiplicative.MEuclidean (MEuclidean)
import Numeric.Algebra.Normed (Normed)
import Numeric.Algebra.Rings.Semiring (Semiring)
import Numeric.Data.Fraction.Internal
  ( Fraction
      ( UnsafeFraction,
        (:%!),
        (:%:)
      ),
  )
import Numeric.Data.Fraction.Internal qualified as Internal
import Numeric.Data.Internal.Utils (rmatching)
import Numeric.Data.Internal.Utils qualified as Utils
import Optics.Core
  ( ReversedPrism',
    ReversibleOptic (re),
    prism,
  )

-- $setup
-- >>> :set -XTemplateHaskell
-- >>> import Numeric.Data.Fraction.Internal ((%!))

-- | Template haskell for creating a 'Fraction' at compile-time.
--
-- ==== __Examples__
-- >>> $$(mkFractionTH 7 2)
-- UnsafeFraction 7 2
--
-- @since 0.1
mkFractionTH ::
  ( Lift a,
    MEuclidean a,
    Normed a,
    Ord a,
    Semiring a,
    UpperBoundless a
  ) =>
  a ->
  a ->
  Code Q (Fraction a)
mkFractionTH :: forall a.
(Lift a, MEuclidean a, Normed a, Ord a, Semiring a,
 UpperBoundless a) =>
a -> a -> Code Q (Fraction a)
mkFractionTH a
n = Either String (Fraction a) -> Code Q (Fraction a)
forall a. Lift a => Either String a -> Code Q a
Utils.liftErrorTH (Either String (Fraction a) -> Code Q (Fraction a))
-> (a -> Either String (Fraction a)) -> a -> Code Q (Fraction a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> Either String (Fraction a)
forall a.
(MEuclidean a, Normed a, Ord a, Semiring a, UpperBoundless a) =>
a -> a -> Either String (Fraction a)
mkFraction a
n
{-# INLINEABLE mkFractionTH #-}

-- | Smart constructor for 'Fraction'. Returns 'Nothing' if the second
-- parameter is 0. Reduces the fraction via 'reduce' if possible.
--
-- ==== __Examples__
-- >>> mkFraction 10 4
-- Right (UnsafeFraction 5 2)
--
-- >>> mkFraction 10 0
-- Left "Numeric.Data.Fraction: Fraction has zero denominator"
--
-- @since 0.1
mkFraction ::
  ( MEuclidean a,
    Normed a,
    Ord a,
    Semiring a,
    UpperBoundless a
  ) =>
  a ->
  a ->
  Either String (Fraction a)
mkFraction :: forall a.
(MEuclidean a, Normed a, Ord a, Semiring a, UpperBoundless a) =>
a -> a -> Either String (Fraction a)
mkFraction a
_ a
Zero = String -> Either String (Fraction a)
forall a b. a -> Either a b
Left String
Internal.errMsg
mkFraction a
n (NonZero a
d) = Fraction a -> Either String (Fraction a)
forall a b. b -> Either a b
Right (Fraction a -> Either String (Fraction a))
-> Fraction a -> Either String (Fraction a)
forall a b. (a -> b) -> a -> b
$ Fraction a -> Fraction a
forall a.
(MEuclidean a, Normed a, Ord a, Semiring a, UpperBoundless a) =>
Fraction a -> Fraction a
Internal.reduce (a -> a -> Fraction a
forall a. a -> a -> Fraction a
UnsafeFraction a
n a
d)
{-# INLINEABLE mkFraction #-}

-- | Infix version of 'mkFractionTH'.
--
-- ==== __Examples__
--
-- >>> $$(7 %% 2)
-- UnsafeFraction 7 2
--
-- @since 0.1
(%%) ::
  ( Lift a,
    MEuclidean a,
    Normed a,
    Ord a,
    Semiring a,
    UpperBoundless a
  ) =>
  a ->
  a ->
  Code Q (Fraction a)
a
n %% :: forall a.
(Lift a, MEuclidean a, Normed a, Ord a, Semiring a,
 UpperBoundless a) =>
a -> a -> Code Q (Fraction a)
%% a
d = a -> a -> Code Q (Fraction a)
forall a.
(Lift a, MEuclidean a, Normed a, Ord a, Semiring a,
 UpperBoundless a) =>
a -> a -> Code Q (Fraction a)
mkFractionTH a
n a
d
{-# INLINE (%%) #-}

infixl 7 %%

-- $optics
-- We provide a 'ReversedPrism'' '_MkFraction' that allows for total
-- elimination and partial construction, along with 'Optics.Core.LabelOptic' instances for
-- "numerator" and "denominator".
--
-- ==== __Examples__
--
-- >>> :set -XOverloadedLabels
-- >>> import Optics.Core (set, view)
-- >>> let x = 2 %! 7
-- >>> view #numerator x
-- 2
--
-- >>> set #numerator 5 x
-- UnsafeFraction 5 7
--
-- >>> view #denominator x
-- 7

-- | 'ReversedPrism'' that enables total elimination and partial construction.
--
-- ==== __Examples__
-- >>> import Optics.Core (view)
-- >>> f = $$(2 %% 8)
-- >>> view _MkFraction f
-- (1,4)
--
-- >>> rmatching _MkFraction (0, 4)
-- Right (UnsafeFraction 0 1)
--
-- >>> rmatching _MkFraction (1, 0)
-- Left (1,0)
--
-- @since 0.1
_MkFraction ::
  ( MEuclidean a,
    Normed a,
    Ord a,
    Semiring a,
    UpperBoundless a
  ) =>
  ReversedPrism' (Fraction a) (a, a)
_MkFraction :: forall a.
(MEuclidean a, Normed a, Ord a, Semiring a, UpperBoundless a) =>
ReversedPrism' (Fraction a) (a, a)
_MkFraction = Optic A_Prism NoIx (a, a) (a, a) (Fraction a) (Fraction a)
-> Optic
     (ReversedOptic A_Prism)
     NoIx
     (Fraction a)
     (Fraction a)
     (a, 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 ((Fraction a -> (a, a))
-> ((a, a) -> Either (a, a) (Fraction a))
-> Optic A_Prism NoIx (a, a) (a, a) (Fraction a) (Fraction a)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism (\(UnsafeFraction a
n a
d) -> (a
n, a
d)) (a, a) -> Either (a, a) (Fraction a)
forall {b}.
(MEuclidean b, Normed b, Ord b, Semiring b, UpperBoundless b) =>
(b, b) -> Either (b, b) (Fraction b)
g)
  where
    g :: (b, b) -> Either (b, b) (Fraction b)
g (b, b)
x = (String -> (b, b))
-> Either String (Fraction b) -> Either (b, b) (Fraction b)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((b, b) -> String -> (b, b)
forall a b. a -> b -> a
const (b, b)
x) (Either String (Fraction b) -> Either (b, b) (Fraction b))
-> ((b, b) -> Either String (Fraction b))
-> (b, b)
-> Either (b, b) (Fraction b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> b -> Either String (Fraction b))
-> (b, b) -> Either String (Fraction b)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry b -> b -> Either String (Fraction b)
forall a.
(MEuclidean a, Normed a, Ord a, Semiring a, UpperBoundless a) =>
a -> a -> Either String (Fraction a)
mkFraction ((b, b) -> Either (b, b) (Fraction b))
-> (b, b) -> Either (b, b) (Fraction b)
forall a b. (a -> b) -> a -> b
$ (b, b)
x
{-# INLINEABLE _MkFraction #-}

-- | Lifts an unsafe unary function onto a 'Fraction'.
--
-- @since 0.1
unsafeLiftFraction ::
  ( HasCallStack,
    MEuclidean b,
    Normed b,
    Ord b,
    Semiring b,
    UpperBoundless b
  ) =>
  ((a, a) -> (b, b)) ->
  Fraction a ->
  Fraction b
unsafeLiftFraction :: forall b a.
(HasCallStack, MEuclidean b, Normed b, Ord b, Semiring b,
 UpperBoundless b) =>
((a, a) -> (b, b)) -> Fraction a -> Fraction b
unsafeLiftFraction (a, a) -> (b, b)
f (UnsafeFraction a
n a
d) =
  let (b
n2, b
d2) = (a, a) -> (b, b)
f (a
n, a
d)
   in b -> b -> Fraction b
forall a.
(HasCallStack, MEuclidean a, Normed a, Ord a, Semiring a,
 UpperBoundless a) =>
a -> a -> Fraction a
Internal.unsafeFraction b
n2 b
d2
{-# INLINEABLE unsafeLiftFraction #-}

-- | Lifts an unsafe binary function onto a 'Fraction'.
--
-- @since 0.1
unsafeLiftFraction2 ::
  ( HasCallStack,
    MEuclidean c,
    Normed c,
    Ord c,
    Semiring c,
    UpperBoundless c
  ) =>
  ((a, a) -> (b, b) -> (c, c)) ->
  Fraction a ->
  Fraction b ->
  Fraction c
unsafeLiftFraction2 :: forall c a b.
(HasCallStack, MEuclidean c, Normed c, Ord c, Semiring c,
 UpperBoundless c) =>
((a, a) -> (b, b) -> (c, c))
-> Fraction a -> Fraction b -> Fraction c
unsafeLiftFraction2 (a, a) -> (b, b) -> (c, c)
f (UnsafeFraction a
n1 a
d1) (UnsafeFraction b
n2 b
d2) =
  let (c
n3, c
d3) = (a, a) -> (b, b) -> (c, c)
f (a
n1, a
d1) (b
n2, b
d2)
   in c -> c -> Fraction c
forall a.
(HasCallStack, MEuclidean a, Normed a, Ord a, Semiring a,
 UpperBoundless a) =>
a -> a -> Fraction a
Internal.unsafeFraction c
n3 c
d3
{-# INLINEABLE unsafeLiftFraction2 #-}

-- | Lifts an unsafe 3-ary function onto a 'Fraction'.
--
-- @since 0.1
unsafeLiftFraction3 ::
  ( HasCallStack,
    MEuclidean d,
    Normed d,
    Ord d,
    Semiring d,
    UpperBoundless d
  ) =>
  ((a, a) -> (b, b) -> (c, c) -> (d, d)) ->
  Fraction a ->
  Fraction b ->
  Fraction c ->
  Fraction d
unsafeLiftFraction3 :: forall d a b c.
(HasCallStack, MEuclidean d, Normed d, Ord d, Semiring d,
 UpperBoundless d) =>
((a, a) -> (b, b) -> (c, c) -> (d, d))
-> Fraction a -> Fraction b -> Fraction c -> Fraction d
unsafeLiftFraction3 (a, a) -> (b, b) -> (c, c) -> (d, d)
f (UnsafeFraction a
n1 a
d1) (UnsafeFraction b
n2 b
d2) (UnsafeFraction c
n3 c
d3) =
  let (d
n4, d
d4) = (a, a) -> (b, b) -> (c, c) -> (d, d)
f (a
n1, a
d1) (b
n2, b
d2) (c
n3, c
d3)
   in d -> d -> Fraction d
forall a.
(HasCallStack, MEuclidean a, Normed a, Ord a, Semiring a,
 UpperBoundless a) =>
a -> a -> Fraction a
Internal.unsafeFraction d
n4 d
d4
{-# INLINEABLE unsafeLiftFraction3 #-}