From d93201ef8e7ab93deabad8d83102769df5ebf630 Mon Sep 17 00:00:00 2001 From: Yura Lazaryev Date: Wed, 24 Apr 2024 20:41:36 +0200 Subject: [PATCH 1/3] Fix issue #5922 --- plutus-core/plutus-ir/src/PlutusIR/Contexts.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/plutus-core/plutus-ir/src/PlutusIR/Contexts.hs b/plutus-core/plutus-ir/src/PlutusIR/Contexts.hs index 9b3ac6c3f91..5cb784dcc7f 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Contexts.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Contexts.hs @@ -133,10 +133,12 @@ data SplitMatchContext tyname name uni fun a = SplitMatchContext } extractTyArgs :: AppContext tyname name uni fun a -> Maybe [Type tyname uni a] -extractTyArgs = go [] - where go acc (TypeAppContext ty _ ctx) = go (ty:acc) ctx - go _ (TermAppContext{}) = Nothing - go acc AppContextEnd = Just acc +extractTyArgs = go id + where + go acc = \case + TypeAppContext ty _ ctx -> go (acc . (ty :)) ctx + TermAppContext{} -> Nothing + AppContextEnd -> Just (acc []) -- | Split a normal datatype 'match'. splitNormalDatatypeMatch From b9ca13052d9745b331f565058fda35ec71616ab8 Mon Sep 17 00:00:00 2001 From: Yura Lazaryev Date: Thu, 25 Apr 2024 13:11:11 +0200 Subject: [PATCH 2/3] test_extractTyArgs --- plutus-core/plutus-core.cabal | 1 + .../plutus-ir/src/PlutusIR/Contexts.hs | 12 ++++-- .../plutus-ir/test/PlutusIR/Contexts/Tests.hs | 40 +++++++++++++++++++ 3 files changed, 49 insertions(+), 4 deletions(-) create mode 100644 plutus-core/plutus-ir/test/PlutusIR/Contexts/Tests.hs diff --git a/plutus-core/plutus-core.cabal b/plutus-core/plutus-core.cabal index adfa11c0efa..a4cc73b3581 100644 --- a/plutus-core/plutus-core.cabal +++ b/plutus-core/plutus-core.cabal @@ -608,6 +608,7 @@ test-suite plutus-ir-test PlutusIR.Compiler.Error.Tests PlutusIR.Compiler.Let.Tests PlutusIR.Compiler.Recursion.Tests + PlutusIR.Contexts.Tests PlutusIR.Core.Tests PlutusIR.Generators.QuickCheck.Tests PlutusIR.Parser.Tests diff --git a/plutus-core/plutus-ir/src/PlutusIR/Contexts.hs b/plutus-core/plutus-ir/src/PlutusIR/Contexts.hs index 5cb784dcc7f..93f52a8e716 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Contexts.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Contexts.hs @@ -8,6 +8,7 @@ module PlutusIR.Contexts where import Control.Lens +import Data.DList qualified as DList import Data.Functor (void) import PlutusCore.Arity import PlutusCore.Name.Unique qualified as PLC @@ -132,13 +133,16 @@ data SplitMatchContext tyname name uni fun a = SplitMatchContext , smBranches :: AppContext tyname name uni fun a } +-- | Extract the type application arguments from an 'AppContext'. +-- Returns 'Nothing' if the context contains a TermAppContext. +-- See 'test_extractTyArgs' extractTyArgs :: AppContext tyname name uni fun a -> Maybe [Type tyname uni a] -extractTyArgs = go id +extractTyArgs = go DList.empty where go acc = \case - TypeAppContext ty _ ctx -> go (acc . (ty :)) ctx - TermAppContext{} -> Nothing - AppContextEnd -> Just (acc []) + TypeAppContext ty _ann ctx -> go (DList.snoc acc ty) ctx + TermAppContext{} -> Nothing + AppContextEnd -> Just (DList.toList acc) -- | Split a normal datatype 'match'. splitNormalDatatypeMatch diff --git a/plutus-core/plutus-ir/test/PlutusIR/Contexts/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Contexts/Tests.hs new file mode 100644 index 00000000000..a9ae479ac6f --- /dev/null +++ b/plutus-core/plutus-ir/test/PlutusIR/Contexts/Tests.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE OverloadedStrings #-} + +module PlutusIR.Contexts.Tests where + +import PlutusIR +import PlutusIR.Contexts + +import PlutusCore.Default (DefaultFun, DefaultUni) +import PlutusCore.Name.Unique (Unique (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +test_extractTyArgs :: TestTree +test_extractTyArgs = + testGroup + "Applying extractTyArgs to an" + [ testCase "empty AppContext evaluates to an empty list of ty args" do + extractTyArgs AppContextEnd @?= Just ([] :: [Type TyName DefaultUni ()]) + , testCase "AppContext without type applications evaluates to Nothing" do + extractTyArgs (TermAppContext term () AppContextEnd) @?= Nothing + , testCase "AppContext with a mix of term and type applications evaluates to Nothing" do + extractTyArgs (TypeAppContext ty1 () (TermAppContext term () AppContextEnd)) @?= Nothing + extractTyArgs (TermAppContext term () (TypeAppContext ty1 () AppContextEnd)) @?= Nothing + , testCase "AppContext with type applications only evaluates to Just (list of ty vars)" do + extractTyArgs (TypeAppContext ty1 () (TypeAppContext ty2 () AppContextEnd)) + @?= Just [ty1, ty2] + ] + +---------------------------------------------------------------------------------------------------- +-- Test values ------------------------------------------------------------------------------------- + +term :: Term TyName Name DefaultUni DefaultFun () +term = Var () (Name "x" (Unique 0)) + +ty1 :: Type TyName DefaultUni () +ty1 = TyVar () (TyName (Name "t" (Unique 0))) + +ty2 :: Type TyName DefaultUni () +ty2 = TyVar () (TyName (Name "t" (Unique 1))) From cd14c4cb81c0ecd009769d369372f5f3b1fddd02 Mon Sep 17 00:00:00 2001 From: Yura Lazaryev Date: Fri, 26 Apr 2024 08:36:54 +0200 Subject: [PATCH 3/3] CaseOfCase: cover types with two type args --- .../PlutusIR/Transform/CaseOfCase/Tests.hs | 1 + .../PlutusIR/Transform/CaseOfCase/twoTyArgs | 30 ++++++++++++++ .../Transform/CaseOfCase/twoTyArgs.golden | 40 +++++++++++++++++++ 3 files changed, 71 insertions(+) create mode 100644 plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/twoTyArgs create mode 100644 plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/twoTyArgs.golden diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/Tests.hs index 437a700204e..9732d9f4a3a 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/Tests.hs @@ -21,6 +21,7 @@ test_caseOfCase = runTestNestedIn ["plutus-ir", "test", "PlutusIR", "Transform"] , "builtinBool" , "largeExpr" , "exponential" + , "twoTyArgs" ] prop_caseOfCase :: Property diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/twoTyArgs b/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/twoTyArgs new file mode 100644 index 00000000000..b6f5e161468 --- /dev/null +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/twoTyArgs @@ -0,0 +1,30 @@ +(let + (nonrec) + (datatypebind + (datatype + (tyvardecl d12 (fun (fun (type) (type)) (fun (type) (type)))) + (tyvardecl a3 (fun (type) (type))) (tyvardecl a10 (type)) + m11 + (vardecl c6 (fun (con unit) [ [ d12 a3 ] a10 ])) + ) + ) + [ + { + [ + { { m11 (con list) } (con unit) } + [ + { + [ + { { m11 (con list) } (con unit) } + (error [ [ d12 (con list) ] (con unit) ]) + ] + [ [ d12 (con list) ] (con unit) ] + } + (lam x23 (con unit) (error [ [ d12 (con list) ] (con unit) ])) + ] + ] + (con unit) + } + (error (fun (con unit) (con unit))) + ] +) diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/twoTyArgs.golden b/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/twoTyArgs.golden new file mode 100644 index 00000000000..b721532b7e4 --- /dev/null +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/CaseOfCase/twoTyArgs.golden @@ -0,0 +1,40 @@ +(let + (nonrec) + (datatypebind + (datatype + (tyvardecl d12 (fun (fun (type) (type)) (fun (type) (type)))) + (tyvardecl a3 (fun (type) (type))) (tyvardecl a10 (type)) + m11 + (vardecl c6 (fun (con unit) [ [ d12 a3 ] a10 ])) + ) + ) + (let + (nonrec) + (termbind + (strict) + (vardecl k_caseOfCase (fun [ [ d12 (con list) ] (con unit) ] (con unit))) + (lam + scrutinee + [ [ d12 (con list) ] (con unit) ] + [ + { [ { { m11 (con list) } (con unit) } scrutinee ] (con unit) } + (error (fun (con unit) (con unit))) + ] + ) + ) + [ + { + [ + { { m11 (con list) } (con unit) } + (error [ [ d12 (con list) ] (con unit) ]) + ] + (con unit) + } + (lam + x23 + (con unit) + [ k_caseOfCase (error [ [ d12 (con list) ] (con unit) ]) ] + ) + ] + ) +) \ No newline at end of file