wip - pattern synonyms

IntersectMBO · May 3, 2024 · f125f56 · f125f56
1 parent 61a010e
commit f125f56
Show file tree

Hide file tree

Showing 13 changed files with 227 additions and 130 deletions.
diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Scripts.hs
@@ -22,8 +22,8 @@
 module Cardano.Ledger.Allegra.Scripts (
   AllegraEraScript (..),
   Timelock (
-    RequireSignature,
-    RequireAllOf,
+    -- RequireSignature,
+    -- RequireAllOf,
     RequireAnyOf,
     RequireMOf,
     RequireTimeExpire,
@@ -76,7 +76,13 @@ import Cardano.Ledger.MemoBytes (
   mkMemoized,
  )
 import Cardano.Ledger.SafeHash (SafeToHash)
-import Cardano.Ledger.Shelley.Scripts (ShelleyEraScript (..), nativeMultiSigTag)
+import Cardano.Ledger.Shelley.Scripts (
+  ShelleyEraScript (..),
+  nativeMultiSigTag,
+  pattern RequireAllOfX,
+  pattern RequireSignatureX,
+ )
+
 import qualified Cardano.Ledger.Shelley.Scripts as Shelley
 import Cardano.Slotting.Slot (SlotNo (..))
 import Control.DeepSeq (NFData (..))
@@ -214,8 +220,8 @@ instance Crypto c => EraScript (AllegraEra c) where
   type NativeScript (AllegraEra c) = Timelock (AllegraEra c)
 
   upgradeScript = \case
-    Shelley.RequireSignature keyHash -> RequireSignature keyHash
-    Shelley.RequireAllOf sigs -> RequireAllOf $ Seq.fromList $ map upgradeScript sigs
+    RequireSignatureX keyHash -> undefined -- RequireSignatureX keyHash
+    RequireAllOfX sigs -> undefined -- RequireAllOf $ Seq.fromList $ map upgradeScript sigs
     Shelley.RequireAnyOf sigs -> RequireAnyOf $ Seq.fromList $ map upgradeScript sigs
     Shelley.RequireMOf n sigs -> RequireMOf n $ Seq.fromList $ map upgradeScript sigs
 
@@ -226,11 +232,17 @@ instance Crypto c => EraScript (AllegraEra c) where
   fromNativeScript = id
 
 instance Crypto c => ShelleyEraScript (AllegraEra c) where
-  mkRequireSignature = RequireSignature
-  mkRequireAllOf = RequireAllOf . Seq.fromList
+  mkRequireSignature kh = mkMemoized (Signature kh)
+  mkRequireAllOf ms = mkMemoized (AllOf (Seq.fromList ms))
   mkRequireAnyOf = RequireAnyOf . Seq.fromList
   mkRequireMOf n = RequireMOf n . Seq.fromList
 
+  getRequireSignature (TimelockConstr (Memo (Signature kh) _)) = Just kh
+  getRequireSignature _ = Nothing
+  getRequireAnyOf = undefined
+  getRequireAllOf = undefined
+  getRequireMOf = undefined
+
 instance Crypto c => AllegraEraScript (AllegraEra c) where
   mkTimeStart = RequireTimeStart
   mkTimeExpire = RequireTimeExpire
@@ -243,15 +255,15 @@ deriving via
   instance
     Era era => DecCBOR (Annotator (Timelock era))
 
-pattern RequireSignature :: Era era => KeyHash 'Witness (EraCrypto era) -> Timelock era
-pattern RequireSignature akh <- (getMemoRawType -> Signature akh)
-  where
-    RequireSignature akh = mkMemoized (Signature akh)
+-- pattern RequireSignature :: Era era => KeyHash 'Witness (EraCrypto era) -> Timelock era
+-- pattern RequireSignature akh <- (getMemoRawType -> Signature akh)
+--   where
+--     RequireSignature akh = mkMemoized (Signature akh)
 
-pattern RequireAllOf :: Era era => StrictSeq (Timelock era) -> Timelock era
-pattern RequireAllOf ms <- (getMemoRawType -> AllOf ms)
-  where
-    RequireAllOf ms = mkMemoized (AllOf ms)
+-- pattern RequireAllOf :: Era era => StrictSeq (Timelock era) -> Timelock era
+-- pattern RequireAllOf ms <- (getMemoRawType -> AllOf ms)
+--   where
+--     RequireAllOf ms = mkMemoized (AllOf ms)
 
 pattern RequireAnyOf :: Era era => StrictSeq (Timelock era) -> Timelock era
 pattern RequireAnyOf ms <- (getMemoRawType -> AnyOf ms)
@@ -273,14 +285,14 @@ pattern RequireTimeStart mslot <- (getMemoRawType -> TimeStart mslot)
   where
     RequireTimeStart mslot = mkMemoized (TimeStart mslot)
 
-{-# COMPLETE
-  RequireSignature
-  , RequireAllOf
-  , RequireAnyOf
-  , RequireMOf
-  , RequireTimeExpire
-  , RequireTimeStart
-  #-}
+-- {-# COMPLETE
+--   RequireSignature
+--   , RequireAllOf
+--   , RequireAnyOf
+--   , RequireMOf
+--   , RequireTimeExpire
+--   , RequireTimeStart
+--   #-}
 
 -- =================================================================
 -- Evaluating and validating a Timelock
@@ -296,10 +308,11 @@ ltePosInfty SNothing _ = False -- ∞ > j
 ltePosInfty (SJust i) j = i <= j
 
 evalTimelock ::
-  Era era =>
+  AllegraEraScript era =>
   Set.Set (KeyHash 'Witness (EraCrypto era)) ->
   ValidityInterval ->
-  Timelock era ->
+  -- Timelock era ->
+  NativeScript era ->
   Bool
 evalTimelock vhks (ValidityInterval txStart txExp) = go
   where
@@ -309,12 +322,13 @@ evalTimelock vhks (ValidityInterval txStart txExp) = go
     isValidMOf n (ts SSeq.:<| tss) =
       n <= 0 || if go ts then isValidMOf (n - 1) tss else isValidMOf n tss
     go = \case
-      RequireTimeStart lockStart -> lockStart `lteNegInfty` txStart
-      RequireTimeExpire lockExp -> txExp `ltePosInfty` lockExp
-      RequireSignature hash -> hash `Set.member` vhks
-      RequireAllOf xs -> all go xs
-      RequireAnyOf xs -> any go xs
-      RequireMOf m xs -> isValidMOf m xs
+      -- RequireTimeStart lockStart -> lockStart `lteNegInfty` txStart
+      -- RequireTimeExpire lockExp -> txExp `ltePosInfty` lockExp
+      RequireSignatureX hash -> hash `Set.member` vhks
+      -- RequireAllOf xs -> all go xs
+      -- RequireAnyOf xs -> any go xs
+      -- RequireMOf m xs -> isValidMOf m xs
+      _ -> undefined
 
 -- =========================================================
 -- Operations on Timelock scripts
@@ -328,19 +342,20 @@ inInterval slot (ValidityInterval (SJust bottom) SNothing) = bottom <= slot
 inInterval slot (ValidityInterval (SJust bottom) (SJust top)) =
   bottom <= slot && slot < top
 
-showTimelock :: Era era => Timelock era -> String
-showTimelock (RequireTimeStart (SlotNo i)) = "(Start >= " ++ show i ++ ")"
-showTimelock (RequireTimeExpire (SlotNo i)) = "(Expire < " ++ show i ++ ")"
-showTimelock (RequireAllOf xs) = "(AllOf " ++ foldl accum ")" xs
-  where
-    accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireAnyOf xs) = "(AnyOf " ++ foldl accum ")" xs
-  where
-    accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireMOf m xs) = "(MOf " ++ show m ++ " " ++ foldl accum ")" xs
-  where
-    accum ans x = showTimelock x ++ " " ++ ans
-showTimelock (RequireSignature hash) = "(Signature " ++ show hash ++ ")"
+showTimelock :: AllegraEraScript era => NativeScript era -> String
+-- showTimelock (RequireTimeStart (SlotNo i)) = "(Start >= " ++ show i ++ ")"
+-- showTimelock (RequireTimeExpire (SlotNo i)) = "(Expire < " ++ show i ++ ")"
+-- showTimelock (RequireAllOf xs) = "(AllOf " ++ foldl accum ")" xs
+--   where
+--     accum ans x = showTimelock x ++ " " ++ ans
+-- showTimelock (RequireAnyOf xs) = "(AnyOf " ++ foldl accum ")" xs
+--   where
+--     accum ans x = showTimelock x ++ " " ++ ans
+-- showTimelock (RequireMOf m xs) = "(MOf " ++ show m ++ " " ++ foldl accum ")" xs
+--   where
+--     accum ans x = showTimelock x ++ " " ++ ans
+showTimelock (RequireSignatureX hash) = "(Signature " ++ show hash ++ ")"
+showTimeLock _ = undefined
 
 -- | Check the equality of two underlying types, while ignoring their binary
 -- representation, which `Eq` instance normally does. This is used for testing.

diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Tx.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Tx.hs
@@ -13,14 +13,15 @@ where
 
 import Cardano.Ledger.Allegra.Era (AllegraEra)
 import Cardano.Ledger.Allegra.PParams ()
-import Cardano.Ledger.Allegra.Scripts (Timelock, evalTimelock)
+import Cardano.Ledger.Allegra.Scripts (AllegraEraScript (..), Timelock, evalTimelock)
 import Cardano.Ledger.Allegra.TxAuxData ()
 import Cardano.Ledger.Allegra.TxBody (AllegraEraTxBody (..))
 import Cardano.Ledger.Allegra.TxWits ()
 import Cardano.Ledger.Core (
   EraTx (..),
   EraTxAuxData (upgradeTxAuxData),
   EraTxWits (..),
+  NativeScript,
   upgradeTxBody,
  )
 import Cardano.Ledger.Crypto (Crypto, StandardCrypto)
@@ -75,7 +76,7 @@ instance Crypto c => EraTx (AllegraEra c) where
 -- We still need to correctly compute the witness set for TxBody as well.
 
 validateTimelock ::
-  (EraTx era, AllegraEraTxBody era) => Tx era -> Timelock era -> Bool
+  (EraTx era, AllegraEraTxBody era, AllegraEraScript era) => Tx era -> NativeScript era -> Bool
 validateTimelock tx timelock = evalTimelock vhks (tx ^. bodyTxL . vldtTxBodyL) timelock
   where
     vhks = Set.map witVKeyHash (tx ^. witsTxL . addrTxWitsL)

diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Arbitrary.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Arbitrary.hs
@@ -14,7 +14,7 @@ module Test.Cardano.Ledger.Allegra.Arbitrary (
 ) where
 
 import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure)
-import Cardano.Ledger.Allegra.Scripts (Timelock (..), ValidityInterval (..))
+import Cardano.Ledger.Allegra.Scripts (AllegraEraScript (..), Timelock (..), ValidityInterval (..))
 import Cardano.Ledger.Allegra.TxAuxData (AllegraTxAuxData (..))
 import Cardano.Ledger.Allegra.TxBody (AllegraTxBody (AllegraTxBody))
 import Cardano.Ledger.Binary (EncCBOR)
@@ -44,37 +44,40 @@ maxTimelockListLens :: Int
 maxTimelockListLens = 5
 
 sizedTimelock ::
-  Era era =>
+  AllegraEraScript era =>
   Int ->
-  Gen (Timelock era)
-sizedTimelock 0 = RequireSignature . KeyHash . mkDummyHash <$> (arbitrary :: Gen Int)
-sizedTimelock n =
-  oneof
-    [ RequireSignature . KeyHash . mkDummyHash <$> (arbitrary :: Gen Int)
-    , RequireAllOf
-        <$> ( fromList
-                <$> resize
-                  maxTimelockListLens
-                  (listOf (sizedTimelock (n - 1)))
-            )
-    , RequireAnyOf
-        <$> ( fromList
-                <$> resize
-                  maxTimelockListLens
-                  (listOf (sizedTimelock (n - 1)))
-            )
-    , do
-        subs <- resize maxTimelockListLens (listOf (sizedTimelock (n - 1)))
-        let i = length subs
-        RequireMOf <$> choose (0, i) <*> pure (fromList subs)
-    , RequireTimeStart <$> arbitrary
-    , RequireTimeExpire <$> arbitrary
-    ]
+  Gen (NativeScript era)
+sizedTimelock = undefined
+
+-- sizedTimelock 0 = RequireSignature . KeyHash . mkDummyHash <$> (arbitrary :: Gen Int)
+-- sizedTimelock n =
+--   oneof
+--     [ RequireSignature . KeyHash . mkDummyHash <$> (arbitrary :: Gen Int)
+--     , RequireAllOf
+--         <$> ( fromList
+--                 <$> resize
+--                   maxTimelockListLens
+--                   (listOf (sizedTimelock (n - 1)))
+--             )
+--     , RequireAnyOf
+--         <$> ( fromList
+--                 <$> resize
+--                   maxTimelockListLens
+--                   (listOf (sizedTimelock (n - 1)))
+--             )
+--     , do
+--         subs <- resize maxTimelockListLens (listOf (sizedTimelock (n - 1)))
+--         let i = length subs
+--         RequireMOf <$> choose (0, i) <*> pure (fromList subs)
+--     , RequireTimeStart <$> arbitrary
+--     , RequireTimeExpire <$> arbitrary
+--     ]
 
 -- TODO Generate metadata with script preimages
 instance
   forall era.
-  ( EncCBOR (Script era)
+  ( AllegraEraScript era
+  , EncCBOR (Script era)
   , Arbitrary (Script era)
   , Era era
   ) =>
@@ -95,7 +98,7 @@ instance
     genMetadata' @era >>= \case
       ShelleyTxAuxData m -> AllegraTxAuxData m <$> (genScriptSeq @era)
 
-genScriptSeq :: Era era => Gen (StrictSeq (Timelock era))
+genScriptSeq :: AllegraEraScript era => Gen (StrictSeq (Timelock era))
 genScriptSeq = do
   n <- choose (0, 3)
   l <- vectorOf n arbitrary
@@ -131,8 +134,8 @@ instance
       <*> scale (`div` 15) arbitrary
       <*> arbitrary
 
-instance Era era => Arbitrary (Timelock era) where
-  arbitrary = sizedTimelock maxTimelockDepth
+instance AllegraEraScript era => Arbitrary (Timelock era) where
+  arbitrary = undefined -- sizedTimelock maxTimelockDepth
 
 instance Arbitrary ValidityInterval where
   arbitrary = genericArbitraryU

diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -15,9 +16,12 @@ import Cardano.Crypto.DSIGN (DSIGNAlgorithm (..), Ed25519DSIGN)
 import Cardano.Crypto.Hash.Class (Hash)
 import Cardano.Ledger.Allegra (AllegraEra)
 import Cardano.Ledger.Allegra.Core
-import Cardano.Ledger.Allegra.Scripts (Timelock (..))
+import Cardano.Ledger.Allegra.Scripts (AllegraEraScript, Timelock (..))
 import Cardano.Ledger.Crypto (Crypto (..))
 import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
+import Cardano.Ledger.Shelley.Scripts (
+  pattern RequireSignatureX,
+ )
 import Control.Monad.State.Strict (get)
 import qualified Data.Map.Strict as Map
 import Data.Sequence.Strict (StrictSeq (..))
@@ -44,7 +48,7 @@ instance
   fixupTx = shelleyFixupTx
 
 impAllegraSatisfyNativeScript ::
-  (ShelleyEraImp era, NativeScript era ~ Timelock era) =>
+  (ShelleyEraImp era, AllegraEraScript era) =>
   Set.Set (KeyHash 'Witness (EraCrypto era)) ->
   NativeScript era ->
   ImpTestM era (Maybe (Map.Map (KeyHash 'Witness (EraCrypto era)) (KeyPair 'Witness (EraCrypto era))))
@@ -63,18 +67,19 @@ impAllegraSatisfyNativeScript providedVKeyHashes script = do
           kps' <- satisfyMOf (m - 1) xs
           Just $ kps <> kps'
     satisfyScript = \case
-      RequireSignature keyHash
+      RequireSignatureX keyHash
         | keyHash `Set.member` providedVKeyHashes -> Just mempty
         | otherwise -> do
             keyPair <- Map.lookup keyHash keyPairs
             Just $ Map.singleton keyHash keyPair
-      RequireAllOf ss -> satisfyMOf (length ss) ss
-      RequireAnyOf ss -> satisfyMOf 1 ss
-      RequireMOf m ss -> satisfyMOf m ss
-      RequireTimeExpire slotNo
-        | slotNo < prevSlotNo -> Just mempty
-        | otherwise -> Nothing
-      RequireTimeStart slotNo
-        | slotNo > prevSlotNo -> Just mempty
-        | otherwise -> Nothing
+      _ -> undefined
+  -- RequireAllOf ss -> satisfyMOf (length ss) ss
+  -- RequireAnyOf ss -> satisfyMOf 1 ss
+  -- RequireMOf m ss -> satisfyMOf m ss
+  -- RequireTimeExpire slotNo
+  --   | slotNo < prevSlotNo -> Just mempty
+  --   | otherwise -> Nothing
+  -- RequireTimeStart slotNo
+  --   | slotNo > prevSlotNo -> Just mempty
+  --   | otherwise -> Nothing
   pure $ satisfyScript script
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Scripts.hs
@@ -112,6 +112,7 @@ import Cardano.Ledger.Plutus.Language (
  )
 import Cardano.Ledger.SafeHash (SafeToHash (..))
 import Cardano.Ledger.Shelley.Scripts (ShelleyEraScript (..), nativeMultiSigTag)
+import qualified Cardano.Ledger.Shelley.Scripts as Shelley
 import Cardano.Ledger.TxIn (TxIn)
 import Control.DeepSeq (NFData (..), deepseq)
 import Control.Monad (guard)
@@ -468,11 +469,16 @@ alonzoScriptPrefixTag = \case
   PlutusScript plutusScript -> BS.singleton (withPlutusScript plutusScript plutusLanguageTag)
 
 instance Crypto c => ShelleyEraScript (AlonzoEra c) where
-  mkRequireSignature = RequireSignature
-  mkRequireAllOf = RequireAllOf . Seq.fromList
+  mkRequireSignature = Shelley.mkRequireSignature
+  mkRequireAllOf = Shelley.mkRequireAllOf -- . Seq.fromList
   mkRequireAnyOf = RequireAnyOf . Seq.fromList
   mkRequireMOf n = RequireMOf n . Seq.fromList
 
+  getRequireSignature = undefined
+  getRequireAnyOf = undefined
+  getRequireAllOf = undefined
+  getRequireMOf = undefined
+
 instance Crypto c => AllegraEraScript (AlonzoEra c) where
   mkTimeStart = RequireTimeStart
   mkTimeExpire = RequireTimeExpire