{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Allegra.Scripts (
  AllegraEraScript (..),
  mkRequireSignatureTimelock,
  getRequireSignatureTimelock,
  mkRequireAllOfTimelock,
  getRequireAllOfTimelock,
  mkRequireAnyOfTimelock,
  getRequireAnyOfTimelock,
  mkRequireMOfTimelock,
  getRequireMOfTimelock,
  mkTimeStartTimelock,
  getTimeStartTimelock,
  mkTimeExpireTimelock,
  getTimeExpireTimelock,
  Timelock,
  pattern RequireTimeExpire,
  pattern RequireTimeStart,
  TimelockRaw,
  pattern TimelockConstr,
  inInterval,
  showTimelock,
  evalTimelock,
  eqTimelockRaw,
  ValidityInterval (..),
  encodeVI,
  decodeVI,
  -- translate,
  translateTimelock,
)
where

import Cardano.Ledger.Allegra.Era (AllegraEra)
import Cardano.Ledger.BaseTypes (StrictMaybe (SJust, SNothing))
import Cardano.Ledger.Binary (
  Annotator (..),
  DecCBOR (decCBOR),
  EncCBOR (encCBOR),
  ToCBOR (..),
 )
import Cardano.Ledger.Binary.Coders (
  Decode (..),
  Density (..),
  Encode (..),
  Wrapped (..),
  decode,
  encode,
  (!>),
  (<!),
  (<*!),
 )
import Cardano.Ledger.Core
import Cardano.Ledger.MemoBytes (
  EqRaw (..),
  MemoBytes (Memo),
  Memoized (..),
  byteCountMemoBytes,
  decodeMemoized,
  getMemoRawType,
  mkMemoBytes,
  mkMemoizedEra,
  packMemoBytesM,
  unpackMemoBytesM,
 )
import Cardano.Ledger.Shelley.Scripts (
  ShelleyEraScript (..),
  nativeMultiSigTag,
  pattern RequireAllOf,
  pattern RequireAnyOf,
  pattern RequireMOf,
  pattern RequireSignature,
 )
import Cardano.Slotting.Slot (SlotNo (..))
import Control.DeepSeq (NFData (..))
import Data.Aeson (ToJSON (..), (.=))
import qualified Data.Aeson as Aeson
import Data.ByteString.Lazy (fromStrict)
import Data.ByteString.Short (fromShort)
import Data.MemPack
import Data.Sequence.Strict as Seq (StrictSeq (Empty, (:<|)))
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set (Set, member)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))

-- | ValidityInterval is a half open interval. Closed on the bottom, open on the top.
--   A SNothing on the bottom is negative infinity, and a SNothing on the top is positive infinity
data ValidityInterval = ValidityInterval
  { ValidityInterval -> StrictMaybe SlotNo
invalidBefore :: !(StrictMaybe SlotNo)
  , ValidityInterval -> StrictMaybe SlotNo
invalidHereafter :: !(StrictMaybe SlotNo)
  }
  deriving (Eq ValidityInterval
ValidityInterval -> ValidityInterval -> Bool
ValidityInterval -> ValidityInterval -> Ordering
ValidityInterval -> ValidityInterval -> ValidityInterval
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ValidityInterval -> ValidityInterval -> ValidityInterval
$cmin :: ValidityInterval -> ValidityInterval -> ValidityInterval
max :: ValidityInterval -> ValidityInterval -> ValidityInterval
$cmax :: ValidityInterval -> ValidityInterval -> ValidityInterval
>= :: ValidityInterval -> ValidityInterval -> Bool
$c>= :: ValidityInterval -> ValidityInterval -> Bool
> :: ValidityInterval -> ValidityInterval -> Bool
$c> :: ValidityInterval -> ValidityInterval -> Bool
<= :: ValidityInterval -> ValidityInterval -> Bool
$c<= :: ValidityInterval -> ValidityInterval -> Bool
< :: ValidityInterval -> ValidityInterval -> Bool
$c< :: ValidityInterval -> ValidityInterval -> Bool
compare :: ValidityInterval -> ValidityInterval -> Ordering
$ccompare :: ValidityInterval -> ValidityInterval -> Ordering
Ord, ValidityInterval -> ValidityInterval -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidityInterval -> ValidityInterval -> Bool
$c/= :: ValidityInterval -> ValidityInterval -> Bool
== :: ValidityInterval -> ValidityInterval -> Bool
$c== :: ValidityInterval -> ValidityInterval -> Bool
Eq, forall x. Rep ValidityInterval x -> ValidityInterval
forall x. ValidityInterval -> Rep ValidityInterval x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ValidityInterval x -> ValidityInterval
$cfrom :: forall x. ValidityInterval -> Rep ValidityInterval x
Generic, Int -> ValidityInterval -> ShowS
[ValidityInterval] -> ShowS
ValidityInterval -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidityInterval] -> ShowS
$cshowList :: [ValidityInterval] -> ShowS
show :: ValidityInterval -> String
$cshow :: ValidityInterval -> String
showsPrec :: Int -> ValidityInterval -> ShowS
$cshowsPrec :: Int -> ValidityInterval -> ShowS
Show, Context -> ValidityInterval -> IO (Maybe ThunkInfo)
Proxy ValidityInterval -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy ValidityInterval -> String
$cshowTypeOf :: Proxy ValidityInterval -> String
wNoThunks :: Context -> ValidityInterval -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ValidityInterval -> IO (Maybe ThunkInfo)
noThunks :: Context -> ValidityInterval -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> ValidityInterval -> IO (Maybe ThunkInfo)
NoThunks, ValidityInterval -> ()
forall a. (a -> ()) -> NFData a
rnf :: ValidityInterval -> ()
$crnf :: ValidityInterval -> ()
NFData)

encodeVI :: ValidityInterval -> Encode ('Closed 'Dense) ValidityInterval
encodeVI :: ValidityInterval -> Encode ('Closed 'Dense) ValidityInterval
encodeVI (ValidityInterval StrictMaybe SlotNo
f StrictMaybe SlotNo
t) = forall t. t -> Encode ('Closed 'Dense) t
Rec StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictMaybe SlotNo
f forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictMaybe SlotNo
t

instance EncCBOR ValidityInterval where
  encCBOR :: ValidityInterval -> Encoding
encCBOR ValidityInterval
vi = forall (w :: Wrapped) t. Encode w t -> Encoding
encode (ValidityInterval -> Encode ('Closed 'Dense) ValidityInterval
encodeVI ValidityInterval
vi)

decodeVI :: Decode ('Closed 'Dense) ValidityInterval
decodeVI :: Decode ('Closed 'Dense) ValidityInterval
decodeVI = forall t. t -> Decode ('Closed 'Dense) t
RecD StrictMaybe SlotNo -> StrictMaybe SlotNo -> ValidityInterval
ValidityInterval forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From

instance DecCBOR ValidityInterval where
  decCBOR :: forall s. Decoder s ValidityInterval
decCBOR = forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode Decode ('Closed 'Dense) ValidityInterval
decodeVI

instance ToJSON ValidityInterval where
  toJSON :: ValidityInterval -> Value
toJSON ValidityInterval
vi =
    [Pair] -> Value
Aeson.object forall a b. (a -> b) -> a -> b
$
      [ Key
k forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SlotNo
v
      | (Key
k, SJust SlotNo
v) <-
          [ (Key
"invalidBefore", ValidityInterval -> StrictMaybe SlotNo
invalidBefore ValidityInterval
vi)
          , (Key
"invalidHereafter", ValidityInterval -> StrictMaybe SlotNo
invalidHereafter ValidityInterval
vi)
          ]
      ]

-- ==================================================================

data TimelockRaw era
  = Signature !(KeyHash 'Witness)
  | AllOf !(StrictSeq (Timelock era)) -- NOTE that Timelock and
  | AnyOf !(StrictSeq (Timelock era)) -- TimelockRaw are mutually recursive.
  | MOfN !Int !(StrictSeq (Timelock era))
  | -- Note that the Int may be negative in which case (MOfN (-2) [..]) is always True
    TimeStart !SlotNo -- The start time
  | TimeExpire !SlotNo -- The time it expires
  deriving (TimelockRaw era -> TimelockRaw era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (era :: k). TimelockRaw era -> TimelockRaw era -> Bool
/= :: TimelockRaw era -> TimelockRaw era -> Bool
$c/= :: forall k (era :: k). TimelockRaw era -> TimelockRaw era -> Bool
== :: TimelockRaw era -> TimelockRaw era -> Bool
$c== :: forall k (era :: k). TimelockRaw era -> TimelockRaw era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (era :: k) x. Rep (TimelockRaw era) x -> TimelockRaw era
forall k (era :: k) x. TimelockRaw era -> Rep (TimelockRaw era) x
$cto :: forall k (era :: k) x. Rep (TimelockRaw era) x -> TimelockRaw era
$cfrom :: forall k (era :: k) x. TimelockRaw era -> Rep (TimelockRaw era) x
Generic, forall a. (a -> ()) -> NFData a
forall k (era :: k). TimelockRaw era -> ()
rnf :: TimelockRaw era -> ()
$crnf :: forall k (era :: k). TimelockRaw era -> ()
NFData)

class ShelleyEraScript era => AllegraEraScript era where
  mkTimeStart :: SlotNo -> NativeScript era
  getTimeStart :: NativeScript era -> Maybe SlotNo

  mkTimeExpire :: SlotNo -> NativeScript era
  getTimeExpire :: NativeScript era -> Maybe SlotNo

deriving instance Era era => NoThunks (TimelockRaw era)

deriving instance Show (TimelockRaw era)

-- | This function deconstructs and then reconstructs the timelock script
-- to prove the compiler that we can arbirarily switch out the eras as long
-- as the cryptos for both eras are the same.
translateTimelock ::
  forall era1 era2.
  ( Era era1
  , Era era2
  ) =>
  Timelock era1 ->
  Timelock era2
translateTimelock :: forall era1 era2.
(Era era1, Era era2) =>
Timelock era1 -> Timelock era2
translateTimelock (TimelockConstr (Memo TimelockRaw era1
tl ShortByteString
bs)) =
  let rewrap :: TimelockRaw era2 -> Timelock era2
rewrap TimelockRaw era2
rtl = forall {k} (era :: k). MemoBytes (TimelockRaw era) -> Timelock era
TimelockConstr forall a b. (a -> b) -> a -> b
$ forall t. t -> ByteString -> MemoBytes t
mkMemoBytes TimelockRaw era2
rtl (ByteString -> ByteString
fromStrict forall a b. (a -> b) -> a -> b
$ ShortByteString -> ByteString
fromShort ShortByteString
bs)
   in case TimelockRaw era1
tl of
        Signature KeyHash 'Witness
s -> TimelockRaw era2 -> Timelock era2
rewrap forall a b. (a -> b) -> a -> b
$ forall {k} (era :: k). KeyHash 'Witness -> TimelockRaw era
Signature KeyHash 'Witness
s
        AllOf StrictSeq (Timelock era1)
l -> TimelockRaw era2 -> Timelock era2
rewrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (era :: k). StrictSeq (Timelock era) -> TimelockRaw era
AllOf forall a b. (a -> b) -> a -> b
$ forall era1 era2.
(Era era1, Era era2) =>
Timelock era1 -> Timelock era2
translateTimelock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (Timelock era1)
l
        AnyOf StrictSeq (Timelock era1)
l -> TimelockRaw era2 -> Timelock era2
rewrap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (era :: k). StrictSeq (Timelock era) -> TimelockRaw era
AnyOf forall a b. (a -> b) -> a -> b
$ forall era1 era2.
(Era era1, Era era2) =>
Timelock era1 -> Timelock era2
translateTimelock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (Timelock era1)
l
        MOfN Int
n StrictSeq (Timelock era1)
l -> TimelockRaw era2 -> Timelock era2
rewrap forall a b. (a -> b) -> a -> b
$ forall {k} (era :: k).
Int -> StrictSeq (Timelock era) -> TimelockRaw era
MOfN Int
n (forall era1 era2.
(Era era1, Era era2) =>
Timelock era1 -> Timelock era2
translateTimelock forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (Timelock era1)
l)
        TimeStart SlotNo
x -> TimelockRaw era2 -> Timelock era2
rewrap forall a b. (a -> b) -> a -> b
$ forall {k} (era :: k). SlotNo -> TimelockRaw era
TimeStart SlotNo
x
        TimeExpire SlotNo
x -> TimelockRaw era2 -> Timelock era2
rewrap forall a b. (a -> b) -> a -> b
$ forall {k} (era :: k). SlotNo -> TimelockRaw era
TimeExpire SlotNo
x

-- These coding choices are chosen so that a MultiSig script
-- can be deserialised as a Timelock script

instance Era era => EncCBOR (TimelockRaw era) where
  encCBOR :: TimelockRaw era -> Encoding
encCBOR =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Signature KeyHash 'Witness
hash -> forall t. t -> Word -> Encode 'Open t
Sum forall {k} (era :: k). KeyHash 'Witness -> TimelockRaw era
Signature Word
0 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To KeyHash 'Witness
hash
      AllOf StrictSeq (Timelock era)
xs -> forall t. t -> Word -> Encode 'Open t
Sum forall {k} (era :: k). StrictSeq (Timelock era) -> TimelockRaw era
AllOf Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictSeq (Timelock era)
xs
      AnyOf StrictSeq (Timelock era)
xs -> forall t. t -> Word -> Encode 'Open t
Sum forall {k} (era :: k). StrictSeq (Timelock era) -> TimelockRaw era
AnyOf Word
2 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictSeq (Timelock era)
xs
      MOfN Int
m StrictSeq (Timelock era)
xs -> forall t. t -> Word -> Encode 'Open t
Sum forall {k} (era :: k).
Int -> StrictSeq (Timelock era) -> TimelockRaw era
MOfN Word
3 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Int
m forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To StrictSeq (Timelock era)
xs
      TimeStart SlotNo
m -> forall t. t -> Word -> Encode 'Open t
Sum forall {k} (era :: k). SlotNo -> TimelockRaw era
TimeStart Word
4 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To SlotNo
m
      TimeExpire SlotNo
m -> forall t. t -> Word -> Encode 'Open t
Sum forall {k} (era :: k). SlotNo -> TimelockRaw era
TimeExpire Word
5 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To SlotNo
m

-- This instance allows us to derive instance DecCBOR (Annotator (Timelock era)).
-- Since Timelock is a newtype around (Memo (Timelock era)).
instance Era era => DecCBOR (Annotator (TimelockRaw era)) where
  decCBOR :: forall s. Decoder s (Annotator (TimelockRaw era))
decCBOR = forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"TimelockRaw" Word -> Decode 'Open (Annotator (TimelockRaw era))
decRaw)
    where
      decRaw :: Word -> Decode 'Open (Annotator (TimelockRaw era))
      decRaw :: Word -> Decode 'Open (Annotator (TimelockRaw era))
decRaw Word
0 = forall t1 (w :: Wrapped).
Typeable t1 =>
Decode w t1 -> Decode w (Annotator t1)
Ann (forall t. t -> Decode 'Open t
SumD forall {k} (era :: k). KeyHash 'Witness -> TimelockRaw era
Signature forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From)
      decRaw Word
1 = forall t1 (w :: Wrapped).
Typeable t1 =>
Decode w t1 -> Decode w (Annotator t1)
Ann (forall t. t -> Decode 'Open t
SumD forall {k} (era :: k). StrictSeq (Timelock era) -> TimelockRaw era
AllOf) forall a t (w1 :: Wrapped) (d :: Density).
(Typeable a, Typeable t) =>
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
<*! forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR)
      decRaw Word
2 = forall t1 (w :: Wrapped).
Typeable t1 =>
Decode w t1 -> Decode w (Annotator t1)
Ann (forall t. t -> Decode 'Open t
SumD forall {k} (era :: k). StrictSeq (Timelock era) -> TimelockRaw era
AnyOf) forall a t (w1 :: Wrapped) (d :: Density).
(Typeable a, Typeable t) =>
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
<*! forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR)
      decRaw Word
3 = forall t1 (w :: Wrapped).
Typeable t1 =>
Decode w t1 -> Decode w (Annotator t1)
Ann (forall t. t -> Decode 'Open t
SumD forall {k} (era :: k).
Int -> StrictSeq (Timelock era) -> TimelockRaw era
MOfN) forall a t (w1 :: Wrapped) (d :: Density).
(Typeable a, Typeable t) =>
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
<*! forall t1 (w :: Wrapped).
Typeable t1 =>
Decode w t1 -> Decode w (Annotator t1)
Ann forall t (w :: Wrapped). DecCBOR t => Decode w t
From forall a t (w1 :: Wrapped) (d :: Density).
(Typeable a, Typeable t) =>
Decode w1 (Annotator (a -> t))
-> Decode ('Closed d) (Annotator a) -> Decode w1 (Annotator t)
<*! forall t. (forall s. Decoder s t) -> Decode ('Closed 'Dense) t
D (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR)
      decRaw Word
4 = forall t1 (w :: Wrapped).
Typeable t1 =>
Decode w t1 -> Decode w (Annotator t1)
Ann (forall t. t -> Decode 'Open t
SumD forall {k} (era :: k). SlotNo -> TimelockRaw era
TimeStart forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From)
      decRaw Word
5 = forall t1 (w :: Wrapped).
Typeable t1 =>
Decode w t1 -> Decode w (Annotator t1)
Ann (forall t. t -> Decode 'Open t
SumD forall {k} (era :: k). SlotNo -> TimelockRaw era
TimeExpire forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From)
      decRaw Word
n = forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

instance Era era => DecCBOR (TimelockRaw era) where
  decCBOR :: forall s. Decoder s (TimelockRaw era)
decCBOR = forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$ forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"TimelockRaw" forall a b. (a -> b) -> a -> b
$ \case
    Word
0 -> forall t. t -> Decode 'Open t
SumD forall {k} (era :: k). KeyHash 'Witness -> TimelockRaw era
Signature forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
1 -> forall t. t -> Decode 'Open t
SumD forall {k} (era :: k). StrictSeq (Timelock era) -> TimelockRaw era
AllOf forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
2 -> forall t. t -> Decode 'Open t
SumD forall {k} (era :: k). StrictSeq (Timelock era) -> TimelockRaw era
AnyOf forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
3 -> forall t. t -> Decode 'Open t
SumD forall {k} (era :: k).
Int -> StrictSeq (Timelock era) -> TimelockRaw era
MOfN forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
4 -> forall t. t -> Decode 'Open t
SumD forall {k} (era :: k). SlotNo -> TimelockRaw era
TimeStart forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
5 -> forall t. t -> Decode 'Open t
SumD forall {k} (era :: k). SlotNo -> TimelockRaw era
TimeExpire forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
n -> forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

-- =================================================================
-- Native Scripts are Memoized TimelockRaw.
-- The patterns give the appearence that the mutual recursion is not present.
-- They rely on memoBytes, and TimelockRaw to memoize each constructor of Timelock
-- =================================================================

newtype Timelock era = TimelockConstr (MemoBytes (TimelockRaw era))
  deriving (Timelock era -> Timelock era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (era :: k). Timelock era -> Timelock era -> Bool
/= :: Timelock era -> Timelock era -> Bool
$c/= :: forall k (era :: k). Timelock era -> Timelock era -> Bool
== :: Timelock era -> Timelock era -> Bool
$c== :: forall k (era :: k). Timelock era -> Timelock era -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (era :: k) x. Rep (Timelock era) x -> Timelock era
forall k (era :: k) x. Timelock era -> Rep (Timelock era) x
$cto :: forall k (era :: k) x. Rep (Timelock era) x -> Timelock era
$cfrom :: forall k (era :: k) x. Timelock era -> Rep (Timelock era) x
Generic)
  deriving newtype (Timelock era -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [Timelock era] -> Size
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (Timelock era) -> Size
forall a.
Typeable a
-> (a -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> ToCBOR a
forall {k} {era :: k}.
(Typeable era, Typeable k) =>
Typeable (Timelock era)
forall k (era :: k).
(Typeable era, Typeable k) =>
Timelock era -> Encoding
forall k (era :: k).
(Typeable era, Typeable k) =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [Timelock era] -> Size
forall k (era :: k).
(Typeable era, Typeable k) =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (Timelock era) -> Size
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [Timelock era] -> Size
$cencodedListSizeExpr :: forall k (era :: k).
(Typeable era, Typeable k) =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [Timelock era] -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (Timelock era) -> Size
$cencodedSizeExpr :: forall k (era :: k).
(Typeable era, Typeable k) =>
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (Timelock era) -> Size
toCBOR :: Timelock era -> Encoding
$ctoCBOR :: forall k (era :: k).
(Typeable era, Typeable k) =>
Timelock era -> Encoding
ToCBOR, Timelock era -> ()
forall a. (a -> ()) -> NFData a
forall k (era :: k). Timelock era -> ()
rnf :: Timelock era -> ()
$crnf :: forall k (era :: k). Timelock era -> ()
NFData, Timelock era -> Int
Timelock era -> ByteString
forall i. Proxy i -> Timelock era -> SafeHash i
forall t.
(t -> ByteString)
-> (t -> Int)
-> (forall i. Proxy i -> t -> SafeHash i)
-> SafeToHash t
forall k (era :: k). Timelock era -> Int
forall k (era :: k). Timelock era -> ByteString
forall k (era :: k) i. Proxy i -> Timelock era -> SafeHash i
makeHashWithExplicitProxys :: forall i. Proxy i -> Timelock era -> SafeHash i
$cmakeHashWithExplicitProxys :: forall k (era :: k) i. Proxy i -> Timelock era -> SafeHash i
originalBytesSize :: Timelock era -> Int
$coriginalBytesSize :: forall k (era :: k). Timelock era -> Int
originalBytes :: Timelock era -> ByteString
$coriginalBytes :: forall k (era :: k). Timelock era -> ByteString
SafeToHash)

instance Era era => MemPack (Timelock era) where
  packedByteCount :: Timelock era -> Int
packedByteCount (TimelockConstr MemoBytes (TimelockRaw era)
mb) = forall t. MemoBytes t -> Int
byteCountMemoBytes MemoBytes (TimelockRaw era)
mb
  packM :: forall s. Timelock era -> Pack s ()
packM (TimelockConstr MemoBytes (TimelockRaw era)
mb) = forall t s. MemoBytes t -> Pack s ()
packMemoBytesM MemoBytes (TimelockRaw era)
mb
  unpackM :: forall b. Buffer b => Unpack b (Timelock era)
unpackM = forall {k} (era :: k). MemoBytes (TimelockRaw era) -> Timelock era
TimelockConstr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t b.
(Typeable t, DecCBOR (Annotator t), Buffer b) =>
Version -> Unpack b (MemoBytes t)
unpackMemoBytesM (forall era. Era era => Version
eraProtVerLow @era)

instance Era era => NoThunks (Timelock era)
instance Era era => EncCBOR (Timelock era)

instance Era era => DecCBOR (Timelock era) where
  decCBOR :: forall s. Decoder s (Timelock era)
decCBOR = forall {k} (era :: k). MemoBytes (TimelockRaw era) -> Timelock era
TimelockConstr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s t. Decoder s t -> Decoder s (MemoBytes t)
decodeMemoized forall a s. DecCBOR a => Decoder s a
decCBOR

instance Memoized (Timelock era) where
  type RawType (Timelock era) = TimelockRaw era

deriving instance Show (Timelock era)

instance EqRaw (Timelock era) where
  eqRaw :: Timelock era -> Timelock era -> Bool
eqRaw = forall k (era :: k). Timelock era -> Timelock era -> Bool
eqTimelockRaw

instance Era era => DecCBOR (Annotator (Timelock era)) where
  decCBOR :: forall s. Decoder s (Annotator (Timelock era))
decCBOR = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall {k} (era :: k). MemoBytes (TimelockRaw era) -> Timelock era
TimelockConstr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR

-- | Since Timelock scripts are a strictly backwards compatible extension of
-- MultiSig scripts, we can use the same 'scriptPrefixTag' tag here as we did
-- for the ValidateScript instance in MultiSig
instance EraScript AllegraEra where
  type Script AllegraEra = Timelock AllegraEra
  type NativeScript AllegraEra = Timelock AllegraEra

  upgradeScript :: EraScript (PreviousEra AllegraEra) =>
Script (PreviousEra AllegraEra) -> Script AllegraEra
upgradeScript = \case
    RequireSignature KeyHash 'Witness
keyHash -> forall era.
ShelleyEraScript era =>
KeyHash 'Witness -> NativeScript era
RequireSignature KeyHash 'Witness
keyHash
    RequireAllOf StrictSeq (NativeScript ShelleyEra)
sigs -> forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf forall a b. (a -> b) -> a -> b
$ forall era.
(EraScript era, EraScript (PreviousEra era)) =>
Script (PreviousEra era) -> Script era
upgradeScript forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (NativeScript ShelleyEra)
sigs
    RequireAnyOf StrictSeq (NativeScript ShelleyEra)
sigs -> forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf forall a b. (a -> b) -> a -> b
$ forall era.
(EraScript era, EraScript (PreviousEra era)) =>
Script (PreviousEra era) -> Script era
upgradeScript forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (NativeScript ShelleyEra)
sigs
    RequireMOf Int
n StrictSeq (NativeScript ShelleyEra)
sigs -> forall era.
ShelleyEraScript era =>
Int -> StrictSeq (NativeScript era) -> NativeScript era
RequireMOf Int
n forall a b. (a -> b) -> a -> b
$ forall era.
(EraScript era, EraScript (PreviousEra era)) =>
Script (PreviousEra era) -> Script era
upgradeScript forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StrictSeq (NativeScript ShelleyEra)
sigs
    Script (PreviousEra AllegraEra)
_ -> forall a. HasCallStack => String -> a
error String
"Impossible: All NativeScripts should have been accounted for"

  scriptPrefixTag :: Script AllegraEra -> ByteString
scriptPrefixTag Script AllegraEra
_script = ByteString
nativeMultiSigTag -- "\x00"

  getNativeScript :: Script AllegraEra -> Maybe (NativeScript AllegraEra)
getNativeScript = forall a. a -> Maybe a
Just

  fromNativeScript :: NativeScript AllegraEra -> Script AllegraEra
fromNativeScript = forall a. a -> a
id

instance ShelleyEraScript AllegraEra where
  mkRequireSignature :: KeyHash 'Witness -> NativeScript AllegraEra
mkRequireSignature = forall era. Era era => KeyHash 'Witness -> Timelock era
mkRequireSignatureTimelock
  getRequireSignature :: NativeScript AllegraEra -> Maybe (KeyHash 'Witness)
getRequireSignature = forall {k} (era :: k). Timelock era -> Maybe (KeyHash 'Witness)
getRequireSignatureTimelock

  mkRequireAllOf :: StrictSeq (NativeScript AllegraEra) -> NativeScript AllegraEra
mkRequireAllOf = forall era. Era era => StrictSeq (Timelock era) -> Timelock era
mkRequireAllOfTimelock
  getRequireAllOf :: NativeScript AllegraEra
-> Maybe (StrictSeq (NativeScript AllegraEra))
getRequireAllOf = forall {k} (era :: k).
Timelock era -> Maybe (StrictSeq (Timelock era))
getRequireAllOfTimelock

  mkRequireAnyOf :: StrictSeq (NativeScript AllegraEra) -> NativeScript AllegraEra
mkRequireAnyOf = forall era. Era era => StrictSeq (Timelock era) -> Timelock era
mkRequireAnyOfTimelock
  getRequireAnyOf :: NativeScript AllegraEra
-> Maybe (StrictSeq (NativeScript AllegraEra))
getRequireAnyOf = forall {k} (era :: k).
Timelock era -> Maybe (StrictSeq (Timelock era))
getRequireAnyOfTimelock

  mkRequireMOf :: Int
-> StrictSeq (NativeScript AllegraEra) -> NativeScript AllegraEra
mkRequireMOf = forall era.
Era era =>
Int -> StrictSeq (Timelock era) -> Timelock era
mkRequireMOfTimelock
  getRequireMOf :: NativeScript AllegraEra
-> Maybe (Int, StrictSeq (NativeScript AllegraEra))
getRequireMOf = forall {k} (era :: k).
Timelock era -> Maybe (Int, StrictSeq (Timelock era))
getRequireMOfTimelock

instance AllegraEraScript AllegraEra where
  mkTimeStart :: SlotNo -> NativeScript AllegraEra
mkTimeStart = forall era. Era era => SlotNo -> Timelock era
mkTimeStartTimelock
  getTimeStart :: NativeScript AllegraEra -> Maybe SlotNo
getTimeStart = forall {k} (era :: k). Timelock era -> Maybe SlotNo
getTimeStartTimelock

  mkTimeExpire :: SlotNo -> NativeScript AllegraEra
mkTimeExpire = forall era. Era era => SlotNo -> Timelock era
mkTimeExpireTimelock
  getTimeExpire :: NativeScript AllegraEra -> Maybe SlotNo
getTimeExpire = forall {k} (era :: k). Timelock era -> Maybe SlotNo
getTimeExpireTimelock

pattern RequireTimeExpire :: AllegraEraScript era => SlotNo -> NativeScript era
pattern $bRequireTimeExpire :: forall era. AllegraEraScript era => SlotNo -> NativeScript era
$mRequireTimeExpire :: forall {r} {era}.
AllegraEraScript era =>
NativeScript era -> (SlotNo -> r) -> ((# #) -> r) -> r
RequireTimeExpire mslot <- (getTimeExpire -> Just mslot)
  where
    RequireTimeExpire SlotNo
mslot = forall era. AllegraEraScript era => SlotNo -> NativeScript era
mkTimeExpire SlotNo
mslot

pattern RequireTimeStart :: AllegraEraScript era => SlotNo -> NativeScript era
pattern $bRequireTimeStart :: forall era. AllegraEraScript era => SlotNo -> NativeScript era
$mRequireTimeStart :: forall {r} {era}.
AllegraEraScript era =>
NativeScript era -> (SlotNo -> r) -> ((# #) -> r) -> r
RequireTimeStart mslot <- (getTimeStart -> Just mslot)
  where
    RequireTimeStart SlotNo
mslot = forall era. AllegraEraScript era => SlotNo -> NativeScript era
mkTimeStart SlotNo
mslot

{-# COMPLETE
  RequireSignature
  , RequireAllOf
  , RequireAnyOf
  , RequireMOf
  , RequireTimeExpire
  , RequireTimeStart
  #-}

mkRequireSignatureTimelock :: forall era. Era era => KeyHash 'Witness -> Timelock era
mkRequireSignatureTimelock :: forall era. Era era => KeyHash 'Witness -> Timelock era
mkRequireSignatureTimelock = forall era t.
(Era era, EncCBOR (RawType t), Memoized t) =>
RawType t -> t
mkMemoizedEra @era forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (era :: k). KeyHash 'Witness -> TimelockRaw era
Signature
getRequireSignatureTimelock :: Timelock era -> Maybe (KeyHash 'Witness)
getRequireSignatureTimelock :: forall {k} (era :: k). Timelock era -> Maybe (KeyHash 'Witness)
getRequireSignatureTimelock (TimelockConstr (Memo (Signature KeyHash 'Witness
kh) ShortByteString
_)) = forall a. a -> Maybe a
Just KeyHash 'Witness
kh
getRequireSignatureTimelock Timelock era
_ = forall a. Maybe a
Nothing

mkRequireAllOfTimelock :: forall era. Era era => StrictSeq (Timelock era) -> Timelock era
mkRequireAllOfTimelock :: forall era. Era era => StrictSeq (Timelock era) -> Timelock era
mkRequireAllOfTimelock = forall era t.
(Era era, EncCBOR (RawType t), Memoized t) =>
RawType t -> t
mkMemoizedEra @era forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (era :: k). StrictSeq (Timelock era) -> TimelockRaw era
AllOf
getRequireAllOfTimelock :: Timelock era -> Maybe (StrictSeq (Timelock era))
getRequireAllOfTimelock :: forall {k} (era :: k).
Timelock era -> Maybe (StrictSeq (Timelock era))
getRequireAllOfTimelock (TimelockConstr (Memo (AllOf StrictSeq (Timelock era)
ms) ShortByteString
_)) = forall a. a -> Maybe a
Just StrictSeq (Timelock era)
ms
getRequireAllOfTimelock Timelock era
_ = forall a. Maybe a
Nothing

mkRequireAnyOfTimelock :: forall era. Era era => StrictSeq (Timelock era) -> Timelock era
mkRequireAnyOfTimelock :: forall era. Era era => StrictSeq (Timelock era) -> Timelock era
mkRequireAnyOfTimelock = forall era t.
(Era era, EncCBOR (RawType t), Memoized t) =>
RawType t -> t
mkMemoizedEra @era forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (era :: k). StrictSeq (Timelock era) -> TimelockRaw era
AnyOf
getRequireAnyOfTimelock :: Timelock era -> Maybe (StrictSeq (Timelock era))
getRequireAnyOfTimelock :: forall {k} (era :: k).
Timelock era -> Maybe (StrictSeq (Timelock era))
getRequireAnyOfTimelock (TimelockConstr (Memo (AnyOf StrictSeq (Timelock era)
ms) ShortByteString
_)) = forall a. a -> Maybe a
Just StrictSeq (Timelock era)
ms
getRequireAnyOfTimelock Timelock era
_ = forall a. Maybe a
Nothing

mkRequireMOfTimelock :: forall era. Era era => Int -> StrictSeq (Timelock era) -> Timelock era
mkRequireMOfTimelock :: forall era.
Era era =>
Int -> StrictSeq (Timelock era) -> Timelock era
mkRequireMOfTimelock Int
n = forall era t.
(Era era, EncCBOR (RawType t), Memoized t) =>
RawType t -> t
mkMemoizedEra @era forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (era :: k).
Int -> StrictSeq (Timelock era) -> TimelockRaw era
MOfN Int
n
getRequireMOfTimelock :: Timelock era -> Maybe (Int, StrictSeq (Timelock era))
getRequireMOfTimelock :: forall {k} (era :: k).
Timelock era -> Maybe (Int, StrictSeq (Timelock era))
getRequireMOfTimelock (TimelockConstr (Memo (MOfN Int
n StrictSeq (Timelock era)
ms) ShortByteString
_)) = forall a. a -> Maybe a
Just (Int
n, StrictSeq (Timelock era)
ms)
getRequireMOfTimelock Timelock era
_ = forall a. Maybe a
Nothing

mkTimeStartTimelock :: forall era. Era era => SlotNo -> Timelock era
mkTimeStartTimelock :: forall era. Era era => SlotNo -> Timelock era
mkTimeStartTimelock = forall era t.
(Era era, EncCBOR (RawType t), Memoized t) =>
RawType t -> t
mkMemoizedEra @era forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (era :: k). SlotNo -> TimelockRaw era
TimeStart
getTimeStartTimelock :: Timelock era -> Maybe SlotNo
getTimeStartTimelock :: forall {k} (era :: k). Timelock era -> Maybe SlotNo
getTimeStartTimelock (TimelockConstr (Memo (TimeStart SlotNo
mslot) ShortByteString
_)) = forall a. a -> Maybe a
Just SlotNo
mslot
getTimeStartTimelock Timelock era
_ = forall a. Maybe a
Nothing

mkTimeExpireTimelock :: forall era. Era era => SlotNo -> Timelock era
mkTimeExpireTimelock :: forall era. Era era => SlotNo -> Timelock era
mkTimeExpireTimelock = forall era t.
(Era era, EncCBOR (RawType t), Memoized t) =>
RawType t -> t
mkMemoizedEra @era forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (era :: k). SlotNo -> TimelockRaw era
TimeExpire
getTimeExpireTimelock :: Timelock era -> Maybe SlotNo
getTimeExpireTimelock :: forall {k} (era :: k). Timelock era -> Maybe SlotNo
getTimeExpireTimelock (TimelockConstr (Memo (TimeExpire SlotNo
mslot) ShortByteString
_)) = forall a. a -> Maybe a
Just SlotNo
mslot
getTimeExpireTimelock Timelock era
_ = forall a. Maybe a
Nothing

-- =================================================================
-- Evaluating and validating a Timelock

-- | less-than-equal comparison, where Nothing is negative infinity
lteNegInfty :: SlotNo -> StrictMaybe SlotNo -> Bool
lteNegInfty :: SlotNo -> StrictMaybe SlotNo -> Bool
lteNegInfty SlotNo
_ StrictMaybe SlotNo
SNothing = Bool
False -- i > -∞
lteNegInfty SlotNo
i (SJust SlotNo
j) = SlotNo
i forall a. Ord a => a -> a -> Bool
<= SlotNo
j

-- | less-than-equal comparison, where Nothing is positive infinity
ltePosInfty :: StrictMaybe SlotNo -> SlotNo -> Bool
ltePosInfty :: StrictMaybe SlotNo -> SlotNo -> Bool
ltePosInfty StrictMaybe SlotNo
SNothing SlotNo
_ = Bool
False -- ∞ > j
ltePosInfty (SJust SlotNo
i) SlotNo
j = SlotNo
i forall a. Ord a => a -> a -> Bool
<= SlotNo
j

evalTimelock ::
  AllegraEraScript era =>
  Set.Set (KeyHash 'Witness) ->
  ValidityInterval ->
  NativeScript era ->
  Bool
evalTimelock :: forall era.
AllegraEraScript era =>
Set (KeyHash 'Witness)
-> ValidityInterval -> NativeScript era -> Bool
evalTimelock Set (KeyHash 'Witness)
vhks (ValidityInterval StrictMaybe SlotNo
txStart StrictMaybe SlotNo
txExp) = NativeScript era -> Bool
go
  where
    -- The important part of this validator is that it will stop as soon as it reaches the
    -- required number of valid scripts
    isValidMOf :: Int -> StrictSeq (NativeScript era) -> Bool
isValidMOf Int
n StrictSeq (NativeScript era)
SSeq.Empty = Int
n forall a. Ord a => a -> a -> Bool
<= Int
0
    isValidMOf Int
n (NativeScript era
ts SSeq.:<| StrictSeq (NativeScript era)
tss) =
      Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| if NativeScript era -> Bool
go NativeScript era
ts then Int -> StrictSeq (NativeScript era) -> Bool
isValidMOf (Int
n forall a. Num a => a -> a -> a
- Int
1) StrictSeq (NativeScript era)
tss else Int -> StrictSeq (NativeScript era) -> Bool
isValidMOf Int
n StrictSeq (NativeScript era)
tss
    go :: NativeScript era -> Bool
go = \case
      RequireTimeStart SlotNo
lockStart -> SlotNo
lockStart SlotNo -> StrictMaybe SlotNo -> Bool
`lteNegInfty` StrictMaybe SlotNo
txStart
      RequireTimeExpire SlotNo
lockExp -> StrictMaybe SlotNo
txExp StrictMaybe SlotNo -> SlotNo -> Bool
`ltePosInfty` SlotNo
lockExp
      RequireSignature KeyHash 'Witness
hash -> KeyHash 'Witness
hash forall a. Ord a => a -> Set a -> Bool
`Set.member` Set (KeyHash 'Witness)
vhks
      RequireAllOf StrictSeq (NativeScript era)
xs -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all NativeScript era -> Bool
go StrictSeq (NativeScript era)
xs
      RequireAnyOf StrictSeq (NativeScript era)
xs -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any NativeScript era -> Bool
go StrictSeq (NativeScript era)
xs
      RequireMOf Int
m StrictSeq (NativeScript era)
xs -> Int -> StrictSeq (NativeScript era) -> Bool
isValidMOf Int
m StrictSeq (NativeScript era)
xs

-- =========================================================
-- Operations on Timelock scripts

-- | Test if a slot is in the Validity interval. Recall that a ValidityInterval
--   is a half Open interval, that is why we use (slot < top)
inInterval :: SlotNo -> ValidityInterval -> Bool
inInterval :: SlotNo -> ValidityInterval -> Bool
inInterval SlotNo
_slot (ValidityInterval StrictMaybe SlotNo
SNothing StrictMaybe SlotNo
SNothing) = Bool
True
inInterval SlotNo
slot (ValidityInterval StrictMaybe SlotNo
SNothing (SJust SlotNo
top)) = SlotNo
slot forall a. Ord a => a -> a -> Bool
< SlotNo
top
inInterval SlotNo
slot (ValidityInterval (SJust SlotNo
bottom) StrictMaybe SlotNo
SNothing) = SlotNo
bottom forall a. Ord a => a -> a -> Bool
<= SlotNo
slot
inInterval SlotNo
slot (ValidityInterval (SJust SlotNo
bottom) (SJust SlotNo
top)) =
  SlotNo
bottom forall a. Ord a => a -> a -> Bool
<= SlotNo
slot Bool -> Bool -> Bool
&& SlotNo
slot forall a. Ord a => a -> a -> Bool
< SlotNo
top

showTimelock :: AllegraEraScript era => NativeScript era -> String
showTimelock :: forall era. AllegraEraScript era => NativeScript era -> String
showTimelock (RequireTimeStart (SlotNo Word64
i)) = String
"(Start >= " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word64
i forall a. [a] -> [a] -> [a]
++ String
")"
showTimelock (RequireTimeExpire (SlotNo Word64
i)) = String
"(Expire < " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word64
i forall a. [a] -> [a] -> [a]
++ String
")"
showTimelock (RequireAllOf StrictSeq (NativeScript era)
xs) = String
"(AllOf " forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {era}.
AllegraEraScript era =>
String -> NativeScript era -> String
accum String
")" StrictSeq (NativeScript era)
xs
  where
    accum :: String -> NativeScript era -> String
accum String
ans NativeScript era
x = forall era. AllegraEraScript era => NativeScript era -> String
showTimelock NativeScript era
x forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
ans
showTimelock (RequireAnyOf StrictSeq (NativeScript era)
xs) = String
"(AnyOf " forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {era}.
AllegraEraScript era =>
String -> NativeScript era -> String
accum String
")" StrictSeq (NativeScript era)
xs
  where
    accum :: String -> NativeScript era -> String
accum String
ans NativeScript era
x = forall era. AllegraEraScript era => NativeScript era -> String
showTimelock NativeScript era
x forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
ans
showTimelock (RequireMOf Int
m StrictSeq (NativeScript era)
xs) = String
"(MOf " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
m forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {era}.
AllegraEraScript era =>
String -> NativeScript era -> String
accum String
")" StrictSeq (NativeScript era)
xs
  where
    accum :: String -> NativeScript era -> String
accum String
ans NativeScript era
x = forall era. AllegraEraScript era => NativeScript era -> String
showTimelock NativeScript era
x forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
ans
showTimelock (RequireSignature KeyHash 'Witness
hash) = String
"(Signature " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show KeyHash 'Witness
hash forall a. [a] -> [a] -> [a]
++ String
")"

-- | Check the equality of two underlying types, while ignoring their binary
-- representation, which `Eq` instance normally does. This is used for testing.
eqTimelockRaw :: Timelock era -> Timelock era -> Bool
eqTimelockRaw :: forall k (era :: k). Timelock era -> Timelock era -> Bool
eqTimelockRaw Timelock era
t1 Timelock era
t2 = forall k (era :: k). TimelockRaw era -> TimelockRaw era -> Bool
go (forall t. Memoized t => t -> RawType t
getMemoRawType Timelock era
t1) (forall t. Memoized t => t -> RawType t
getMemoRawType Timelock era
t2)
  where
    seqEq :: StrictSeq (Timelock era) -> StrictSeq (Timelock era) -> Bool
seqEq StrictSeq (Timelock era)
Empty StrictSeq (Timelock era)
Empty = Bool
True
    seqEq (Timelock era
x :<| StrictSeq (Timelock era)
xs) (Timelock era
y :<| StrictSeq (Timelock era)
ys) = forall k (era :: k). Timelock era -> Timelock era -> Bool
eqTimelockRaw Timelock era
x Timelock era
y Bool -> Bool -> Bool
&& StrictSeq (Timelock era) -> StrictSeq (Timelock era) -> Bool
seqEq StrictSeq (Timelock era)
xs StrictSeq (Timelock era)
ys
    seqEq StrictSeq (Timelock era)
_ StrictSeq (Timelock era)
_ = Bool
False
    go :: TimelockRaw era -> TimelockRaw era -> Bool
go (Signature KeyHash 'Witness
kh1) (Signature KeyHash 'Witness
kh2) = KeyHash 'Witness
kh1 forall a. Eq a => a -> a -> Bool
== KeyHash 'Witness
kh2
    go (AllOf StrictSeq (Timelock era)
ts1) (AllOf StrictSeq (Timelock era)
ts2) = forall {k} {era :: k}.
StrictSeq (Timelock era) -> StrictSeq (Timelock era) -> Bool
seqEq StrictSeq (Timelock era)
ts1 StrictSeq (Timelock era)
ts2
    go (AnyOf StrictSeq (Timelock era)
ts1) (AnyOf StrictSeq (Timelock era)
ts2) = forall {k} {era :: k}.
StrictSeq (Timelock era) -> StrictSeq (Timelock era) -> Bool
seqEq StrictSeq (Timelock era)
ts1 StrictSeq (Timelock era)
ts2
    go (MOfN Int
n1 StrictSeq (Timelock era)
ts1) (MOfN Int
n2 StrictSeq (Timelock era)
ts2) = Int
n1 forall a. Eq a => a -> a -> Bool
== Int
n2 Bool -> Bool -> Bool
&& forall {k} {era :: k}.
StrictSeq (Timelock era) -> StrictSeq (Timelock era) -> Bool
seqEq StrictSeq (Timelock era)
ts1 StrictSeq (Timelock era)
ts2
    go (TimeStart SlotNo
sn1) (TimeStart SlotNo
sn2) = SlotNo
sn1 forall a. Eq a => a -> a -> Bool
== SlotNo
sn2
    go (TimeExpire SlotNo
sn1) (TimeExpire SlotNo
sn2) = SlotNo
sn1 forall a. Eq a => a -> a -> Bool
== SlotNo
sn2
    go TimelockRaw era
_ TimelockRaw era
_ = Bool
False