Add simple force-delay tests + clean-up

plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs

@@ -6,17 +6,14 @@
 {-# LANGUAGE TemplateHaskell        #-}
 {-# LANGUAGE TypeApplications       #-}
 
-{- | Defines the 'Name' type used for identifiers in Plutus Core together with a technique
- to minimise the cost of 'Name' comparisons.
-
- A 'Name' is a piece of text used to identify a variable inside the Plutus Core languages.
+{- | A 'Name' is a datatype used to identify a variable inside the Plutus Core languages.
  Name comparisons are a fundamental part of the domain logic, and comparing 'Text' directly
  is inefficient. As a solution to this problem, we provide the 'Unique' type which is an
  integer associated to the 'Name', unique to each instantiation of the type. We can,
  therefore, compare the integers instead, which is obviously much more cost-effective.
 
- We distinguish between the names of term variables and type variables by defining wrappers
- over 'Name': 'TermName' and 'TyName'. Since the code we usually write is polymorphic in the
+ We distinguish between the names of term variables and type variables by defining the
+ 'TyName' wrapper over 'Name'. Since the code we usually write is polymorphic in the
  name type, we want to be able to define a class of names which have an associated 'Unique'.
  This class is 'HasUnique', see the definition below.
 -}

plutus-core/plutus-core/src/PlutusCore/Name/UniqueMap.hs

@@ -6,20 +6,18 @@
 
 module PlutusCore.Name.UniqueMap (
   UniqueMap (..),
-insertByUnique,
-insertByName,
-singletonByName,
-insertNamed,
-insertByNameIndex,
-fromFoldable,
-fromUniques,
-fromNames,
-lookupUnique,
-lookupName,
-restrictKeys,
-foldr,
-lookupNameIndex,
-isEmpty,
+  insertByUnique,
+  insertByName,
+  singletonByName,
+  insertNamed,
+  insertByNameIndex,
+  fromFoldable,
+  fromUniques,
+  fromNames,
+  lookupUnique,
+  lookupName,
+  restrictKeys,
+  lookupNameIndex,
 ) where
 
 import Control.Lens (view)
@@ -38,7 +36,8 @@ import Prelude hiding (foldr)
 newtype UniqueMap unique a = UniqueMap
   { unUniqueMap :: IM.IntMap a
   }
-  deriving newtype (Show, Eq, Semigroup, Monoid, Functor)
+  deriving stock (Show, Eq)
+  deriving newtype (Semigroup, Monoid, Functor, Foldable)
 
 -- | Insert a value @a@ by a @unique@.
 insertByUnique ::
@@ -106,9 +105,6 @@ restrictKeys :: UniqueMap unique v -> UniqueSet unique -> UniqueMap unique v
 restrictKeys (UniqueMap m) (UniqueSet s) =
   UniqueMap $ IM.restrictKeys m s
 
-foldr :: (a -> b -> b) -> b -> UniqueMap unique a -> b
-foldr f unit (UniqueMap m) = IM.foldr f unit m
-
 {- | Look up a value by the index of the unique of a name.
 Unlike 'lookupUnique' and 'lookupName', this function does not provide any static guarantees,
 so you can for example look up a type-level name in a map from term-level uniques.
@@ -119,7 +115,3 @@ lookupNameIndex ::
   UniqueMap unique2 a ->
   Maybe a
 lookupNameIndex = lookupUnique . coerce . view unique
-
-{-# INLINE isEmpty #-}
-isEmpty :: UniqueMap unique a -> Bool
-isEmpty (UniqueMap m) = IM.null m

plutus-core/plutus-core/src/PlutusCore/Name/UniqueSet.hs

@@ -34,7 +34,8 @@ import PlutusCore.Name.Unique (HasUnique (..), Unique (Unique))
 newtype UniqueSet unique = UniqueSet
   { unUniqueSet :: IS.IntSet
   }
-  deriving newtype (Show, Eq, Semigroup, Monoid)
+  deriving stock (Show, Eq)
+  deriving newtype (Semigroup, Monoid)
 
 -- | Insert a @unique@.
 insertByUnique ::

plutus-core/plutus-ir/src/PlutusIR/Transform/Inline/Utils.hs

@@ -158,7 +158,7 @@ lookupType tn s = UMap.lookupName tn $ s ^. typeSubst . unTypeSubst
 
 -- | Check if the type substitution is empty.
 isTypeSubstEmpty :: InlinerState tyname name uni fun ann -> Bool
-isTypeSubstEmpty (InlinerState _ (TypeSubst tyEnv) _) = UMap.isEmpty tyEnv
+isTypeSubstEmpty (InlinerState _ (TypeSubst tyEnv) _) = null tyEnv
 
 -- | Insert the unprocessed type variable into the type substitution.
 extendType

plutus-core/plutus-ir/src/PlutusIR/Transform/LetFloatOut.hs

@@ -434,7 +434,7 @@ floatTerm binfo t =
 -- HELPERS
 
 maxPos :: PLC.UniqueMap k Pos -> Pos
-maxPos = UMap.foldr max topPos
+maxPos = foldr max topPos
 
 withDepth :: (r ~ MarkCtx tyname name uni fun a2, MonadReader r m)
           => (Depth -> Depth) -> m a -> m a

plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Transform/ForceDelay.hs

@@ -1,4 +1,6 @@
-{- | The 'ForceDelay' optimisation pushes 'Force' inside its direct 'Apply' subterms,
+{- Note [Cancelling interleaved Force-Delay pairs]
+
+ The 'ForceDelay' optimisation pushes 'Force' inside its direct 'Apply' subterms,
  removing any 'Delay' at the top of the body of the underlying lambda abstraction.
  For example, @force [(\x -> delay b) a]@ is transformed into @[(\x -> b) a]@.
  We also consider the case where the 'Force' is applied directly to the 'Delay' as
@@ -138,7 +140,6 @@ import UntypedPlutusCore.Core
 import Control.Lens (transformOf)
 import Control.Monad (guard)
 import Data.Foldable (foldl')
-import Data.Maybe (fromMaybe)
 
 {- | Traverses the term, for each node applying the optimisation
  detailed above. For implementation details see 'optimisationProcedure'.
@@ -153,7 +154,9 @@ processTerm :: Term name uni fun a -> Term name uni fun a
 processTerm = \case
     Force _ (Delay _ t) -> t
     original@(Force _ subTerm) ->
-        fromMaybe original (optimisationProcedure subTerm)
+        case optimisationProcedure subTerm of
+            Just result -> result
+            Nothing     -> original
     t -> t
 
 {- | Converts the subterm of a 'Force' into specialised types for representing

plutus-core/untyped-plutus-core/test/Transform/Simplify.hs

@@ -227,6 +227,18 @@ multiApp = runQuote $ do
       app = mkIterAppNoAnn lam [mkConstant @Integer () 1, mkConstant @Integer () 2, mkConstant @Integer () 3]
   pure app
 
+forceDelayNoApps :: Term Name PLC.DefaultUni PLC.DefaultFun ()
+forceDelayNoApps = runQuote $ do
+  let one = mkConstant @Integer () 1
+      term = Force () $ Delay () $ Force () $ Delay () $ Force () $ Delay () one
+  pure term
+
+forceDelayNoAppsLayered :: Term Name PLC.DefaultUni PLC.DefaultFun ()
+forceDelayNoAppsLayered = runQuote $ do
+  let one = mkConstant @Integer () 1
+      term = Force () $ Force () $ Force () $ Delay () $ Delay () $ Delay () one
+  pure term
+
 -- | The UPLC term in this test should come from the following TPLC term after erasing its types:
 -- > (/\(p :: *) -> \(x : p) -> /\(q :: *) -> \(y : q) -> /\(r :: *) -> \(z : r) -> z) Int 1 Int 2 Int 3
 -- This case is simple in the sense that each type abstraction is followed by a single term abstraction.
@@ -442,6 +454,8 @@ test_simplify =
     , goldenVsSimplified "inlineImpure3" inlineImpure3
     , goldenVsSimplified "inlineImpure4" inlineImpure4
     , goldenVsSimplified "multiApp" multiApp
+    , goldenVsSimplified "forceDelayNoApps" forceDelayNoApps
+    , goldenVsSimplified "forceDelayNoAppsLayered" forceDelayNoAppsLayered
     , goldenVsSimplified "forceDelaySimple" forceDelaySimple
     , goldenVsSimplified "forceDelayMultiApply" forceDelayMultiApply
     , goldenVsSimplified "forceDelayMultiForce" forceDelayMultiForce

plutus-core/untyped-plutus-core/test/Transform/forceDelayNoApps.uplc.golden

@@ -0,0 +1 @@
+1

plutus-core/untyped-plutus-core/test/Transform/forceDelayNoAppsLayered.uplc.golden

@@ -0,0 +1 @@
+1