{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

module Plutarch.Extra.Fixed (
  PFixed (..),
  DivideSemigroup (..),
  DivideMonoid (..),
  fixedToAdaValue,
  fromPInteger,
  toPInteger,
) where

import Control.Composition (on, (.*))
import Data.Bifunctor (first)
import Data.Proxy (Proxy (Proxy))
import GHC.TypeLits (KnownNat, Nat, natVal)
import Plutarch.Api.V1 (AmountGuarantees (NonZero), PValue)
import Plutarch.Api.V1.Value qualified as Value
import Plutarch.Api.V2 (KeyGuarantees (Sorted))
import Plutarch.Extra.Function (pflip)
import Plutarch.Num (PNum (pfromInteger, (#*)))
import Plutarch.Numeric.Additive qualified as A (
  AdditiveMonoid (zero),
  AdditiveSemigroup ((+)),
 )
import Plutarch.TryFrom (PTryFrom (PTryFromExcess, ptryFrom'))
import Plutarch.Unsafe (punsafeCoerce)

{- | Fixed width decimal. Denominator will be given through typelit `unit`.
 This would be used for representing Ada value with some Lovelace changes.

 @since 3.12.0
-}
{-# DEPRECATED PFixed "Use PFixedDecimal instead" #-}

newtype PFixed (unit :: Nat) (s :: S)
  = PFixed (Term s PInteger)
  deriving stock
    ( -- | @since 3.12.0
      forall (unit :: Nat) (s :: S) x.
Rep (PFixed unit s) x -> PFixed unit s
forall (unit :: Nat) (s :: S) x.
PFixed unit s -> Rep (PFixed unit s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall (unit :: Nat) (s :: S) x.
Rep (PFixed unit s) x -> PFixed unit s
$cfrom :: forall (unit :: Nat) (s :: S) x.
PFixed unit s -> Rep (PFixed unit s) x
Generic
    )
  deriving anyclass
    ( -- | @since 3.12.0
      forall (unit :: Nat) (s :: S).
PFixed unit s -> Term s (PInner (PFixed unit))
forall (unit :: Nat) (s :: S) (b :: PType).
Term s (PInner (PFixed unit))
-> (PFixed unit s -> Term s b) -> Term s b
forall (a :: PType).
(forall (s :: S). a s -> Term s (PInner a))
-> (forall (s :: S) (b :: PType).
    Term s (PInner a) -> (a s -> Term s b) -> Term s b)
-> PlutusType a
pmatch' :: forall (s :: S) (b :: PType).
Term s (PInner (PFixed unit))
-> (PFixed unit s -> Term s b) -> Term s b
$cpmatch' :: forall (unit :: Nat) (s :: S) (b :: PType).
Term s (PInner (PFixed unit))
-> (PFixed unit s -> Term s b) -> Term s b
pcon' :: forall (s :: S). PFixed unit s -> Term s (PInner (PFixed unit))
$cpcon' :: forall (unit :: Nat) (s :: S).
PFixed unit s -> Term s (PInner (PFixed unit))
PlutusType
    , -- | @since 3.12.0
      forall (unit :: Nat) (s :: S).
Term s (PAsData (PFixed unit)) -> Term s (PFixed unit)
forall (unit :: Nat) (s :: S). Term s (PFixed unit) -> Term s PData
forall (a :: PType).
(forall (s :: S). Term s (PAsData a) -> Term s a)
-> (forall (s :: S). Term s a -> Term s PData) -> PIsData a
pdataImpl :: forall (s :: S). Term s (PFixed unit) -> Term s PData
$cpdataImpl :: forall (unit :: Nat) (s :: S). Term s (PFixed unit) -> Term s PData
pfromDataImpl :: forall (s :: S).
Term s (PAsData (PFixed unit)) -> Term s (PFixed unit)
$cpfromDataImpl :: forall (unit :: Nat) (s :: S).
Term s (PAsData (PFixed unit)) -> Term s (PFixed unit)
PIsData
    , -- | @since 3.12.0
      forall (unit :: Nat) (s :: S).
Term s (PFixed unit) -> Term s (PFixed unit) -> Term s PBool
forall (t :: PType).
(forall (s :: S). Term s t -> Term s t -> Term s PBool) -> PEq t
#== :: forall (s :: S).
Term s (PFixed unit) -> Term s (PFixed unit) -> Term s PBool
$c#== :: forall (unit :: Nat) (s :: S).
Term s (PFixed unit) -> Term s (PFixed unit) -> Term s PBool
PEq
    , -- | @since 3.12.0
      forall (unit :: Nat). PEq (PFixed unit)
forall (unit :: Nat) (s :: S).
Term s (PFixed unit) -> Term s (PFixed unit) -> Term s PBool
forall (t :: PType).
PEq t
-> (forall (s :: S). Term s t -> Term s t -> Term s PBool)
-> (forall (s :: S). Term s t -> Term s t -> Term s PBool)
-> PPartialOrd t
#< :: forall (s :: S).
Term s (PFixed unit) -> Term s (PFixed unit) -> Term s PBool
$c#< :: forall (unit :: Nat) (s :: S).
Term s (PFixed unit) -> Term s (PFixed unit) -> Term s PBool
#<= :: forall (s :: S).
Term s (PFixed unit) -> Term s (PFixed unit) -> Term s PBool
$c#<= :: forall (unit :: Nat) (s :: S).
Term s (PFixed unit) -> Term s (PFixed unit) -> Term s PBool
PPartialOrd
    , -- | @since 3.12.0
      forall (unit :: Nat). PPartialOrd (PFixed unit)
forall (t :: PType). PPartialOrd t -> POrd t
POrd
    , -- | @since 3.12.0
      forall (unit :: Nat) (s :: S).
Bool -> Term s (PFixed unit) -> Term s PString
forall (t :: PType).
(forall (s :: S). Bool -> Term s t -> Term s PString) -> PShow t
pshow' :: forall (s :: S). Bool -> Term s (PFixed unit) -> Term s PString
$cpshow' :: forall (unit :: Nat) (s :: S).
Bool -> Term s (PFixed unit) -> Term s PString
PShow
    )

-- | @since 3.12.0
instance DerivePlutusType (PFixed a) where
  type DPTStrat _ = PlutusTypeNewtype

-- | @since 3.12.0
instance KnownNat u => PNum (PFixed u) where
  #* :: forall (s :: S).
Term s (PFixed u) -> Term s (PFixed u) -> Term s (PFixed u)
(#*) =
    (forall (a :: PType) (s :: S). PlutusType a => a s -> Term s a
pcon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (unit :: Nat) (s :: S). Term s PInteger -> PFixed unit s
PFixed)
      forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* (forall (a :: PType) (b :: PType) (c :: PType) (s :: S).
Term s ((a :--> (b :--> c)) :--> (b :--> (a :--> c)))
pflip forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (a :: PType) (s :: S).
PIntegral a =>
Term s (a :--> (a :--> a))
pdiv forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @u)) forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
#)
      forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* forall (a :: PType) (s :: S).
PNum a =>
Term s a -> Term s a -> Term s a
(#*)
      forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall (s :: S) (a :: PType) (b :: PType). Term s a -> Term s b
punsafeCoerce
  pfromInteger :: forall (s :: S). Integer -> Term s (PFixed u)
pfromInteger = forall (a :: PType) (s :: S). PlutusType a => a s -> Term s a
pcon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (unit :: Nat) (s :: S). Term s PInteger -> PFixed unit s
PFixed forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @u))) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant

-- | @since 3.12.0
instance PTryFrom PData (PAsData (PFixed unit)) where
  type PTryFromExcess PData (PAsData (PFixed unit)) = PTryFromExcess PData (PAsData PInteger)
  ptryFrom' :: forall (s :: S) (r :: PType).
Term s PData
-> ((Term s (PAsData (PFixed unit)),
     Reduce (PTryFromExcess PData (PAsData (PFixed unit)) s))
    -> Term s r)
-> Term s r
ptryFrom' Term s PData
d (Term s (PAsData (PFixed unit)),
 Reduce (PTryFromExcess PData (PAsData (PFixed unit)) s))
-> Term s r
k = forall (a :: PType) (b :: PType) (s :: S) (r :: PType).
PTryFrom a b =>
Term s a
-> ((Term s b, Reduce (PTryFromExcess a b s)) -> Term s r)
-> Term s r
ptryFrom' @_ @(PAsData PInteger) Term s PData
d forall a b. (a -> b) -> a -> b
$ (Term s (PAsData (PFixed unit)),
 Reduce (PTryFromExcess PData (PAsData (PFixed unit)) s))
-> Term s r
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall (s :: S) (a :: PType) (b :: PType). Term s a -> Term s b
punsafeCoerce

-- TODO: This should be moved to either to plutarch-numeric or other module
class DivideSemigroup a where
  divide :: a -> a -> a

class DivideSemigroup a => DivideMonoid a where
  one :: a

-- | @since 3.12.0
instance KnownNat u => DivideSemigroup (Term s (PFixed u)) where
  divide :: Term s (PFixed u) -> Term s (PFixed u) -> Term s (PFixed u)
divide (forall (s :: S) (a :: PType). Term s a -> Term s (PInner a)
pto -> Term s (PInner (PFixed u))
x) (forall (s :: S) (a :: PType). Term s a -> Term s (PInner a)
pto -> Term s (PInner (PFixed u))
y) =
    forall (a :: PType) (s :: S). PlutusType a => a s -> Term s a
pcon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (unit :: Nat) (s :: S). Term s PInteger -> PFixed unit s
PFixed forall a b. (a -> b) -> a -> b
$ forall (a :: PType) (s :: S).
PIntegral a =>
Term s (a :--> (a :--> a))
pdiv forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# (Term s (PInner (PFixed u))
x forall a. Num a => a -> a -> a
* forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @u))) forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s (PInner (PFixed u))
y

-- | @since 3.12.0
instance KnownNat u => DivideMonoid (Term s (PFixed u)) where
  one :: Term s (PFixed u)
one = Term s (PFixed u)
1

-- | @since 3.12.0
instance KnownNat u => A.AdditiveSemigroup (Term s (PFixed u)) where
  + :: Term s (PFixed u) -> Term s (PFixed u) -> Term s (PFixed u)
(+) = forall a. Num a => a -> a -> a
(+)

-- | @since 3.12.0
instance KnownNat u => A.AdditiveMonoid (Term s (PFixed u)) where
  zero :: Term s (PFixed u)
zero = forall (a :: PType) (s :: S). PlutusType a => a s -> Term s a
pcon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (unit :: Nat) (s :: S). Term s PInteger -> PFixed unit s
PFixed forall a b. (a -> b) -> a -> b
$ forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant Integer
0

{- | Convert given fixed into Ada value. Input should be Ada value with decimals; outputs
 will be lovelace values in integer.

 @since 3.9.0
-}
fixedToAdaValue ::
  forall (s :: S) (unit :: Nat).
  KnownNat unit =>
  Term s (PFixed unit :--> PValue 'Sorted 'NonZero)
fixedToAdaValue :: forall (s :: S) (unit :: Nat).
KnownNat unit =>
Term s (PFixed unit :--> PValue 'Sorted 'NonZero)
fixedToAdaValue =
  forall (a :: PType) (s :: S).
HasCallStack =>
ClosedTerm a -> Term s a
phoistAcyclic forall a b. (a -> b) -> a -> b
$
    forall a (b :: PType) (s :: S) (c :: PType).
(PLamN a b s, HasCallStack) =>
(Term s c -> a) -> Term s (c :--> b)
plam forall a b. (a -> b) -> a -> b
$ \(forall (s :: S) (a :: PType). Term s a -> Term s (PInner a)
pto -> Term s (PInner (PFixed unit))
dec) ->
      let adaValue :: Term s PInteger
adaValue = (forall (a :: PType) (s :: S).
PIntegral a =>
Term s (a :--> (a :--> a))
pdiv forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s (PInner (PFixed unit))
dec forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @unit))) forall a. Num a => a -> a -> a
* forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant Integer
1000000
       in forall (s :: S).
Term
  s
  (PCurrencySymbol
   :--> (PTokenName :--> (PInteger :--> PValue 'Sorted 'NonZero)))
Value.psingleton forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant CurrencySymbol
"" forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant TokenName
"" forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
#$ Term s PInteger
adaValue

{- | Convert @PInteger@ to @PFixed@.

 @since 3.12.0
-}
fromPInteger ::
  forall (unit :: Nat) (s :: S).
  KnownNat unit =>
  Term s (PInteger :--> PFixed unit)
fromPInteger :: forall (unit :: Nat) (s :: S).
KnownNat unit =>
Term s (PInteger :--> PFixed unit)
fromPInteger =
  forall (a :: PType) (s :: S).
HasCallStack =>
ClosedTerm a -> Term s a
phoistAcyclic forall a b. (a -> b) -> a -> b
$ forall a (b :: PType) (s :: S) (c :: PType).
(PLamN a b s, HasCallStack) =>
(Term s c -> a) -> Term s (c :--> b)
plam forall a b. (a -> b) -> a -> b
$ \Term s PInteger
z -> forall (a :: PType) (s :: S). PlutusType a => a s -> Term s a
pcon forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (unit :: Nat) (s :: S). Term s PInteger -> PFixed unit s
PFixed forall a b. (a -> b) -> a -> b
$ forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @unit)) forall a. Num a => a -> a -> a
* Term s PInteger
z

{- | Convert @PFixed@ to @Integer@. Values that are smaller than 1 will be lost.

 @since 3.12.0
-}
toPInteger ::
  forall (unit :: Nat) (s :: S).
  KnownNat unit =>
  Term s (PFixed unit :--> PInteger)
toPInteger :: forall (unit :: Nat) (s :: S).
KnownNat unit =>
Term s (PFixed unit :--> PInteger)
toPInteger =
  forall (a :: PType) (s :: S).
HasCallStack =>
ClosedTerm a -> Term s a
phoistAcyclic forall a b. (a -> b) -> a -> b
$ forall a (b :: PType) (s :: S) (c :: PType).
(PLamN a b s, HasCallStack) =>
(Term s c -> a) -> Term s (c :--> b)
plam forall a b. (a -> b) -> a -> b
$ \Term s (PFixed unit)
d -> forall (a :: PType) (s :: S).
PIntegral a =>
Term s (a :--> (a :--> a))
pdiv forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (s :: S) (a :: PType). Term s a -> Term s (PInner a)
pto Term s (PFixed unit)
d forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant (forall (n :: Nat) (proxy :: Nat -> Type).
KnownNat n =>
proxy n -> Integer
natVal (forall {k} (t :: k). Proxy t
Proxy @unit))