Test case that demonstrates lack of short-curicuiting under no GHC op…

…timisations.

plutus-tx-plugin/plutus-tx-plugin.cabal

@@ -158,6 +158,9 @@ test-suite plutus-tx-plugin-tests
     Plugin.Strict.Spec
     Plugin.Typeclasses.Lib
     Plugin.Typeclasses.Spec
+    ShortCircuit.Spec
+    ShortCircuit.WithGHCOptimisations
+    ShortCircuit.WithoutGHCOptimisations
     StdLib.Spec
     Strictness.Spec
     TH.Spec

plutus-tx-plugin/test/ShortCircuit/Spec.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell     #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module ShortCircuit.Spec (tests) where
+
+import ShortCircuit.WithGHCOptimisations qualified as WithOptimisations
+import ShortCircuit.WithoutGHCOptimisations qualified as WithoutOptimisations
+
+import Control.Lens ((&), (^.))
+import PlutusCore.Default (DefaultFun, DefaultUni)
+import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParameters)
+import PlutusTx.Code (CompiledCode, getPlc, unsafeApplyCode)
+import PlutusTx.Lift (liftCodeDef)
+import PlutusTx.TH (compile)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit (Assertion, assertEqual, assertFailure, testCase)
+import UntypedPlutusCore.Core.Type (Term (Constr), progTerm)
+import UntypedPlutusCore.Evaluation.Machine.Cek (counting, noEmitter)
+import UntypedPlutusCore.Evaluation.Machine.Cek.Internal (NTerm, runCekDeBruijn)
+
+tests :: TestTree
+tests = testGroup "ShortCircuit" [withGhcOptimisations, withoutGhcOptimisations]
+
+withGhcOptimisations :: TestTree
+withGhcOptimisations =
+  testGroup
+    "GHC Optimisations ON"
+    [ testCase "GHC inlines the (&&) unfolding making it short-circuit" $
+        unsafeApplyCode $$(compile [||WithOptimisations.shortCircuitAnd||]) false'
+          & assertResult termFalse
+    , testCase "GHC inlines the (||) unfolding making it short-circuit" do
+        unsafeApplyCode $$(compile [||WithOptimisations.shortCircuitOr||]) true'
+          & assertResult termTrue
+    ]
+
+withoutGhcOptimisations :: TestTree
+withoutGhcOptimisations =
+  testGroup
+    "GHC Optimisations OFF"
+    [ testCase "(&&) isn't inlined but it short-circuits anyway" do
+        unsafeApplyCode $$(compile [||WithoutOptimisations.shortCircuitAnd||]) false'
+          & assertResult termFalse
+    , testCase "(||) isn't inlined but it short-circuits anyway" do
+        unsafeApplyCode $$(compile [||WithoutOptimisations.shortCircuitOr||]) true'
+          & assertResult termTrue
+    ]
+
+----------------------------------------------------------------------------------------------------
+-- Helpers -----------------------------------------------------------------------------------------
+
+assertResult :: NTerm DefaultUni DefaultFun () -> CompiledCode a -> Assertion
+assertResult expected code =
+  case runCekDeBruijn defaultCekParameters counting noEmitter (getPlc code ^. progTerm) of
+    (Left ex, _counting, _logs)      -> assertFailure $ show ex
+    (Right actual, _counting, _logs) -> assertEqual "Evaluation has succeeded" expected actual
+
+false' :: CompiledCode Bool
+false' = liftCodeDef False
+
+true' :: CompiledCode Bool
+true' = liftCodeDef True
+
+termFalse :: Term name uni fun ()
+termFalse = Constr mempty 1 []
+
+termTrue :: Term name uni fun ()
+termTrue = Constr mempty 0 []

plutus-tx-plugin/test/ShortCircuit/WithGHCOptimisations.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -O1 #-}
+
+module ShortCircuit.WithGHCOptimisations
+  ( shortCircuitAnd
+  , shortCircuitOr
+  ) where
+
+import PlutusTx.Prelude (error, (&&), (||))
+import Prelude (Bool)
+
+shortCircuitAnd :: Bool -> Bool
+shortCircuitAnd x = x && error ()
+
+shortCircuitOr :: Bool -> Bool
+shortCircuitOr x = x || error ()

plutus-tx-plugin/test/ShortCircuit/WithoutGHCOptimisations.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -O0 #-}
+{-# OPTIONS_GHC -fmax-simplifier-iterations=0 #-}
+{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-}
+{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
+
+module ShortCircuit.WithoutGHCOptimisations
+  ( shortCircuitAnd
+  , shortCircuitOr
+  ) where
+
+import PlutusTx.Prelude (error, (&&), (||))
+import Prelude (Bool)
+
+shortCircuitAnd :: Bool -> Bool
+shortCircuitAnd x = x && error ()
+
+shortCircuitOr :: Bool -> Bool
+shortCircuitOr x = x || error ()

plutus-tx-plugin/test/Spec.hs

@@ -12,6 +12,7 @@ import IsData.Spec qualified as IsData
 import Lift.Spec qualified as Lift
 import Optimization.Spec qualified as Optimization
 import Plugin.Spec qualified as Plugin
+import ShortCircuit.Spec qualified as ShortCircuit
 import StdLib.Spec qualified as Lib
 import Strictness.Spec qualified as Strictness
 import TH.Spec qualified as TH
@@ -38,6 +39,7 @@ tests =
       , Budget.tests
       , AsData.Budget.tests
       , Optimization.tests
+      , pure ShortCircuit.tests
       , Strictness.tests
       , Blueprint.Tests.goldenTests
       ]