Add Delay type and use it

Fixes #5908.

Unsure where to put this, it could go in its own module I guess.

plutus-tx-plugin/test/IsData/9.6/deconstructData.pir.golden

@@ -11,8 +11,6 @@ let
  Nothing : Maybe a
  !head : all a. list a -> a = headList
  !ifThenElse : all a. bool -> a -> a -> a = ifThenElse
- data Unit | Unit_match where
- Unit : Unit
  !chooseData : all a. data -> a -> a -> a -> a -> a -> a = chooseData
  !fst : all a b. pair a b -> a = fstPair
  !snd : all a b. pair a b -> b = sndPair
@@ -54,23 +52,24 @@ let
  \(bCase : bytestring -> r) ->
  let
  !bCase : bytestring -> r = bCase
+ !a : all b. r
+ = chooseData
+ {(\a -> all b. a) r}
+ d
+ (/\b ->
+ let
+ !tup : pair integer (list data)
+ = unsafeDataAsConstr d
+ in
+ constrCase
+ (fst {integer} {list data} tup)
+ (snd {integer} {list data} tup))
+ (/\b -> mapCase (unsafeDataAsMap d))
+ (/\b -> listCase (unsafeDataAsList d))
+ (/\b -> iCase (unsafeDataAsI d))
+ (/\b -> bCase (unsafeDataAsB d))
  in
- chooseData
- {Unit -> r}
- d
- (\(ds : Unit) ->
- let
- !tup : pair integer (list data)
- = unsafeDataAsConstr d
- in
- constrCase
- (fst {integer} {list data} tup)
- (snd {integer} {list data} tup))
- (\(ds : Unit) -> mapCase (unsafeDataAsMap d))
- (\(ds : Unit) -> listCase (unsafeDataAsList d))
- (\(ds : Unit) -> iCase (unsafeDataAsI d))
- (\(ds : Unit) -> bCase (unsafeDataAsB d))
- Unit
+ a {unit}
  !tail : all a. list a -> list a = tailList
  ~`$fFromDataTuple2_$cfromBuiltinData` :
  all a b.
@@ -101,22 +100,26 @@ let
  (ifThenElse {Bool} b True False)
  {all dead. Maybe (Tuple2 a b)}
  (/\dead ->
+ let
+ !a : all b. Maybe (Tuple2 data (list data))
+ = chooseList
+ {data}
+ {(\a -> all b. a)
+ (Maybe (Tuple2 data (list data)))}
+ args
+ (/\b -> Nothing {Tuple2 data (list data)})
+ (/\b ->
+ let
+ !h : data = head {data} args
+ !t : list data = tail {data} args
+ in
+ Just
+ {Tuple2 data (list data)}
+ (Tuple2 {data} {list data} h t))
+ in
  Maybe_match
  {Tuple2 data (list data)}
- (chooseList
- {data}
- {Unit -> Maybe (Tuple2 data (list data))}
- args
- (\(ds : Unit) -> Nothing {Tuple2 data (list data)})
- (\(ds : Unit) ->
- let
- !h : data = head {data} args
- !t : list data = tail {data} args
- in
- Just
- {Tuple2 data (list data)}
- (Tuple2 {data} {list data} h t))
- Unit)
+ (a {unit})
  {all dead. Maybe (Tuple2 a b)}
  (\(ds : Tuple2 data (list data)) ->
  /\dead ->
@@ -135,21 +138,24 @@ let
  {all dead. Maybe (Tuple2 a b)}
  (\(arg : a) ->
  /\dead ->
+ let
+ !a : all b. Maybe data
+ = chooseList
+ {data}
+ {(\a -> all b. a) (Maybe data)}
+ l
+ (/\b -> Nothing {data})
+ (/\b ->
+ let
+ !h : data = head {data} l
+ !ds : list data
+ = tail {data} l
+ in
+ Just {data} h)
+ in
  Maybe_match
  {data}
- (chooseList
- {data}
- {Unit -> Maybe data}
- l
- (\(ds : Unit) -> Nothing {data})
- (\(ds : Unit) ->
- let
- !h : data = head {data} l
- !ds : list data
- = tail {data} l
- in
- Just {data} h)
- Unit)
+ (a {unit})
  {all dead. Maybe (Tuple2 a b)}
  (\(ds : data) ->
  /\dead ->

plutus-tx-plugin/test/size/fromBuiltinData.size.golden

@@ -1 +1 @@
-346
+343

plutus-tx/src/PlutusTx/Builtins.hs

@@ -109,14 +109,15 @@ module PlutusTx.Builtins (
  ) where
 
 import Data.Maybe
-import PlutusTx.Base (const, uncurry)
+import PlutusTx.Base (uncurry)
 import PlutusTx.Bool (Bool (..))
 import PlutusTx.Builtins.Class
 import PlutusTx.Builtins.Internal (BuiltinBLS12_381_G1_Element (..),
  BuiltinBLS12_381_G2_Element (..), BuiltinBLS12_381_MlResult (..),
  BuiltinByteString (..), BuiltinData, BuiltinString)
 import PlutusTx.Builtins.Internal qualified as BI
 import PlutusTx.Integer (Integer)
+import PlutusTx.Utils
 
 import GHC.ByteOrder (ByteOrder (BigEndian, LittleEndian))
 
@@ -385,7 +386,7 @@ encodeUtf8 = BI.encodeUtf8
 
 {-# INLINABLE matchList #-}
 matchList :: forall a r . BI.BuiltinList a -> r -> (a -> BI.BuiltinList a -> r) -> r
-matchList l nilCase consCase = BI.chooseList l (const nilCase) (\_ -> consCase (BI.head l) (BI.tail l)) ()
+matchList l nilCase consCase = force (BI.chooseList l (Delay nilCase) (Delay (consCase (BI.head l) (BI.tail l))))
 
 {-# INLINE headMaybe #-}
 headMaybe :: BI.BuiltinList a -> Maybe a
@@ -484,14 +485,15 @@ matchData
  -> (BuiltinByteString -> r)
  -> r
 matchData d constrCase mapCase listCase iCase bCase =
+ force (
  chooseData
  d
- (\_ -> uncurry constrCase (unsafeDataAsConstr d))
- (\_ -> mapCase (unsafeDataAsMap d))
- (\_ -> listCase (unsafeDataAsList d))
- (\_ -> iCase (unsafeDataAsI d))
- (\_ -> bCase (unsafeDataAsB d))
-  ()
+ (Delay (uncurry constrCase (unsafeDataAsConstr d)))
+ (Delay (mapCase (unsafeDataAsMap d)))
+ (Delay (listCase (unsafeDataAsList d)))
+ (Delay (iCase (unsafeDataAsI d)))
+ (Delay (bCase (unsafeDataAsB d)))
+ )
 
 {-# INLINABLE matchData' #-}
 -- | Given a 'BuiltinData' value and matching functions for the five constructors,
@@ -505,14 +507,15 @@ matchData'
  -> (BuiltinByteString -> r)
  -> r
 matchData' d constrCase mapCase listCase iCase bCase =
+ force (
  chooseData
  d
- (\_ -> let tup = BI.unsafeDataAsConstr d in constrCase (BI.fst tup) (BI.snd tup))
- (\_ -> mapCase (BI.unsafeDataAsMap d))
- (\_ -> listCase (BI.unsafeDataAsList d))
- (\_ -> iCase (unsafeDataAsI d))
- (\_ -> bCase (unsafeDataAsB d))
-  ()
+ (Delay (let tup = BI.unsafeDataAsConstr d in constrCase (BI.fst tup) (BI.snd tup)))
+ (Delay (mapCase (BI.unsafeDataAsMap d)))
+ (Delay (listCase (BI.unsafeDataAsList d)))
+ (Delay (iCase (unsafeDataAsI d)))
+ (Delay (bCase (unsafeDataAsB d)))
+ )
 
 -- G1 --
 {-# INLINABLE bls12_381_G1_equals #-}

plutus-tx/src/PlutusTx/Utils.hs

@@ -1,10 +1,21 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -Wno-unused-foralls #-}
 module PlutusTx.Utils where
 
 -- We do not use qualified import because the whole module contains off-chain code
+import PlutusTx.Builtins.Internal qualified as BI
 import Prelude as Haskell
 
 mustBeReplaced :: String -> a
 mustBeReplaced placeholder =
  error $
  "The " <> show placeholder <> " placeholder must have been replaced by the \
  \core-to-plc plugin during compilation."
+
+-- | Delay evalaution of the expression inside the 'Delay' constructor.
+newtype Delay a = Delay (forall b. a)
+
+-- | Force the evaluation of the expression delayed by the 'Delay'.
+force :: Delay a -> a
+force (Delay a) = a @BI.BuiltinUnit