{-# LANGUAGE ViewPatterns #-}

module Plutarch.Extra.Time (
  PFullyBoundedTimeRange (..),
  pgetFullyBoundedTimeRange,
  fullyBoundedTimeRangeFromValidRange,
  passertFullyBoundedTimeRange,
  pisWithinTimeRange,
  pisTimeRangeWithin,
  ptimeRangeDuration,
) where

import Control.Composition ((.*))
import GHC.Records (HasField)
import Plutarch.Api.V1 (
  PExtended (PFinite),
  PInterval (PInterval),
  PLowerBound (PLowerBound),
  PPOSIXTime,
  PUpperBound (PUpperBound),
 )
import Plutarch.Api.V2 (PPOSIXTimeRange)
import Plutarch.Extra.Applicative (pliftA2)
import Plutarch.Extra.Field (pletAll, pletAllC)
import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing)
import Plutarch.Extra.TermCont (pmatchC)

{- | Represent a fully bounded time range.

     Note: 'PFullyBoundedTimeRange' doesn't need a Haskell-level equivalent
     because it is only used in scripts, and does not go in datums. It is also
     Scott-encoded.

     @since 3.3.0
-}
data PFullyBoundedTimeRange (s :: S)
  = PFullyBoundedTimeRange
      (Term s PPOSIXTime)
      -- ^ The lower bound.
      (Term s PPOSIXTime)
      -- ^ The upper bound.
  deriving stock
    ( -- | @since 3.3.0
      forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (s :: S) x.
Rep (PFullyBoundedTimeRange s) x -> PFullyBoundedTimeRange s
forall (s :: S) x.
PFullyBoundedTimeRange s -> Rep (PFullyBoundedTimeRange s) x
$cto :: forall (s :: S) x.
Rep (PFullyBoundedTimeRange s) x -> PFullyBoundedTimeRange s
$cfrom :: forall (s :: S) x.
PFullyBoundedTimeRange s -> Rep (PFullyBoundedTimeRange s) x
Generic
    )
  deriving anyclass
    ( -- | @since 3.3.0
      forall (s :: S).
PFullyBoundedTimeRange s -> Term s (PInner PFullyBoundedTimeRange)
forall (s :: S) (b :: PType).
Term s (PInner PFullyBoundedTimeRange)
-> (PFullyBoundedTimeRange 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 PFullyBoundedTimeRange)
-> (PFullyBoundedTimeRange s -> Term s b) -> Term s b
$cpmatch' :: forall (s :: S) (b :: PType).
Term s (PInner PFullyBoundedTimeRange)
-> (PFullyBoundedTimeRange s -> Term s b) -> Term s b
pcon' :: forall (s :: S).
PFullyBoundedTimeRange s -> Term s (PInner PFullyBoundedTimeRange)
$cpcon' :: forall (s :: S).
PFullyBoundedTimeRange s -> Term s (PInner PFullyBoundedTimeRange)
PlutusType
    , -- | @since 3.3.0
      forall (s :: S).
Term s PFullyBoundedTimeRange
-> Term s PFullyBoundedTimeRange -> 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 PFullyBoundedTimeRange
-> Term s PFullyBoundedTimeRange -> Term s PBool
$c#== :: forall (s :: S).
Term s PFullyBoundedTimeRange
-> Term s PFullyBoundedTimeRange -> Term s PBool
PEq
    )

-- | @since 3.3.0
instance DerivePlutusType PFullyBoundedTimeRange where
  type DPTStrat _ = PlutusTypeScott

{- | Get the current time, given a 'PPOSIXTimeRange'.

     If it's impossible to get a full-bounded time (for example, either end of
     the 'PPOSIXTimeRange' is an infinity), then we return 'PNothing'.

     @since 3.3.0
-}
pgetFullyBoundedTimeRange ::
  forall (s :: S).
  Term
    s
    ( PPOSIXTimeRange
        :--> PMaybe PFullyBoundedTimeRange
    )
pgetFullyBoundedTimeRange :: forall (s :: S).
Term s (PPOSIXTimeRange :--> PMaybe PFullyBoundedTimeRange)
pgetFullyBoundedTimeRange = 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 PPOSIXTimeRange
iv -> forall (a :: PType) (s :: S). TermCont s (Term s a) -> Term s a
unTermCont forall a b. (a -> b) -> a -> b
$ do
    PInterval Term
  s
  (PDataRecord
     '[ "from" ':= PLowerBound PPOSIXTime,
        "to" ':= PUpperBound PPOSIXTime])
iv' <- forall {r :: PType} (a :: PType) (s :: S).
PlutusType a =>
Term s a -> TermCont s (a s)
pmatchC Term s PPOSIXTimeRange
iv
    HRec
  '[ '("from", Term s (PAsData (PLowerBound PPOSIXTime))),
     '("to", Term s (PAsData (PUpperBound PPOSIXTime)))]
ivf <- forall (a :: PType) (s :: S) (b :: PType) (ps :: [PLabeledType])
       (bs :: [ToBind]).
(PDataFields a, ps ~ PFields a, bs ~ Bindings ps (BindAll ps),
 BindFields ps bs) =>
Term s a -> TermCont s (HRec (BoundTerms ps bs s))
pletAllC Term
  s
  (PDataRecord
     '[ "from" ':= PLowerBound PPOSIXTime,
        "to" ':= PUpperBound PPOSIXTime])
iv'
    PLowerBound Term
  s (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool])
lb <- forall {r :: PType} (a :: PType) (s :: S).
PlutusType a =>
Term s a -> TermCont s (a s)
pmatchC (forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"from" HRec
  '[ '("from", Term s (PAsData (PLowerBound PPOSIXTime))),
     '("to", Term s (PAsData (PUpperBound PPOSIXTime)))]
ivf)
    PUpperBound Term
  s (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool])
ub <- forall {r :: PType} (a :: PType) (s :: S).
PlutusType a =>
Term s a -> TermCont s (a s)
pmatchC (forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"to" HRec
  '[ '("from", Term s (PAsData (PLowerBound PPOSIXTime))),
     '("to", Term s (PAsData (PUpperBound PPOSIXTime)))]
ivf)

    let getBound :: Term
  s
  (PBool
   :--> (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool]
         :--> PMaybe PPOSIXTime))
getBound = 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 PBool
dontCheckInclusive ->
            forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (a :: PType) (s :: S) (b :: PType) (ps :: [PLabeledType])
       (bs :: [ToBind]).
(PDataFields a, ps ~ PFields a, bs ~ Bindings ps (BindAll ps),
 BindFields ps bs) =>
Term s a -> (HRecOf a (BindAll ps) s -> Term s b) -> Term s b
pletAll forall a b. (a -> b) -> a -> b
$ \HRec
  (BoundTerms
     (PFields
        (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool]))
     (Bindings
        (PFields
           (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool]))
        (BindAll
           (PFields
              (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool]))))
     s)
f ->
              forall (s :: S) (a :: PType).
Term s PBool -> Term s a -> Term s a -> Term s a
pif
                (Term s PBool
dontCheckInclusive forall (s :: S). Term s PBool -> Term s PBool -> Term s PBool
#|| forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"_1" HRec
  (BoundTerms
     (PFields
        (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool]))
     (Bindings
        (PFields
           (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool]))
        (BindAll
           (PFields
              (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool]))))
     s)
f)
                ( forall (a :: PType) (s :: S) (b :: PType).
PlutusType a =>
Term s a -> (a s -> Term s b) -> Term s b
pmatch (forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"_0" HRec
  (BoundTerms
     (PFields
        (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool]))
     (Bindings
        (PFields
           (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool]))
        (BindAll
           (PFields
              (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool]))))
     s)
f) forall a b. (a -> b) -> a -> b
$ \case
                    PFinite (forall (a :: PType) (s :: S).
PIsData a =>
Term s (PAsData a) -> Term s a
pfromData forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (name :: Symbol) (b :: PType) (p :: PType) (s :: S)
       (a :: PType) (as :: [PLabeledType]) (n :: Nat).
(PDataFields p, as ~ PFields p, n ~ PLabelIndex name as,
 KnownNat n, a ~ PUnLabel (IndexList n as), PFromDataable a b) =>
Term s (p :--> b)
pfield @"_0" forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
#) -> Term s PPOSIXTime
d) -> forall (a :: PType) (s :: S). Term s (a :--> PMaybe a)
pjust forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s PPOSIXTime
d
                    PExtended PPOSIXTime s
_ ->
                      forall (s :: S) (a :: PType).
Term s PString -> Term s a -> Term s a
ptrace
                        Term s PString
"pcurrentTime: time range should be bounded"
                        forall (a :: PType) (s :: S). Term s (PMaybe a)
pnothing
                )
                (forall (s :: S) (a :: PType).
Term s PString -> Term s a -> Term s a
ptrace Term s PString
"pcurrentTime: time range should be inclusive" forall (a :: PType) (s :: S). Term s (PMaybe a)
pnothing)

        lb' :: Term s (PMaybe PPOSIXTime)
lb' = forall {s :: S}.
Term
  s
  (PBool
   :--> (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool]
         :--> PMaybe PPOSIXTime))
getBound forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (a :: PType) (s :: S). PlutusType a => a s -> Term s a
pcon forall (s :: S). PBool s
PFalse forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term
  s (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool])
lb
        ub' :: Term s (PMaybe PPOSIXTime)
ub' = forall {s :: S}.
Term
  s
  (PBool
   :--> (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool]
         :--> PMaybe PPOSIXTime))
getBound forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (a :: PType) (s :: S). PlutusType a => a s -> Term s a
pcon forall (s :: S). PBool s
PTrue forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term
  s (PDataRecord '[ "_0" ':= PExtended PPOSIXTime, "_1" ':= PBool])
ub

        mkTime :: Term s (PPOSIXTime :--> (PPOSIXTime :--> PFullyBoundedTimeRange))
mkTime = 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 (a :: PType) (s :: S). PlutusType a => a s -> Term s a
pcon forall c d a b. (c -> d) -> (a -> b -> c) -> a -> b -> d
.* forall (s :: S).
Term s PPOSIXTime -> Term s PPOSIXTime -> PFullyBoundedTimeRange s
PFullyBoundedTimeRange
    forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: PType -> PType) (a :: PType) (b :: PType) (c :: PType)
       (s :: S).
(PApply f, PSubcategory f a, PSubcategory f b, PSubcategory f c) =>
Term s ((a :--> (b :--> c)) :--> (f a :--> (f b :--> f c)))
pliftA2 forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall {s :: S}.
Term s (PPOSIXTime :--> (PPOSIXTime :--> PFullyBoundedTimeRange))
mkTime forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s (PMaybe PPOSIXTime)
lb' forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s (PMaybe PPOSIXTime)
ub'

{- | Calculate the current time by providing the @validRange@ field,
     which typically comes from 'PTxInfo'.

     @since 3.3.0
-}
fullyBoundedTimeRangeFromValidRange ::
  forall r (s :: S).
  (HasField "validRange" r (Term s PPOSIXTimeRange)) =>
  r ->
  Term s (PMaybe PFullyBoundedTimeRange)
fullyBoundedTimeRangeFromValidRange :: forall r (s :: S).
HasField "validRange" r (Term s PPOSIXTimeRange) =>
r -> Term s (PMaybe PFullyBoundedTimeRange)
fullyBoundedTimeRangeFromValidRange r
x =
  forall (s :: S).
Term s (PPOSIXTimeRange :--> PMaybe PFullyBoundedTimeRange)
pgetFullyBoundedTimeRange
    # getField @"validRange" x

{- | Calculate the current time, and error out with the given message if we can't
     get it.

     @since 3.3.0
-}
passertFullyBoundedTimeRange ::
  forall (s :: S).
  Term
    s
    ( PString
        :--> PPOSIXTimeRange
        :--> PFullyBoundedTimeRange
    )
passertFullyBoundedTimeRange :: forall (s :: S).
Term s (PString :--> (PPOSIXTimeRange :--> PFullyBoundedTimeRange))
passertFullyBoundedTimeRange = 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 PString
msg Term s PPOSIXTimeRange
iv -> forall (a :: PType) (s :: S).
Term s (PString :--> (PMaybe a :--> a))
passertPJust forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s PString
msg forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
#$ forall (s :: S).
Term s (PPOSIXTimeRange :--> PMaybe PFullyBoundedTimeRange)
pgetFullyBoundedTimeRange forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s PPOSIXTimeRange
iv

{- | Retutn 'PTrue' if a `PPOSIXTime` is in the current time range.

     @since 3.3.0
-}
pisWithinTimeRange ::
  forall (s :: S).
  Term
    s
    ( PPOSIXTime
        :--> PFullyBoundedTimeRange
        :--> PBool
    )
pisWithinTimeRange :: forall (s :: S).
Term s (PPOSIXTime :--> (PFullyBoundedTimeRange :--> PBool))
pisWithinTimeRange = 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 PPOSIXTime
time Term s PFullyBoundedTimeRange
ctr ->
    forall (a :: PType) (s :: S) (b :: PType).
PlutusType a =>
Term s a -> (a s -> Term s b) -> Term s b
pmatch Term s PFullyBoundedTimeRange
ctr forall a b. (a -> b) -> a -> b
$ \(PFullyBoundedTimeRange Term s PPOSIXTime
lb Term s PPOSIXTime
ub) ->
      Term s PPOSIXTime
lb forall (t :: PType) (s :: S).
PPartialOrd t =>
Term s t -> Term s t -> Term s PBool
#<= Term s PPOSIXTime
time forall (s :: S). Term s PBool -> Term s PBool -> Term s PBool
#&& Term s PPOSIXTime
time forall (t :: PType) (s :: S).
PPartialOrd t =>
Term s t -> Term s t -> Term s PBool
#<= Term s PPOSIXTime
ub

{- | Return 'PTrue' if current time is within the given time range.

     Note that the first argument is the lower bound of said time range, and
     the second is the upper bound.

     @since 3.3.0
-}
pisTimeRangeWithin ::
  forall (s :: S).
  Term
    s
    ( PPOSIXTime
        :--> PPOSIXTime
        :--> PFullyBoundedTimeRange
        :--> PBool
    )
pisTimeRangeWithin :: forall (s :: S).
Term
  s
  (PPOSIXTime
   :--> (PPOSIXTime :--> (PFullyBoundedTimeRange :--> PBool)))
pisTimeRangeWithin = 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 PPOSIXTime
lb' Term s PPOSIXTime
ub' Term s PFullyBoundedTimeRange
ctr ->
    forall (a :: PType) (s :: S) (b :: PType).
PlutusType a =>
Term s a -> (a s -> Term s b) -> Term s b
pmatch Term s PFullyBoundedTimeRange
ctr forall a b. (a -> b) -> a -> b
$ \(PFullyBoundedTimeRange Term s PPOSIXTime
lb Term s PPOSIXTime
ub) ->
      Term s PPOSIXTime
lb' forall (t :: PType) (s :: S).
PPartialOrd t =>
Term s t -> Term s t -> Term s PBool
#<= Term s PPOSIXTime
lb forall (s :: S). Term s PBool -> Term s PBool -> Term s PBool
#&& Term s PPOSIXTime
ub forall (t :: PType) (s :: S).
PPartialOrd t =>
Term s t -> Term s t -> Term s PBool
#<= Term s PPOSIXTime
ub'

{- | Return the duration of current time.

     @since 3.14.1
-}
ptimeRangeDuration ::
  forall (s :: S).
  Term
    s
    ( PFullyBoundedTimeRange
        :--> PPOSIXTime
    )
ptimeRangeDuration :: forall (s :: S). Term s (PFullyBoundedTimeRange :--> PPOSIXTime)
ptimeRangeDuration = 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 a b c. (a -> b -> c) -> b -> a -> c
flip forall (a :: PType) (s :: S) (b :: PType).
PlutusType a =>
Term s a -> (a s -> Term s b) -> Term s b
pmatch forall a b. (a -> b) -> a -> b
$
      \(PFullyBoundedTimeRange Term s PPOSIXTime
lb Term s PPOSIXTime
ub) -> Term s PPOSIXTime
ub forall a. Num a => a -> a -> a
- Term s PPOSIXTime
lb