From 7bad870d9d11252cac59a6cd4bbf4ad5bfef3ee6 Mon Sep 17 00:00:00 2001 From: Seungheon Oh Date: Mon, 19 May 2025 21:21:21 +0900 Subject: [PATCH] Run fourmolu against `plutus-tx-plugin` files --- .../app/GeneratePluginOptionsDoc.hs | 37 +- .../src/PlutusTx/Compiler/Binders.hs | 162 +-- .../src/PlutusTx/Compiler/Builtins.hs | 959 +++++++++--------- .../src/PlutusTx/Compiler/Error.hs | 121 ++- .../src/PlutusTx/Compiler/Expr.hs | 839 +++++++-------- .../src/PlutusTx/Compiler/Kind.hs | 20 +- .../src/PlutusTx/Compiler/Laziness.hs | 42 +- .../src/PlutusTx/Compiler/Names.hs | 18 +- .../src/PlutusTx/Compiler/Trace.hs | 51 +- .../src/PlutusTx/Compiler/Type.hs | 50 +- .../src/PlutusTx/Compiler/Types.hs | 228 +++-- .../src/PlutusTx/Compiler/Utils.hs | 81 +- plutus-tx-plugin/src/PlutusTx/Options.hs | 80 +- plutus-tx-plugin/src/PlutusTx/Plugin.hs | 889 ++++++++-------- plutus-tx-plugin/test/Array/Spec.hs | 2 +- plutus-tx-plugin/test/AsData/Budget/Spec.hs | 43 +- plutus-tx-plugin/test/Blueprint/Tests.hs | 16 +- plutus-tx-plugin/test/Blueprint/Tests/Lib.hs | 8 +- .../Blueprint/Tests/Lib/AsData/Blueprint.hs | 2 +- .../test/Blueprint/Tests/Lib/AsData/Decls.hs | 2 +- plutus-tx-plugin/test/Budget/Spec.hs | 646 +++++++----- .../test/Budget/WithGHCOptimisations.hs | 3 +- .../test/Budget/WithoutGHCOptimisations.hs | 2 +- .../test/BuiltinList/Budget/Spec.hs | 2 +- plutus-tx-plugin/test/DataList/Budget/Spec.hs | 12 +- plutus-tx-plugin/test/Inline/Spec.hs | 34 +- .../NoStrict/NegativeLiterals/Spec.hs | 25 +- .../NoStrict/NoNegativeLiterals/Spec.hs | 23 +- .../Strict/NegativeLiterals/Spec.hs | 25 +- .../Strict/NoNegativeLiterals/Spec.hs | 23 +- plutus-tx-plugin/test/IsData/Spec.hs | 166 +-- plutus-tx-plugin/test/Lift/Spec.hs | 57 +- plutus-tx-plugin/test/List/Properties1.hs | 415 ++++---- plutus-tx-plugin/test/List/Properties2.hs | 369 ++++--- plutus-tx-plugin/test/List/Semantics.hs | 45 +- plutus-tx-plugin/test/List/Spec.hs | 91 +- plutus-tx-plugin/test/Optimization/Spec.hs | 53 +- plutus-tx-plugin/test/Plugin/Basic/Spec.hs | 37 +- .../Coverage/9.6/coverageCode.pir.golden | 42 +- plutus-tx-plugin/test/Plugin/Coverage/Spec.hs | 59 +- plutus-tx-plugin/test/Plugin/Data/Spec.hs | 343 ++++--- .../test/Plugin/Debug/9.6/fib.pir.golden | 134 +-- .../test/Plugin/Debug/9.6/letFun.pir.golden | 30 +- plutus-tx-plugin/test/Plugin/Debug/Spec.hs | 51 +- plutus-tx-plugin/test/Plugin/Errors/Spec.hs | 74 +- .../test/Plugin/Functions/Spec.hs | 152 +-- plutus-tx-plugin/test/Plugin/Laziness/Spec.hs | 19 +- plutus-tx-plugin/test/Plugin/Lib.hs | 7 +- plutus-tx-plugin/test/Plugin/NoTrace/Lib.hs | 12 +- plutus-tx-plugin/test/Plugin/NoTrace/Spec.hs | 9 +- .../test/Plugin/Optimization/Spec.hs | 12 +- plutus-tx-plugin/test/Plugin/Patterns/Spec.hs | 54 +- .../test/Plugin/Primitives/Spec.hs | 234 +++-- plutus-tx-plugin/test/Plugin/Spec.hs | 34 +- plutus-tx-plugin/test/Plugin/Strict/Spec.hs | 59 +- .../test/Plugin/Typeclasses/Lib.hs | 17 +- .../test/Plugin/Typeclasses/Spec.hs | 102 +- .../test/ShortCircuit/WithGHCOptimisations.hs | 8 +- .../ShortCircuit/WithoutGHCOptimisations.hs | 8 +- plutus-tx-plugin/test/StdLib/Spec.hs | 125 +-- plutus-tx-plugin/test/Strictness/Spec.hs | 60 +- plutus-tx-plugin/test/TH/Spec.hs | 62 +- plutus-tx-plugin/test/TH/TestTH.hs | 18 +- plutus-tx-plugin/test/size/Main.hs | 183 ++-- 64 files changed, 4112 insertions(+), 3474 deletions(-) diff --git a/plutus-tx-plugin/app/GeneratePluginOptionsDoc.hs b/plutus-tx-plugin/app/GeneratePluginOptionsDoc.hs index 2b5e671ab07..750c25a53ab 100644 --- a/plutus-tx-plugin/app/GeneratePluginOptionsDoc.hs +++ b/plutus-tx-plugin/app/GeneratePluginOptionsDoc.hs @@ -17,31 +17,32 @@ import Options.Applicative qualified as OA import Prettyprinter import PyF (fmt) - newtype Params = Params - {paramOutputFile :: Text} + {paramOutputFile :: Text} parseParams :: OA.Parser Params parseParams = do - paramOutputFile <- - OA.argument OA.str $ - mconcat - [ OA.metavar "OUTPUT_FILE" - , OA.help "Output file path" - ] - pure Params{..} + paramOutputFile <- + OA.argument OA.str $ + mconcat + [ OA.metavar "OUTPUT_FILE" + , OA.help "Output file path" + ] + pure Params{..} main :: IO () main = do - params <- - OA.execParser $ - OA.info - (parseParams OA.<**> OA.helper) - (OA.fullDesc <> OA.header "Generate plugin option documentation") - Text.writeFile (Text.unpack $ paramOutputFile params) optionsTable + params <- + OA.execParser $ + OA.info + (parseParams OA.<**> OA.helper) + (OA.fullDesc <> OA.header "Generate plugin option documentation") + Text.writeFile (Text.unpack $ paramOutputFile params) optionsTable optionsTable :: Text -optionsTable = Text.stripStart $ [fmt| +optionsTable = + Text.stripStart $ + [fmt| --- sidebar_position: 5 --- @@ -70,5 +71,5 @@ For each boolean option, you can add a `no-` prefix to switch it off, such as `n genRow :: O.OptionKey -> O.PluginOption -> Text genRow k (O.PluginOption tr _ field desc _) = [fmt||`{k}`|{show tr}|{show (pretty defaultValue)}|{desc}||] - where - defaultValue = O.defaultPluginOptions ^. field + where + defaultValue = O.defaultPluginOptions ^. field diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Binders.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Binders.hs index a70f8c6048d..bd6a8516c67 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Binders.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Binders.hs @@ -31,99 +31,105 @@ first. variable *last* (so it is on the outside, so will be first when applying). -} -withVarScoped :: - CompilingDefault uni fun m ann => - GHC.Var -> - Ann -> - Maybe (PIRTerm uni fun) -> - (PIR.VarDecl PIR.TyName PIR.Name uni Ann -> m a) -> - m a +withVarScoped + :: (CompilingDefault uni fun m ann) + => GHC.Var + -> Ann + -> Maybe (PIRTerm uni fun) + -> (PIR.VarDecl PIR.TyName PIR.Name uni Ann -> m a) + -> m a withVarScoped v ann def k = do - let ghcName = GHC.getName v - var <- compileVarFresh ann v - local (\c -> c {ccScope=pushName ghcName var def (ccScope c)}) (k var) - --- | Like `withVarScoped`, but takes a `PIRType`, and uses it for the type --- of the compiled `GHC.Var`. -withVarTyScoped :: - CompilingDefault uni fun m ann => - GHC.Var -> - PIRType uni -> - (PIR.VarDecl PIR.TyName PIR.Name uni Ann -> m a) -> - m a + let ghcName = GHC.getName v + var <- compileVarFresh ann v + local (\c -> c{ccScope = pushName ghcName var def (ccScope c)}) (k var) + +{-| Like `withVarScoped`, but takes a `PIRType`, and uses it for the type +of the compiled `GHC.Var`. +-} +withVarTyScoped + :: (CompilingDefault uni fun m ann) + => GHC.Var + -> PIRType uni + -> (PIR.VarDecl PIR.TyName PIR.Name uni Ann -> m a) + -> m a withVarTyScoped v t k = do - let ghcName = GHC.getName v - var <- compileVarWithTyFresh annMayInline v t - local (\c -> c {ccScope=pushName ghcName var Nothing (ccScope c)}) (k var) - -withVarsScoped :: - CompilingDefault uni fun m ann => - [(GHC.Var, Maybe (PIRTerm uni fun))] -> - ([PIR.VarDecl PIR.TyName PIR.Name uni Ann] -> m a) -> - m a + let ghcName = GHC.getName v + var <- compileVarWithTyFresh annMayInline v t + local (\c -> c{ccScope = pushName ghcName var Nothing (ccScope c)}) (k var) + +withVarsScoped + :: (CompilingDefault uni fun m ann) + => [(GHC.Var, Maybe (PIRTerm uni fun))] + -> ([PIR.VarDecl PIR.TyName PIR.Name uni Ann] -> m a) + -> m a withVarsScoped vs k = do - vars <- for vs $ \(v, def) -> do - let name = GHC.getName v - var' <- compileVarFresh annMayInline v - pure (name, var', def) - local (\c -> c {ccScope=pushNames vars (ccScope c)}) (k (fmap snd3 vars)) - -withTyVarScoped :: - Compiling uni fun m ann => - GHC.Var -> - (PIR.TyVarDecl PIR.TyName Ann -> m a) -> - m a + vars <- for vs $ \(v, def) -> do + let name = GHC.getName v + var' <- compileVarFresh annMayInline v + pure (name, var', def) + local (\c -> c{ccScope = pushNames vars (ccScope c)}) (k (fmap snd3 vars)) + +withTyVarScoped + :: (Compiling uni fun m ann) + => GHC.Var + -> (PIR.TyVarDecl PIR.TyName Ann -> m a) + -> m a withTyVarScoped v k = do - let ghcName = GHC.getName v - var <- compileTyVarFresh v - local (\c -> c {ccScope=pushTyName ghcName var (ccScope c)}) (k var) - -withTyVarsScoped :: - Compiling uni fun m ann => - [GHC.Var] -> - ([PIR.TyVarDecl PIR.TyName Ann] -> m a) -> - m a + let ghcName = GHC.getName v + var <- compileTyVarFresh v + local (\c -> c{ccScope = pushTyName ghcName var (ccScope c)}) (k var) + +withTyVarsScoped + :: (Compiling uni fun m ann) + => [GHC.Var] + -> ([PIR.TyVarDecl PIR.TyName Ann] -> m a) + -> m a withTyVarsScoped vs k = do - vars <- for vs $ \v -> do - let name = GHC.getName v - var' <- compileTyVarFresh v - pure (name, var') - local (\c -> c {ccScope=pushTyNames vars (ccScope c)}) (k (fmap snd vars)) - --- | Builds a lambda, binding the given variable to a name that --- will be in scope when running the second argument. -mkLamAbsScoped :: - CompilingDefault uni fun m ann => - Ann -> - GHC.Var -> - m (PIRTerm uni fun) -> - m (PIRTerm uni fun) + vars <- for vs $ \v -> do + let name = GHC.getName v + var' <- compileTyVarFresh v + pure (name, var') + local (\c -> c{ccScope = pushTyNames vars (ccScope c)}) (k (fmap snd vars)) + +{-| Builds a lambda, binding the given variable to a name that +will be in scope when running the second argument. +-} +mkLamAbsScoped + :: (CompilingDefault uni fun m ann) + => Ann + -> GHC.Var + -> m (PIRTerm uni fun) + -> m (PIRTerm uni fun) mkLamAbsScoped ann v body = - withVarScoped v ann Nothing $ \(PIR.VarDecl _ n t) -> - PIR.LamAbs ann n t <$> body + withVarScoped v ann Nothing $ \(PIR.VarDecl _ n t) -> + PIR.LamAbs ann n t <$> body --- | Builds a type abstraction, binding the given variable to a name that --- will be in scope when running the second argument. -mkTyAbsScoped :: Compiling uni fun m ann => GHC.Var -> m (PIRTerm uni fun) -> m (PIRTerm uni fun) +{-| Builds a type abstraction, binding the given variable to a name that +will be in scope when running the second argument. +-} +mkTyAbsScoped :: (Compiling uni fun m ann) => GHC.Var -> m (PIRTerm uni fun) -> m (PIRTerm uni fun) mkTyAbsScoped v body = withTyVarScoped v $ \(PIR.TyVarDecl _ t k) -> PIR.TyAbs annMayInline t k <$> body -mkIterTyAbsScoped :: Compiling uni fun m ann => [GHC.Var] -> m (PIRTerm uni fun) -> m (PIRTerm uni fun) +mkIterTyAbsScoped + :: (Compiling uni fun m ann) => [GHC.Var] -> m (PIRTerm uni fun) -> m (PIRTerm uni fun) mkIterTyAbsScoped vars body = foldr (\v acc -> mkTyAbsScoped v acc) body vars --- | Builds a forall, binding the given variable to a name that --- will be in scope when running the second argument. -mkTyForallScoped :: Compiling uni fun m ann => GHC.Var -> m (PIRType uni) -> m (PIRType uni) +{-| Builds a forall, binding the given variable to a name that +will be in scope when running the second argument. +-} +mkTyForallScoped :: (Compiling uni fun m ann) => GHC.Var -> m (PIRType uni) -> m (PIRType uni) mkTyForallScoped v body = - withTyVarScoped v $ \(PIR.TyVarDecl _ t k) -> PIR.TyForall annMayInline t k <$> body + withTyVarScoped v $ \(PIR.TyVarDecl _ t k) -> PIR.TyForall annMayInline t k <$> body -mkIterTyForallScoped :: Compiling uni fun m ann => [GHC.Var] -> m (PIRType uni) -> m (PIRType uni) +mkIterTyForallScoped :: (Compiling uni fun m ann) => [GHC.Var] -> m (PIRType uni) -> m (PIRType uni) mkIterTyForallScoped vars body = foldr (\v acc -> mkTyForallScoped v acc) body vars --- | Builds a type lambda, binding the given variable to a name that --- will be in scope when running the second argument. -mkTyLamScoped :: Compiling uni fun m ann => GHC.Var -> m (PIRType uni) -> m (PIRType uni) +{-| Builds a type lambda, binding the given variable to a name that +will be in scope when running the second argument. +-} +mkTyLamScoped :: (Compiling uni fun m ann) => GHC.Var -> m (PIRType uni) -> m (PIRType uni) mkTyLamScoped v body = - withTyVarScoped v $ \(PIR.TyVarDecl _ t k) -> PIR.TyLam annMayInline t k <$> body + withTyVarScoped v $ \(PIR.TyVarDecl _ t k) -> PIR.TyLam annMayInline t k <$> body -mkIterTyLamScoped :: Compiling uni fun m ann => [GHC.Var] -> m (PIRType uni) -> m (PIRType uni) +mkIterTyLamScoped :: (Compiling uni fun m ann) => [GHC.Var] -> m (PIRType uni) -> m (PIRType uni) mkIterTyLamScoped vars body = foldr (\v acc -> mkTyLamScoped v acc) body vars diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs index eeb09503397..cb0aa91a37f 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Builtins.hs @@ -11,12 +11,13 @@ -- | Functions for compiling Plutus Core builtins. module PlutusTx.Compiler.Builtins ( - builtinNames - , defineBuiltinTypes - , defineBuiltinTerms - , lookupBuiltinTerm - , lookupBuiltinType - , errorFunc) where + builtinNames, + defineBuiltinTypes, + defineBuiltinTerms, + lookupBuiltinTerm, + lookupBuiltinType, + errorFunc, +) where import PlutusTx.Builtins.HasOpaque qualified as Builtins import PlutusTx.Builtins.Internal qualified as Builtins @@ -160,499 +161,493 @@ mkBuiltin = PIR.Builtin annMayInline -- | The 'TH.Name's for which 'NameInfo' needs to be provided. builtinNames :: [TH.Name] -builtinNames = [ - ''Builtins.BuiltinByteString - , ''Builtins.BuiltinByteStringHex - , ''Builtins.BuiltinByteStringUtf8 - , 'Builtins.appendByteString - , 'Builtins.consByteString - , 'Builtins.sliceByteString - , 'Builtins.lengthOfByteString - , 'Builtins.indexByteString - , 'Builtins.sha2_256 - , 'Builtins.sha3_256 - , 'Builtins.blake2b_224 - , 'Builtins.blake2b_256 - , 'Builtins.keccak_256 - , 'Builtins.ripemd_160 - , 'Builtins.equalsByteString - , 'Builtins.lessThanByteString - , 'Builtins.lessThanEqualsByteString - , 'Builtins.emptyByteString - , 'Builtins.decodeUtf8 - , 'Builtins.stringToBuiltinByteString - , 'Builtins.stringToBuiltinByteStringHex - , 'Builtins.stringToBuiltinByteStringUtf8 - , 'Builtins.verifyEcdsaSecp256k1Signature - , 'Builtins.verifySchnorrSecp256k1Signature - - , 'Builtins.verifyEd25519Signature - - , ''Builtins.BuiltinInteger - , ''Integer - , 'Builtins.addInteger - , 'Builtins.subtractInteger - , 'Builtins.multiplyInteger - , 'Builtins.divideInteger - , 'Builtins.modInteger - , 'Builtins.quotientInteger - , 'Builtins.remainderInteger - , 'Builtins.lessThanInteger - , 'Builtins.lessThanEqualsInteger - , 'Builtins.equalsInteger - - , 'Builtins.error - - , ''Builtins.BuiltinString - , 'Builtins.appendString - , 'Builtins.emptyString - , 'Builtins.equalsString - , 'Builtins.encodeUtf8 - , 'Builtins.integerToByteString - , 'Builtins.byteStringToInteger - -- This one is special - , 'Builtins.stringToBuiltinString - - , 'Builtins.trace - - , ''Builtins.BuiltinBool - , 'Builtins.ifThenElse - , 'Builtins.true - , 'Builtins.false - - , ''Builtins.BuiltinUnit - , 'Builtins.unitval - , 'Builtins.chooseUnit - - , ''Builtins.BuiltinPair - , 'Builtins.fst - , 'Builtins.snd - , 'Builtins.mkPairData - - , ''Builtins.BuiltinList - , 'Builtins.null - , 'Builtins.head - , 'Builtins.tail - , 'Builtins.chooseList - , 'Builtins.caseList' - , 'Builtins.mkNilData - , 'Builtins.mkNilPairData - , 'Builtins.mkCons - , 'Builtins.drop - - , ''Builtins.BuiltinArray - , 'Builtins.lengthOfArray - , 'Builtins.listToArray - , 'Builtins.indexArray - - , ''Builtins.BuiltinData - , 'Builtins.chooseData - , 'Builtins.caseData' - , 'Builtins.equalsData - , 'Builtins.serialiseData - , 'Builtins.mkConstr - , 'Builtins.mkMap - , 'Builtins.mkList - , 'Builtins.mkI - , 'Builtins.mkB - , 'Builtins.unsafeDataAsConstr - , 'Builtins.unsafeDataAsMap - , 'Builtins.unsafeDataAsList - , 'Builtins.unsafeDataAsB - , 'Builtins.unsafeDataAsI - - , ''Builtins.BuiltinBLS12_381_G1_Element - , 'Builtins.bls12_381_G1_equals - , 'Builtins.bls12_381_G1_add - , 'Builtins.bls12_381_G1_neg - , 'Builtins.bls12_381_G1_scalarMul - , 'Builtins.bls12_381_G1_compress - , 'Builtins.bls12_381_G1_uncompress - , 'Builtins.bls12_381_G1_hashToGroup - , 'Builtins.bls12_381_G1_compressed_zero - , 'Builtins.bls12_381_G1_compressed_generator - - , ''Builtins.BuiltinBLS12_381_G2_Element - , 'Builtins.bls12_381_G2_equals - , 'Builtins.bls12_381_G2_add - , 'Builtins.bls12_381_G2_neg - , 'Builtins.bls12_381_G2_scalarMul - , 'Builtins.bls12_381_G2_compress - , 'Builtins.bls12_381_G2_uncompress - , 'Builtins.bls12_381_G2_hashToGroup - , 'Builtins.bls12_381_G2_compressed_zero - , 'Builtins.bls12_381_G2_compressed_generator - - , ''Builtins.BuiltinBLS12_381_MlResult - , 'Builtins.bls12_381_millerLoop - , 'Builtins.bls12_381_mulMlResult - , 'Builtins.bls12_381_finalVerify - - , 'Builtins.integerToByteString - , 'Builtins.byteStringToInteger - - , 'Builtins.andByteString - , 'Builtins.orByteString - , 'Builtins.xorByteString - , 'Builtins.complementByteString - , 'Builtins.readBit - , 'Builtins.writeBits - , 'Builtins.replicateByte - - , 'Builtins.shiftByteString - , 'Builtins.rotateByteString - , 'Builtins.countSetBits - , 'Builtins.findFirstSetBit - - , 'Builtins.expModInteger - ] - -defineBuiltinTerm :: CompilingDefault uni fun m ann => Ann -> TH.Name -> PIRTerm uni fun -> m () +builtinNames = + [ ''Builtins.BuiltinByteString + , ''Builtins.BuiltinByteStringHex + , ''Builtins.BuiltinByteStringUtf8 + , 'Builtins.appendByteString + , 'Builtins.consByteString + , 'Builtins.sliceByteString + , 'Builtins.lengthOfByteString + , 'Builtins.indexByteString + , 'Builtins.sha2_256 + , 'Builtins.sha3_256 + , 'Builtins.blake2b_224 + , 'Builtins.blake2b_256 + , 'Builtins.keccak_256 + , 'Builtins.ripemd_160 + , 'Builtins.equalsByteString + , 'Builtins.lessThanByteString + , 'Builtins.lessThanEqualsByteString + , 'Builtins.emptyByteString + , 'Builtins.decodeUtf8 + , 'Builtins.stringToBuiltinByteString + , 'Builtins.stringToBuiltinByteStringHex + , 'Builtins.stringToBuiltinByteStringUtf8 + , 'Builtins.verifyEcdsaSecp256k1Signature + , 'Builtins.verifySchnorrSecp256k1Signature + , 'Builtins.verifyEd25519Signature + , ''Builtins.BuiltinInteger + , ''Integer + , 'Builtins.addInteger + , 'Builtins.subtractInteger + , 'Builtins.multiplyInteger + , 'Builtins.divideInteger + , 'Builtins.modInteger + , 'Builtins.quotientInteger + , 'Builtins.remainderInteger + , 'Builtins.lessThanInteger + , 'Builtins.lessThanEqualsInteger + , 'Builtins.equalsInteger + , 'Builtins.error + , ''Builtins.BuiltinString + , 'Builtins.appendString + , 'Builtins.emptyString + , 'Builtins.equalsString + , 'Builtins.encodeUtf8 + , 'Builtins.integerToByteString + , 'Builtins.byteStringToInteger + , -- This one is special + 'Builtins.stringToBuiltinString + , 'Builtins.trace + , ''Builtins.BuiltinBool + , 'Builtins.ifThenElse + , 'Builtins.true + , 'Builtins.false + , ''Builtins.BuiltinUnit + , 'Builtins.unitval + , 'Builtins.chooseUnit + , ''Builtins.BuiltinPair + , 'Builtins.fst + , 'Builtins.snd + , 'Builtins.mkPairData + , ''Builtins.BuiltinList + , 'Builtins.null + , 'Builtins.head + , 'Builtins.tail + , 'Builtins.chooseList + , 'Builtins.caseList' + , 'Builtins.mkNilData + , 'Builtins.mkNilPairData + , 'Builtins.mkCons + , 'Builtins.drop + , ''Builtins.BuiltinArray + , 'Builtins.lengthOfArray + , 'Builtins.listToArray + , 'Builtins.indexArray + , ''Builtins.BuiltinData + , 'Builtins.chooseData + , 'Builtins.caseData' + , 'Builtins.equalsData + , 'Builtins.serialiseData + , 'Builtins.mkConstr + , 'Builtins.mkMap + , 'Builtins.mkList + , 'Builtins.mkI + , 'Builtins.mkB + , 'Builtins.unsafeDataAsConstr + , 'Builtins.unsafeDataAsMap + , 'Builtins.unsafeDataAsList + , 'Builtins.unsafeDataAsB + , 'Builtins.unsafeDataAsI + , ''Builtins.BuiltinBLS12_381_G1_Element + , 'Builtins.bls12_381_G1_equals + , 'Builtins.bls12_381_G1_add + , 'Builtins.bls12_381_G1_neg + , 'Builtins.bls12_381_G1_scalarMul + , 'Builtins.bls12_381_G1_compress + , 'Builtins.bls12_381_G1_uncompress + , 'Builtins.bls12_381_G1_hashToGroup + , 'Builtins.bls12_381_G1_compressed_zero + , 'Builtins.bls12_381_G1_compressed_generator + , ''Builtins.BuiltinBLS12_381_G2_Element + , 'Builtins.bls12_381_G2_equals + , 'Builtins.bls12_381_G2_add + , 'Builtins.bls12_381_G2_neg + , 'Builtins.bls12_381_G2_scalarMul + , 'Builtins.bls12_381_G2_compress + , 'Builtins.bls12_381_G2_uncompress + , 'Builtins.bls12_381_G2_hashToGroup + , 'Builtins.bls12_381_G2_compressed_zero + , 'Builtins.bls12_381_G2_compressed_generator + , ''Builtins.BuiltinBLS12_381_MlResult + , 'Builtins.bls12_381_millerLoop + , 'Builtins.bls12_381_mulMlResult + , 'Builtins.bls12_381_finalVerify + , 'Builtins.integerToByteString + , 'Builtins.byteStringToInteger + , 'Builtins.andByteString + , 'Builtins.orByteString + , 'Builtins.xorByteString + , 'Builtins.complementByteString + , 'Builtins.readBit + , 'Builtins.writeBits + , 'Builtins.replicateByte + , 'Builtins.shiftByteString + , 'Builtins.rotateByteString + , 'Builtins.countSetBits + , 'Builtins.findFirstSetBit + , 'Builtins.expModInteger + ] + +defineBuiltinTerm :: (CompilingDefault uni fun m ann) => Ann -> TH.Name -> PIRTerm uni fun -> m () defineBuiltinTerm ann name term = do - ghcId <- lookupGhcId name - var <- compileVarFresh ann ghcId - binfo <- asks ccBuiltinsInfo - -- See Note [Builtin terms and values] - let strictness = if PIR.isPure binfo mempty term then PIR.Strict else PIR.NonStrict - def = PIR.Def var (term, strictness) - PIR.defineTerm (LexName $ GHC.getName ghcId) def mempty + ghcId <- lookupGhcId name + var <- compileVarFresh ann ghcId + binfo <- asks ccBuiltinsInfo + -- See Note [Builtin terms and values] + let strictness = if PIR.isPure binfo mempty term then PIR.Strict else PIR.NonStrict + def = PIR.Def var (term, strictness) + PIR.defineTerm (LexName $ GHC.getName ghcId) def mempty -- | Add definitions for all the builtin types to the environment. -defineBuiltinType :: forall uni fun m ann. Compiling uni fun m ann => TH.Name -> PIRType uni -> m () +defineBuiltinType + :: forall uni fun m ann. (Compiling uni fun m ann) => TH.Name -> PIRType uni -> m () defineBuiltinType name ty = do - tc <- lookupGhcTyCon name - var <- compileTcTyVarFresh tc - PIR.defineType (LexName $ GHC.getName tc) (PIR.Def var ty) mempty - -- these are all aliases for now - PIR.recordAlias (LexName $ GHC.getName tc) + tc <- lookupGhcTyCon name + var <- compileTcTyVarFresh tc + PIR.defineType (LexName $ GHC.getName tc) (PIR.Def var ty) mempty + -- these are all aliases for now + PIR.recordAlias (LexName $ GHC.getName tc) -- | Add definitions for all the builtin terms to the environment. -defineBuiltinTerms :: CompilingDefault uni fun m ann => m () +defineBuiltinTerms :: (CompilingDefault uni fun m ann) => m () defineBuiltinTerms = do - -- Error - -- See Note [Delaying error] - func <- delayedErrorFunc - -- We always want to inline `error :: forall a . () -> a`, hence `annAlwaysInline`. - defineBuiltinTerm annAlwaysInline 'Builtins.error func - - -- Unit constant - defineBuiltinTerm annMayInline 'Builtins.unitval $ PIR.mkConstant annMayInline () - - -- Bool constants - defineBuiltinTerm annMayInline 'Builtins.true $ PIR.mkConstant annMayInline True - defineBuiltinTerm annMayInline 'Builtins.false $ PIR.mkConstant annMayInline False - - -- ByteString constant - defineBuiltinTerm annMayInline 'Builtins.emptyByteString $ PIR.mkConstant annMayInline BS.empty - - -- Text constant - defineBuiltinTerm annMayInline 'Builtins.emptyString $ PIR.mkConstant annMayInline ("" :: Text) - - -- The next two constants are 48 bytes long, so in fact we may not want to inline them. - defineBuiltinTerm annMayInline 'Builtins.bls12_381_G1_compressed_generator $ - PIR.mkConstant annMayInline BLS12_381.G1.compressed_generator - defineBuiltinTerm annMayInline 'Builtins.bls12_381_G1_compressed_zero $ - PIR.mkConstant annMayInline BLS12_381.G1.compressed_zero - - -- The next two constants are 96 bytes long, so in fact we may not want to inline them. - defineBuiltinTerm annMayInline 'Builtins.bls12_381_G2_compressed_generator $ - PIR.mkConstant annMayInline BLS12_381.G2.compressed_generator - defineBuiltinTerm annMayInline 'Builtins.bls12_381_G2_compressed_zero $ - PIR.mkConstant annMayInline BLS12_381.G2.compressed_zero - - -- See Note [Builtin terms and values] - for_ enumerate $ \fun -> - let defineBuiltinInl impl = defineBuiltinTerm annMayInline impl $ mkBuiltin fun - in case fun of - PLC.IfThenElse -> defineBuiltinInl 'Builtins.ifThenElse - PLC.ChooseUnit -> defineBuiltinInl 'Builtins.chooseUnit - - -- Bytestrings - PLC.AppendByteString -> defineBuiltinInl 'Builtins.appendByteString - PLC.ConsByteString -> defineBuiltinInl 'Builtins.consByteString - PLC.SliceByteString -> defineBuiltinInl 'Builtins.sliceByteString - PLC.LengthOfByteString -> defineBuiltinInl 'Builtins.lengthOfByteString - PLC.IndexByteString -> defineBuiltinInl 'Builtins.indexByteString - PLC.Sha2_256 -> defineBuiltinInl 'Builtins.sha2_256 - PLC.Sha3_256 -> defineBuiltinInl 'Builtins.sha3_256 - PLC.Blake2b_224 -> defineBuiltinInl 'Builtins.blake2b_224 - PLC.Blake2b_256 -> defineBuiltinInl 'Builtins.blake2b_256 - PLC.Keccak_256 -> defineBuiltinInl 'Builtins.keccak_256 - PLC.Ripemd_160 -> defineBuiltinInl 'Builtins.ripemd_160 - PLC.EqualsByteString -> defineBuiltinInl 'Builtins.equalsByteString - PLC.LessThanByteString -> defineBuiltinInl 'Builtins.lessThanByteString - PLC.LessThanEqualsByteString -> defineBuiltinInl 'Builtins.lessThanEqualsByteString - PLC.DecodeUtf8 -> defineBuiltinInl 'Builtins.decodeUtf8 - - -- Strings and chars - PLC.AppendString -> defineBuiltinInl 'Builtins.appendString - PLC.EqualsString -> defineBuiltinInl 'Builtins.equalsString - PLC.EncodeUtf8 -> defineBuiltinInl 'Builtins.encodeUtf8 - - -- Crypto - PLC.VerifyEd25519Signature -> defineBuiltinInl 'Builtins.verifyEd25519Signature - PLC.VerifyEcdsaSecp256k1Signature -> defineBuiltinInl 'Builtins.verifyEcdsaSecp256k1Signature - PLC.VerifySchnorrSecp256k1Signature -> defineBuiltinInl 'Builtins.verifySchnorrSecp256k1Signature - - -- Integers - PLC.AddInteger -> defineBuiltinInl 'Builtins.addInteger - PLC.SubtractInteger -> defineBuiltinInl 'Builtins.subtractInteger - PLC.MultiplyInteger -> defineBuiltinInl 'Builtins.multiplyInteger - PLC.DivideInteger -> defineBuiltinInl 'Builtins.divideInteger - PLC.ModInteger -> defineBuiltinInl 'Builtins.modInteger - PLC.QuotientInteger -> defineBuiltinInl 'Builtins.quotientInteger - PLC.RemainderInteger -> defineBuiltinInl 'Builtins.remainderInteger - PLC.LessThanInteger -> defineBuiltinInl 'Builtins.lessThanInteger - PLC.LessThanEqualsInteger -> defineBuiltinInl 'Builtins.lessThanEqualsInteger - PLC.EqualsInteger -> defineBuiltinInl 'Builtins.equalsInteger - - -- Tracing - PLC.Trace -> defineBuiltinInl 'Builtins.trace - - -- Pairs - PLC.FstPair -> defineBuiltinInl 'Builtins.fst - PLC.SndPair -> defineBuiltinInl 'Builtins.snd - PLC.MkPairData -> defineBuiltinInl 'Builtins.mkPairData - - -- List - PLC.NullList -> defineBuiltinInl 'Builtins.null - PLC.HeadList -> defineBuiltinInl 'Builtins.head - PLC.TailList -> defineBuiltinInl 'Builtins.tail - PLC.ChooseList -> defineBuiltinInl 'Builtins.chooseList - PLC.CaseList -> defineBuiltinTerm annMayInline 'Builtins.caseList' $ - -- > /\a r -> - -- > \(z : r) (f : a -> list a -> r) (xs : list a) -> - -- > chooseList - -- > {a} - -- > {all dead. r} - -- > xs - -- > (/\dead -> z) - -- > (/\dead -> f (headList {a} xs) (tailList {a} xs)) - -- > {r} - fmap (const annMayInline) . runQuote $ do - a <- freshTyName "a" - r <- freshTyName "r" - dead <- freshTyName "dead" - xs <- freshName "xs" - z <- freshName "z" - f <- freshName "f" - let listA = PLC.TyApp () (PLC.mkTyBuiltin @_ @[] ()) $ PLC.TyVar () a - funAtXs headOrTail = - PIR.apply () - (PIR.tyInst () (PIR.builtin () headOrTail) $ PLC.TyVar () a) - (PIR.var () xs) - return - . PIR.tyAbs () a (PLC.Type ()) - . PIR.tyAbs () r (PLC.Type ()) - . PIR.lamAbs () z (PLC.TyVar () r) - . PIR.lamAbs () f - (PLC.TyFun () (PLC.TyVar () a) . PLC.TyFun () listA $ PLC.TyVar () r) - . PIR.lamAbs () xs listA - . PIR.tyInst () - (PIR.mkIterAppNoAnn - (PIR.mkIterInstNoAnn - (PIR.builtin () PLC.ChooseList) - [ PLC.TyVar () a - , PLC.TyForall () dead (PLC.Type ()) $ PLC.TyVar () r - ]) - [ PIR.var () xs - , PIR.tyAbs () dead (PLC.Type ()) $ PIR.var () z - , PIR.tyAbs () dead (PLC.Type ()) $ PIR.mkIterAppNoAnn - (PIR.var () f) - [funAtXs PLC.HeadList, funAtXs PLC.TailList] - ]) - $ PLC.TyVar () r - PLC.MkNilData -> defineBuiltinInl 'Builtins.mkNilData - PLC.MkNilPairData -> defineBuiltinInl 'Builtins.mkNilPairData - PLC.MkCons -> defineBuiltinInl 'Builtins.mkCons - PLC.DropList -> defineBuiltinInl 'Builtins.drop - - -- Arrays - PLC.LengthOfArray -> defineBuiltinInl 'Builtins.lengthOfArray - PLC.ListToArray -> defineBuiltinInl 'Builtins.listToArray - PLC.IndexArray -> defineBuiltinInl 'Builtins.indexArray - - -- Data - PLC.ChooseData -> defineBuiltinInl 'Builtins.chooseData - PLC.EqualsData -> defineBuiltinInl 'Builtins.equalsData - PLC.ConstrData -> defineBuiltinInl 'Builtins.mkConstr - PLC.MapData -> defineBuiltinInl 'Builtins.mkMap - PLC.ListData -> defineBuiltinInl 'Builtins.mkList - PLC.IData -> defineBuiltinInl 'Builtins.mkI - PLC.BData -> defineBuiltinInl 'Builtins.mkB - PLC.UnConstrData -> defineBuiltinInl 'Builtins.unsafeDataAsConstr - PLC.UnMapData -> defineBuiltinInl 'Builtins.unsafeDataAsMap - PLC.UnListData -> defineBuiltinInl 'Builtins.unsafeDataAsList - PLC.UnBData -> defineBuiltinInl 'Builtins.unsafeDataAsB - PLC.UnIData -> defineBuiltinInl 'Builtins.unsafeDataAsI - PLC.SerialiseData -> defineBuiltinInl 'Builtins.serialiseData - PLC.CaseData -> defineBuiltinTerm annMayInline 'Builtins.caseData' $ - -- > /\r -> - -- > \(fConstr : integer -> list data -> r) - -- > (fMap : list (pair data data) -> r) - -- > (fList : list data -> r) - -- > (fI : integer -> r) - -- > (fB : bytestring -> r) - -- > (d : data) -> - -- > chooseData - -- > {all dead. r} - -- > d - -- > (/\dead -> - -- > (/\a b c -> - -- > \(f : a -> b -> c) (p : pair a b) -> - -- > f (fstPair {a} {b} p) (sndPair {a} {b} p)) - -- > {integer} - -- > {list data} - -- > {r} - -- > fConstr - -- > (unConstrData d)) - -- > (/\dead -> fMap (unMapData d)) - -- > (/\dead -> fList (unListData d)) - -- > (/\dead -> fI (unIData d)) - -- > (/\dead -> fB (unBData d)) - -- > {r} - fmap (const annMayInline) . runQuote $ do - r <- freshTyName "r" - dead <- freshTyName "dead" - fConstr <- freshName "fConstr" - fMap <- freshName "fMap" - fList <- freshName "fList" - fI <- freshName "fI" - fB <- freshName "fB" - d <- freshName "d" - let integer = PLC.mkTyBuiltin @_ @Integer () - listData = PLC.mkTyBuiltin @_ @[PLC.Data] () - listPairData = PLC.mkTyBuiltin @_ @[(PLC.Data, PLC.Data)] () - bytestring = PLC.mkTyBuiltin @_ @BS.ByteString () - return - . PIR.tyAbs () r (PLC.Type ()) - . PIR.lamAbs () - fConstr - (PLC.TyFun () integer . PLC.TyFun () listData $ PLC.TyVar () r) - . PIR.lamAbs () fMap (PLC.TyFun () listPairData $ PLC.TyVar () r) - . PIR.lamAbs () fList (PLC.TyFun () listData $ PLC.TyVar () r) - . PIR.lamAbs () fI (PLC.TyFun () integer $ PLC.TyVar () r) - . PIR.lamAbs () fB (PLC.TyFun () bytestring $ PLC.TyVar () r) - . PIR.lamAbs () d (PLC.mkTyBuiltin @_ @PLC.Data ()) - . PIR.tyInst () - (PIR.mkIterAppNoAnn - ( PIR.tyInst () (PIR.builtin () PLC.ChooseData) - . PLC.TyForall () dead (PLC.Type ()) - $ PLC.TyVar () r) - [ PIR.var () d - , PIR.tyAbs () dead (PLC.Type ()) - $ PIR.mkIterAppNoAnn - (PIR.mkIterInstNoAnn - PLC.uncurry - [integer, listData, PLC.TyVar () r]) - [ PIR.var () fConstr - , PIR.apply () (PIR.builtin () PLC.UnConstrData) $ - PIR.var () d - ] - , PIR.tyAbs () dead (PLC.Type ()) - . PIR.apply () (PIR.var () fMap) - . PIR.apply () (PIR.builtin () PLC.UnMapData) - $ PIR.var () d - , PIR.tyAbs () dead (PLC.Type ()) - . PIR.apply () (PIR.var () fList) - . PIR.apply () (PIR.builtin () PLC.UnListData) - $ PIR.var () d - , PIR.tyAbs () dead (PLC.Type ()) - . PIR.apply () (PIR.var () fI) - . PIR.apply () (PIR.builtin () PLC.UnIData) - $ PIR.var () d - , PIR.tyAbs () dead (PLC.Type ()) - . PIR.apply () (PIR.var () fB) - . PIR.apply () (PIR.builtin () PLC.UnBData) - $ PIR.var () d - ]) - $ PLC.TyVar () r - -- BLS - PLC.Bls12_381_G1_equal -> defineBuiltinInl 'Builtins.bls12_381_G1_equals - PLC.Bls12_381_G1_add -> defineBuiltinInl 'Builtins.bls12_381_G1_add - PLC.Bls12_381_G1_neg -> defineBuiltinInl 'Builtins.bls12_381_G1_neg - PLC.Bls12_381_G1_scalarMul -> defineBuiltinInl 'Builtins.bls12_381_G1_scalarMul - PLC.Bls12_381_G1_compress -> defineBuiltinInl 'Builtins.bls12_381_G1_compress - PLC.Bls12_381_G1_uncompress -> defineBuiltinInl 'Builtins.bls12_381_G1_uncompress - PLC.Bls12_381_G1_hashToGroup -> defineBuiltinInl 'Builtins.bls12_381_G1_hashToGroup - - PLC.Bls12_381_G2_equal -> defineBuiltinInl 'Builtins.bls12_381_G2_equals - PLC.Bls12_381_G2_add -> defineBuiltinInl 'Builtins.bls12_381_G2_add - PLC.Bls12_381_G2_scalarMul -> defineBuiltinInl 'Builtins.bls12_381_G2_scalarMul - PLC.Bls12_381_G2_neg -> defineBuiltinInl 'Builtins.bls12_381_G2_neg - PLC.Bls12_381_G2_compress -> defineBuiltinInl 'Builtins.bls12_381_G2_compress - PLC.Bls12_381_G2_uncompress -> defineBuiltinInl 'Builtins.bls12_381_G2_uncompress - PLC.Bls12_381_G2_hashToGroup -> defineBuiltinInl 'Builtins.bls12_381_G2_hashToGroup - - PLC.Bls12_381_millerLoop -> defineBuiltinInl 'Builtins.bls12_381_millerLoop - PLC.Bls12_381_mulMlResult -> defineBuiltinInl 'Builtins.bls12_381_mulMlResult - PLC.Bls12_381_finalVerify -> defineBuiltinInl 'Builtins.bls12_381_finalVerify - - -- Bitwise operations - PLC.IntegerToByteString -> defineBuiltinInl 'Builtins.integerToByteString - PLC.ByteStringToInteger -> defineBuiltinInl 'Builtins.byteStringToInteger - - -- Logical operations - PLC.AndByteString -> defineBuiltinInl 'Builtins.andByteString - PLC.OrByteString -> defineBuiltinInl 'Builtins.orByteString - PLC.XorByteString -> defineBuiltinInl 'Builtins.xorByteString - PLC.ComplementByteString -> defineBuiltinInl 'Builtins.complementByteString - PLC.ReadBit -> defineBuiltinInl 'Builtins.readBit - PLC.WriteBits -> defineBuiltinInl 'Builtins.writeBits - PLC.ReplicateByte -> defineBuiltinInl 'Builtins.replicateByte - - -- Other bitwise ops - PLC.ShiftByteString -> defineBuiltinInl 'Builtins.shiftByteString - PLC.RotateByteString -> defineBuiltinInl 'Builtins.rotateByteString - PLC.CountSetBits -> defineBuiltinInl 'Builtins.countSetBits - PLC.FindFirstSetBit -> defineBuiltinInl 'Builtins.findFirstSetBit - - PLC.ExpModInteger -> defineBuiltinInl 'Builtins.expModInteger - -defineBuiltinTypes :: CompilingDefault uni fun m ann => m () + -- Error + -- See Note [Delaying error] + func <- delayedErrorFunc + -- We always want to inline `error :: forall a . () -> a`, hence `annAlwaysInline`. + defineBuiltinTerm annAlwaysInline 'Builtins.error func + + -- Unit constant + defineBuiltinTerm annMayInline 'Builtins.unitval $ PIR.mkConstant annMayInline () + + -- Bool constants + defineBuiltinTerm annMayInline 'Builtins.true $ PIR.mkConstant annMayInline True + defineBuiltinTerm annMayInline 'Builtins.false $ PIR.mkConstant annMayInline False + + -- ByteString constant + defineBuiltinTerm annMayInline 'Builtins.emptyByteString $ PIR.mkConstant annMayInline BS.empty + + -- Text constant + defineBuiltinTerm annMayInline 'Builtins.emptyString $ PIR.mkConstant annMayInline ("" :: Text) + + -- The next two constants are 48 bytes long, so in fact we may not want to inline them. + defineBuiltinTerm annMayInline 'Builtins.bls12_381_G1_compressed_generator $ + PIR.mkConstant annMayInline BLS12_381.G1.compressed_generator + defineBuiltinTerm annMayInline 'Builtins.bls12_381_G1_compressed_zero $ + PIR.mkConstant annMayInline BLS12_381.G1.compressed_zero + + -- The next two constants are 96 bytes long, so in fact we may not want to inline them. + defineBuiltinTerm annMayInline 'Builtins.bls12_381_G2_compressed_generator $ + PIR.mkConstant annMayInline BLS12_381.G2.compressed_generator + defineBuiltinTerm annMayInline 'Builtins.bls12_381_G2_compressed_zero $ + PIR.mkConstant annMayInline BLS12_381.G2.compressed_zero + + -- See Note [Builtin terms and values] + for_ enumerate $ \fun -> + let defineBuiltinInl impl = defineBuiltinTerm annMayInline impl $ mkBuiltin fun + in case fun of + PLC.IfThenElse -> defineBuiltinInl 'Builtins.ifThenElse + PLC.ChooseUnit -> defineBuiltinInl 'Builtins.chooseUnit + -- Bytestrings + PLC.AppendByteString -> defineBuiltinInl 'Builtins.appendByteString + PLC.ConsByteString -> defineBuiltinInl 'Builtins.consByteString + PLC.SliceByteString -> defineBuiltinInl 'Builtins.sliceByteString + PLC.LengthOfByteString -> defineBuiltinInl 'Builtins.lengthOfByteString + PLC.IndexByteString -> defineBuiltinInl 'Builtins.indexByteString + PLC.Sha2_256 -> defineBuiltinInl 'Builtins.sha2_256 + PLC.Sha3_256 -> defineBuiltinInl 'Builtins.sha3_256 + PLC.Blake2b_224 -> defineBuiltinInl 'Builtins.blake2b_224 + PLC.Blake2b_256 -> defineBuiltinInl 'Builtins.blake2b_256 + PLC.Keccak_256 -> defineBuiltinInl 'Builtins.keccak_256 + PLC.Ripemd_160 -> defineBuiltinInl 'Builtins.ripemd_160 + PLC.EqualsByteString -> defineBuiltinInl 'Builtins.equalsByteString + PLC.LessThanByteString -> defineBuiltinInl 'Builtins.lessThanByteString + PLC.LessThanEqualsByteString -> defineBuiltinInl 'Builtins.lessThanEqualsByteString + PLC.DecodeUtf8 -> defineBuiltinInl 'Builtins.decodeUtf8 + -- Strings and chars + PLC.AppendString -> defineBuiltinInl 'Builtins.appendString + PLC.EqualsString -> defineBuiltinInl 'Builtins.equalsString + PLC.EncodeUtf8 -> defineBuiltinInl 'Builtins.encodeUtf8 + -- Crypto + PLC.VerifyEd25519Signature -> defineBuiltinInl 'Builtins.verifyEd25519Signature + PLC.VerifyEcdsaSecp256k1Signature -> defineBuiltinInl 'Builtins.verifyEcdsaSecp256k1Signature + PLC.VerifySchnorrSecp256k1Signature -> defineBuiltinInl 'Builtins.verifySchnorrSecp256k1Signature + -- Integers + PLC.AddInteger -> defineBuiltinInl 'Builtins.addInteger + PLC.SubtractInteger -> defineBuiltinInl 'Builtins.subtractInteger + PLC.MultiplyInteger -> defineBuiltinInl 'Builtins.multiplyInteger + PLC.DivideInteger -> defineBuiltinInl 'Builtins.divideInteger + PLC.ModInteger -> defineBuiltinInl 'Builtins.modInteger + PLC.QuotientInteger -> defineBuiltinInl 'Builtins.quotientInteger + PLC.RemainderInteger -> defineBuiltinInl 'Builtins.remainderInteger + PLC.LessThanInteger -> defineBuiltinInl 'Builtins.lessThanInteger + PLC.LessThanEqualsInteger -> defineBuiltinInl 'Builtins.lessThanEqualsInteger + PLC.EqualsInteger -> defineBuiltinInl 'Builtins.equalsInteger + -- Tracing + PLC.Trace -> defineBuiltinInl 'Builtins.trace + -- Pairs + PLC.FstPair -> defineBuiltinInl 'Builtins.fst + PLC.SndPair -> defineBuiltinInl 'Builtins.snd + PLC.MkPairData -> defineBuiltinInl 'Builtins.mkPairData + -- List + PLC.NullList -> defineBuiltinInl 'Builtins.null + PLC.HeadList -> defineBuiltinInl 'Builtins.head + PLC.TailList -> defineBuiltinInl 'Builtins.tail + PLC.ChooseList -> defineBuiltinInl 'Builtins.chooseList + PLC.CaseList -> defineBuiltinTerm annMayInline 'Builtins.caseList' $ + -- > /\a r -> + -- > \(z : r) (f : a -> list a -> r) (xs : list a) -> + -- > chooseList + -- > {a} + -- > {all dead. r} + -- > xs + -- > (/\dead -> z) + -- > (/\dead -> f (headList {a} xs) (tailList {a} xs)) + -- > {r} + fmap (const annMayInline) . runQuote $ do + a <- freshTyName "a" + r <- freshTyName "r" + dead <- freshTyName "dead" + xs <- freshName "xs" + z <- freshName "z" + f <- freshName "f" + let listA = PLC.TyApp () (PLC.mkTyBuiltin @_ @[] ()) $ PLC.TyVar () a + funAtXs headOrTail = + PIR.apply + () + (PIR.tyInst () (PIR.builtin () headOrTail) $ PLC.TyVar () a) + (PIR.var () xs) + return + . PIR.tyAbs () a (PLC.Type ()) + . PIR.tyAbs () r (PLC.Type ()) + . PIR.lamAbs () z (PLC.TyVar () r) + . PIR.lamAbs + () + f + (PLC.TyFun () (PLC.TyVar () a) . PLC.TyFun () listA $ PLC.TyVar () r) + . PIR.lamAbs () xs listA + . PIR.tyInst + () + ( PIR.mkIterAppNoAnn + ( PIR.mkIterInstNoAnn + (PIR.builtin () PLC.ChooseList) + [ PLC.TyVar () a + , PLC.TyForall () dead (PLC.Type ()) $ PLC.TyVar () r + ] + ) + [ PIR.var () xs + , PIR.tyAbs () dead (PLC.Type ()) $ PIR.var () z + , PIR.tyAbs () dead (PLC.Type ()) $ + PIR.mkIterAppNoAnn + (PIR.var () f) + [funAtXs PLC.HeadList, funAtXs PLC.TailList] + ] + ) + $ PLC.TyVar () r + PLC.MkNilData -> defineBuiltinInl 'Builtins.mkNilData + PLC.MkNilPairData -> defineBuiltinInl 'Builtins.mkNilPairData + PLC.MkCons -> defineBuiltinInl 'Builtins.mkCons + PLC.DropList -> defineBuiltinInl 'Builtins.drop + -- Arrays + PLC.LengthOfArray -> defineBuiltinInl 'Builtins.lengthOfArray + PLC.ListToArray -> defineBuiltinInl 'Builtins.listToArray + PLC.IndexArray -> defineBuiltinInl 'Builtins.indexArray + -- Data + PLC.ChooseData -> defineBuiltinInl 'Builtins.chooseData + PLC.EqualsData -> defineBuiltinInl 'Builtins.equalsData + PLC.ConstrData -> defineBuiltinInl 'Builtins.mkConstr + PLC.MapData -> defineBuiltinInl 'Builtins.mkMap + PLC.ListData -> defineBuiltinInl 'Builtins.mkList + PLC.IData -> defineBuiltinInl 'Builtins.mkI + PLC.BData -> defineBuiltinInl 'Builtins.mkB + PLC.UnConstrData -> defineBuiltinInl 'Builtins.unsafeDataAsConstr + PLC.UnMapData -> defineBuiltinInl 'Builtins.unsafeDataAsMap + PLC.UnListData -> defineBuiltinInl 'Builtins.unsafeDataAsList + PLC.UnBData -> defineBuiltinInl 'Builtins.unsafeDataAsB + PLC.UnIData -> defineBuiltinInl 'Builtins.unsafeDataAsI + PLC.SerialiseData -> defineBuiltinInl 'Builtins.serialiseData + PLC.CaseData -> defineBuiltinTerm annMayInline 'Builtins.caseData' $ + -- > /\r -> + -- > \(fConstr : integer -> list data -> r) + -- > (fMap : list (pair data data) -> r) + -- > (fList : list data -> r) + -- > (fI : integer -> r) + -- > (fB : bytestring -> r) + -- > (d : data) -> + -- > chooseData + -- > {all dead. r} + -- > d + -- > (/\dead -> + -- > (/\a b c -> + -- > \(f : a -> b -> c) (p : pair a b) -> + -- > f (fstPair {a} {b} p) (sndPair {a} {b} p)) + -- > {integer} + -- > {list data} + -- > {r} + -- > fConstr + -- > (unConstrData d)) + -- > (/\dead -> fMap (unMapData d)) + -- > (/\dead -> fList (unListData d)) + -- > (/\dead -> fI (unIData d)) + -- > (/\dead -> fB (unBData d)) + -- > {r} + fmap (const annMayInline) . runQuote $ do + r <- freshTyName "r" + dead <- freshTyName "dead" + fConstr <- freshName "fConstr" + fMap <- freshName "fMap" + fList <- freshName "fList" + fI <- freshName "fI" + fB <- freshName "fB" + d <- freshName "d" + let integer = PLC.mkTyBuiltin @_ @Integer () + listData = PLC.mkTyBuiltin @_ @[PLC.Data] () + listPairData = PLC.mkTyBuiltin @_ @[(PLC.Data, PLC.Data)] () + bytestring = PLC.mkTyBuiltin @_ @BS.ByteString () + return + . PIR.tyAbs () r (PLC.Type ()) + . PIR.lamAbs + () + fConstr + (PLC.TyFun () integer . PLC.TyFun () listData $ PLC.TyVar () r) + . PIR.lamAbs () fMap (PLC.TyFun () listPairData $ PLC.TyVar () r) + . PIR.lamAbs () fList (PLC.TyFun () listData $ PLC.TyVar () r) + . PIR.lamAbs () fI (PLC.TyFun () integer $ PLC.TyVar () r) + . PIR.lamAbs () fB (PLC.TyFun () bytestring $ PLC.TyVar () r) + . PIR.lamAbs () d (PLC.mkTyBuiltin @_ @PLC.Data ()) + . PIR.tyInst + () + ( PIR.mkIterAppNoAnn + ( PIR.tyInst () (PIR.builtin () PLC.ChooseData) + . PLC.TyForall () dead (PLC.Type ()) + $ PLC.TyVar () r + ) + [ PIR.var () d + , PIR.tyAbs () dead (PLC.Type ()) $ + PIR.mkIterAppNoAnn + ( PIR.mkIterInstNoAnn + PLC.uncurry + [integer, listData, PLC.TyVar () r] + ) + [ PIR.var () fConstr + , PIR.apply () (PIR.builtin () PLC.UnConstrData) $ + PIR.var () d + ] + , PIR.tyAbs () dead (PLC.Type ()) + . PIR.apply () (PIR.var () fMap) + . PIR.apply () (PIR.builtin () PLC.UnMapData) + $ PIR.var () d + , PIR.tyAbs () dead (PLC.Type ()) + . PIR.apply () (PIR.var () fList) + . PIR.apply () (PIR.builtin () PLC.UnListData) + $ PIR.var () d + , PIR.tyAbs () dead (PLC.Type ()) + . PIR.apply () (PIR.var () fI) + . PIR.apply () (PIR.builtin () PLC.UnIData) + $ PIR.var () d + , PIR.tyAbs () dead (PLC.Type ()) + . PIR.apply () (PIR.var () fB) + . PIR.apply () (PIR.builtin () PLC.UnBData) + $ PIR.var () d + ] + ) + $ PLC.TyVar () r + -- BLS + PLC.Bls12_381_G1_equal -> defineBuiltinInl 'Builtins.bls12_381_G1_equals + PLC.Bls12_381_G1_add -> defineBuiltinInl 'Builtins.bls12_381_G1_add + PLC.Bls12_381_G1_neg -> defineBuiltinInl 'Builtins.bls12_381_G1_neg + PLC.Bls12_381_G1_scalarMul -> defineBuiltinInl 'Builtins.bls12_381_G1_scalarMul + PLC.Bls12_381_G1_compress -> defineBuiltinInl 'Builtins.bls12_381_G1_compress + PLC.Bls12_381_G1_uncompress -> defineBuiltinInl 'Builtins.bls12_381_G1_uncompress + PLC.Bls12_381_G1_hashToGroup -> defineBuiltinInl 'Builtins.bls12_381_G1_hashToGroup + PLC.Bls12_381_G2_equal -> defineBuiltinInl 'Builtins.bls12_381_G2_equals + PLC.Bls12_381_G2_add -> defineBuiltinInl 'Builtins.bls12_381_G2_add + PLC.Bls12_381_G2_scalarMul -> defineBuiltinInl 'Builtins.bls12_381_G2_scalarMul + PLC.Bls12_381_G2_neg -> defineBuiltinInl 'Builtins.bls12_381_G2_neg + PLC.Bls12_381_G2_compress -> defineBuiltinInl 'Builtins.bls12_381_G2_compress + PLC.Bls12_381_G2_uncompress -> defineBuiltinInl 'Builtins.bls12_381_G2_uncompress + PLC.Bls12_381_G2_hashToGroup -> defineBuiltinInl 'Builtins.bls12_381_G2_hashToGroup + PLC.Bls12_381_millerLoop -> defineBuiltinInl 'Builtins.bls12_381_millerLoop + PLC.Bls12_381_mulMlResult -> defineBuiltinInl 'Builtins.bls12_381_mulMlResult + PLC.Bls12_381_finalVerify -> defineBuiltinInl 'Builtins.bls12_381_finalVerify + -- Bitwise operations + PLC.IntegerToByteString -> defineBuiltinInl 'Builtins.integerToByteString + PLC.ByteStringToInteger -> defineBuiltinInl 'Builtins.byteStringToInteger + -- Logical operations + PLC.AndByteString -> defineBuiltinInl 'Builtins.andByteString + PLC.OrByteString -> defineBuiltinInl 'Builtins.orByteString + PLC.XorByteString -> defineBuiltinInl 'Builtins.xorByteString + PLC.ComplementByteString -> defineBuiltinInl 'Builtins.complementByteString + PLC.ReadBit -> defineBuiltinInl 'Builtins.readBit + PLC.WriteBits -> defineBuiltinInl 'Builtins.writeBits + PLC.ReplicateByte -> defineBuiltinInl 'Builtins.replicateByte + -- Other bitwise ops + PLC.ShiftByteString -> defineBuiltinInl 'Builtins.shiftByteString + PLC.RotateByteString -> defineBuiltinInl 'Builtins.rotateByteString + PLC.CountSetBits -> defineBuiltinInl 'Builtins.countSetBits + PLC.FindFirstSetBit -> defineBuiltinInl 'Builtins.findFirstSetBit + PLC.ExpModInteger -> defineBuiltinInl 'Builtins.expModInteger + +defineBuiltinTypes :: (CompilingDefault uni fun m ann) => m () defineBuiltinTypes = do - defineBuiltinType ''Builtins.BuiltinByteString . ($> annMayInline) $ PLC.toTypeAst $ Proxy @BS.ByteString - defineBuiltinType ''Integer . ($> annMayInline) $ PLC.toTypeAst $ Proxy @Integer - defineBuiltinType ''Builtins.BuiltinBool . ($> annMayInline) $ PLC.toTypeAst $ Proxy @Bool - defineBuiltinType ''Builtins.BuiltinUnit . ($> annMayInline) $ PLC.toTypeAst $ Proxy @() - defineBuiltinType ''Builtins.BuiltinString . ($> annMayInline) $ PLC.toTypeAst $ Proxy @Text - defineBuiltinType ''Builtins.BuiltinData . ($> annMayInline) $ PLC.toTypeAst $ Proxy @PLC.Data - defineBuiltinType ''Builtins.BuiltinPair . ($> annMayInline) $ PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoPair) - defineBuiltinType ''Builtins.BuiltinList . ($> annMayInline) $ PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoList) - defineBuiltinType ''Builtins.BuiltinArray . ($> annMayInline) $ PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoArray) - defineBuiltinType ''Builtins.BuiltinBLS12_381_G1_Element . ($> annMayInline) $ PLC.toTypeAst $ Proxy @BLS12_381.G1.Element - defineBuiltinType ''Builtins.BuiltinBLS12_381_G2_Element . ($> annMayInline) $ PLC.toTypeAst $ Proxy @BLS12_381.G2.Element - defineBuiltinType ''Builtins.BuiltinBLS12_381_MlResult . ($> annMayInline) $ PLC.toTypeAst $ Proxy @BLS12_381.Pairing.MlResult + defineBuiltinType ''Builtins.BuiltinByteString . ($> annMayInline) $ + PLC.toTypeAst $ + Proxy @BS.ByteString + defineBuiltinType ''Integer . ($> annMayInline) $ PLC.toTypeAst $ Proxy @Integer + defineBuiltinType ''Builtins.BuiltinBool . ($> annMayInline) $ PLC.toTypeAst $ Proxy @Bool + defineBuiltinType ''Builtins.BuiltinUnit . ($> annMayInline) $ PLC.toTypeAst $ Proxy @() + defineBuiltinType ''Builtins.BuiltinString . ($> annMayInline) $ PLC.toTypeAst $ Proxy @Text + defineBuiltinType ''Builtins.BuiltinData . ($> annMayInline) $ PLC.toTypeAst $ Proxy @PLC.Data + defineBuiltinType ''Builtins.BuiltinPair . ($> annMayInline) $ + PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoPair) + defineBuiltinType ''Builtins.BuiltinList . ($> annMayInline) $ + PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoList) + defineBuiltinType ''Builtins.BuiltinArray . ($> annMayInline) $ + PLC.TyBuiltin () (PLC.SomeTypeIn PLC.DefaultUniProtoArray) + defineBuiltinType ''Builtins.BuiltinBLS12_381_G1_Element . ($> annMayInline) $ + PLC.toTypeAst $ + Proxy @BLS12_381.G1.Element + defineBuiltinType ''Builtins.BuiltinBLS12_381_G2_Element . ($> annMayInline) $ + PLC.toTypeAst $ + Proxy @BLS12_381.G2.Element + defineBuiltinType ''Builtins.BuiltinBLS12_381_MlResult . ($> annMayInline) $ + PLC.toTypeAst $ + Proxy @BLS12_381.Pairing.MlResult -- | Lookup a builtin term by its TH name. These are assumed to be present, so fails if it cannot find it. -lookupBuiltinTerm :: Compiling uni fun m ann => TH.Name -> m (PIRTerm uni fun) +lookupBuiltinTerm :: (Compiling uni fun m ann) => TH.Name -> m (PIRTerm uni fun) lookupBuiltinTerm name = do - ghcName <- lookupGhcName name - maybeTerm <- PIR.lookupTerm (LexName ghcName) - case maybeTerm of - Just t -> pure t - Nothing -> throwSd CompilationError $ "Missing builtin definition:" GHC.<+> (GHC.text $ show name) + ghcName <- lookupGhcName name + maybeTerm <- PIR.lookupTerm (LexName ghcName) + case maybeTerm of + Just t -> pure t + Nothing -> throwSd CompilationError $ "Missing builtin definition:" GHC.<+> (GHC.text $ show name) -- | Lookup a builtin type by its TH name. These are assumed to be present, so fails if it is cannot find it. -lookupBuiltinType :: Compiling uni fun m ann => TH.Name -> m (PIRType uni) +lookupBuiltinType :: (Compiling uni fun m ann) => TH.Name -> m (PIRType uni) lookupBuiltinType name = do - ghcName <- lookupGhcName name - maybeType <- PIR.lookupType annMayInline (LexName ghcName) - case maybeType of - Just t -> pure t - Nothing -> throwSd CompilationError $ "Missing builtin definition:" GHC.<+> (GHC.text $ show name) + ghcName <- lookupGhcName name + maybeType <- PIR.lookupType annMayInline (LexName ghcName) + case maybeType of + Just t -> pure t + Nothing -> throwSd CompilationError $ "Missing builtin definition:" GHC.<+> (GHC.text $ show name) -- | The function 'error :: forall a . a'. -errorFunc :: Compiling uni fun m ann => m (PIRTerm uni fun) +errorFunc :: (Compiling uni fun m ann) => m (PIRTerm uni fun) errorFunc = do - n <- safeFreshTyName "e" - pure $ PIR.TyAbs annMayInline n (PIR.Type annMayInline) (PIR.Error annMayInline (PIR.TyVar annMayInline n)) + n <- safeFreshTyName "e" + pure $ + PIR.TyAbs annMayInline n (PIR.Type annMayInline) (PIR.Error annMayInline (PIR.TyVar annMayInline n)) -- | The delayed error function 'error :: forall a . () -> a'. -delayedErrorFunc :: CompilingDefault uni fun m ann => m (PIRTerm uni fun) +delayedErrorFunc :: (CompilingDefault uni fun m ann) => m (PIRTerm uni fun) delayedErrorFunc = do - n <- safeFreshTyName "a" - t <- liftQuote (freshName "thunk") - let ty = PLC.toTypeAst $ Proxy @() - pure $ PIR.TyAbs annMayInline n (PIR.Type annMayInline) $ - PIR.LamAbs annMayInline t (ty $> annMayInline) $ PIR.Error annMayInline (PIR.TyVar annMayInline n) + n <- safeFreshTyName "a" + t <- liftQuote (freshName "thunk") + let ty = PLC.toTypeAst $ Proxy @() + pure $ + PIR.TyAbs annMayInline n (PIR.Type annMayInline) $ + PIR.LamAbs annMayInline t (ty $> annMayInline) $ + PIR.Error annMayInline (PIR.TyVar annMayInline n) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Error.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Error.hs index 0de72379a1a..34e73c82aae 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Error.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Error.hs @@ -8,14 +8,16 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + module PlutusTx.Compiler.Error ( - CompileError - , Error (..) - , WithContext (..) - , withContext - , withContextM - , throwPlain - , pruneContext) where + CompileError, + Error (..), + WithContext (..), + withContext, + withContextM, + throwPlain, + pruneContext, +) where import PlutusIR.Compiler qualified as PIR @@ -30,10 +32,12 @@ import Control.Monad.Except import Data.Text qualified as T import Prettyprinter qualified as PP --- | An error with some (nested) context. The integer argument to 'WithContextC' represents --- the priority of the context when displaying it. Lower numbers are more prioritised. +{-| An error with some (nested) context. The integer argument to 'WithContextC' represents +the priority of the context when displaying it. Lower numbers are more prioritised. +-} data WithContext c e = NoContext e | WithContextC Int c (WithContext c e) - deriving stock Functor + deriving stock Functor + makeClassyPrisms ''WithContext type CompileError uni fun ann = WithContext T.Text (Error uni fun ann) @@ -43,70 +47,75 @@ withContext p c act = catchError act $ \err -> throwError (WithContextC p c err) withContextM :: (MonadError (WithContext c e) m) => Int -> m c -> m a -> m a withContextM p mc act = do - c <- mc - catchError act $ \err -> throwError (WithContextC p c err) + c <- mc + catchError act $ \err -> throwError (WithContextC p c err) -throwPlain :: MonadError (WithContext c e) m => e -> m a +throwPlain :: (MonadError (WithContext c e) m) => e -> m a throwPlain = throwError . NoContext pruneContext :: Int -> WithContext c e -> WithContext c e pruneContext prio = \case - NoContext e -> NoContext e - WithContextC p c e -> - let inner = pruneContext prio e in if p > prio then inner else WithContextC p c inner + NoContext e -> NoContext e + WithContextC p c e -> + let inner = pruneContext prio e in if p > prio then inner else WithContextC p c inner instance (PP.Pretty c, PP.Pretty e) => PP.Pretty (WithContext c e) where - pretty = \case - NoContext e -> "Error:" PP.<+> (PP.align $ PP.pretty e) - WithContextC _ c e -> PP.vsep [ - PP.pretty e, - "Context:" PP.<+> (PP.align $ PP.pretty c) - ] + pretty = \case + NoContext e -> "Error:" PP.<+> (PP.align $ PP.pretty e) + WithContextC _ c e -> + PP.vsep + [ PP.pretty e + , "Context:" PP.<+> (PP.align $ PP.pretty c) + ] data Error uni fun a - = PLCError !(PLC.Error uni fun a) - | PIRError !(PIR.Error uni fun (PIR.Provenance a)) - | CompilationError !T.Text - | UnsupportedError !T.Text - | FreeVariableError !T.Text - | InvalidMarkerError !String - | CoreNameLookupError !TH.Name + = PLCError !(PLC.Error uni fun a) + | PIRError !(PIR.Error uni fun (PIR.Provenance a)) + | CompilationError !T.Text + | UnsupportedError !T.Text + | FreeVariableError !T.Text + | InvalidMarkerError !String + | CoreNameLookupError !TH.Name makeClassyPrisms ''Error instance (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty a) => PP.Pretty (Error uni fun a) where - pretty = PLC.prettyPlcClassicSimple + pretty = PLC.prettyPlcClassicSimple instance - (uni1 ~ uni2, b ~ PIR.Provenance a) => - PLC.AsTypeError (CompileError uni1 fun a) (PIR.Term PIR.TyName PIR.Name uni2 fun ()) uni2 fun b - where - _TypeError = _NoContext . _PIRError . PIR._TypeError + (uni1 ~ uni2, b ~ PIR.Provenance a) + => PLC.AsTypeError (CompileError uni1 fun a) (PIR.Term PIR.TyName PIR.Name uni2 fun ()) uni2 fun b + where + _TypeError = _NoContext . _PIRError . PIR._TypeError instance - (uni1 ~ uni2, b ~ PIR.Provenance a) => - PIR.AsTypeErrorExt (CompileError uni1 fun a) uni2 b - where - _TypeErrorExt = _NoContext . _PIRError . PIR._TypeErrorExt + (uni1 ~ uni2, b ~ PIR.Provenance a) + => PIR.AsTypeErrorExt (CompileError uni1 fun a) uni2 b + where + _TypeErrorExt = _NoContext . _PIRError . PIR._TypeErrorExt -instance uni1 ~ uni2 => PLC.AsNormCheckError (CompileError uni1 fun a) PLC.TyName PLC.Name uni2 fun a where - _NormCheckError = _NoContext . _PLCError . PLC._NormCheckError +instance (uni1 ~ uni2) => PLC.AsNormCheckError (CompileError uni1 fun a) PLC.TyName PLC.Name uni2 fun a where + _NormCheckError = _NoContext . _PLCError . PLC._NormCheckError instance PLC.AsUniqueError (CompileError uni fun a) a where - _UniqueError = _NoContext . _PLCError . PLC._UniqueError + _UniqueError = _NoContext . _PLCError . PLC._UniqueError + +instance + (uni1 ~ uni2, b ~ PIR.Provenance a) + => PIR.AsError (CompileError uni1 fun a) uni2 fun b + where + _Error = _NoContext . _PIRError instance - (uni1 ~ uni2, b ~ PIR.Provenance a) => - PIR.AsError (CompileError uni1 fun a) uni2 fun b - where - _Error = _NoContext . _PIRError - -instance (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty a) => - PLC.PrettyBy PLC.PrettyConfigPlc (Error uni fun a) where - prettyBy config = \case - PLCError e -> PP.vsep [ "Error from the PLC compiler:", PLC.prettyBy config e ] - PIRError e -> PP.vsep [ "Error from the PIR compiler:", PLC.prettyBy config e ] - CompilationError e -> "Unexpected error during compilation, please report this to the Plutus team:" PP.<+> PP.pretty e - UnsupportedError e -> "Unsupported feature:" PP.<+> PP.pretty e - FreeVariableError e -> "Reference to a name which is not a local, a builtin, or an external INLINABLE function:" PP.<+> PP.pretty e - InvalidMarkerError e -> "Found invalid marker, not applied correctly in expression" PP.<+> PP.pretty e - CoreNameLookupError n -> "Unable to get Core name needed for the plugin to function: " PP.<+> PP.viaShow n + (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty a) + => PLC.PrettyBy PLC.PrettyConfigPlc (Error uni fun a) + where + prettyBy config = \case + PLCError e -> PP.vsep ["Error from the PLC compiler:", PLC.prettyBy config e] + PIRError e -> PP.vsep ["Error from the PIR compiler:", PLC.prettyBy config e] + CompilationError e -> "Unexpected error during compilation, please report this to the Plutus team:" PP.<+> PP.pretty e + UnsupportedError e -> "Unsupported feature:" PP.<+> PP.pretty e + FreeVariableError e -> + "Reference to a name which is not a local, a builtin, or an external INLINABLE function:" + PP.<+> PP.pretty e + InvalidMarkerError e -> "Found invalid marker, not applied correctly in expression" PP.<+> PP.pretty e + CoreNameLookupError n -> "Unable to get Core name needed for the plugin to function: " PP.<+> PP.viaShow n diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index f8b0a10fe14..afc8cdd6975 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -11,7 +11,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} - {-# OPTIONS_GHC -Wno-partial-type-signatures #-} -- | Functions for compiling GHC Core expressions into Plutus Core terms. @@ -88,7 +87,6 @@ import Data.Traversable (for) import Data.Tuple.Extra import Data.Word (Word8) - {- Note [System FC and System FW] Haskell uses system FC, which includes type equalities and coercions. @@ -140,10 +138,10 @@ character is "un-consed" from its tail, for example: Then we re-do the cons after un-doing the original rewrite rule. -} -compileLiteral :: - (CompilingDefault uni fun m ann) => - GHC.Literal -> - m (PIRTerm uni fun) +compileLiteral + :: (CompilingDefault uni fun m ann) + => GHC.Literal + -> m (PIRTerm uni fun) compileLiteral = \case -- Just accept any kind of number literal, we'll complain about types we don't support elsewhere (GHC.LitNumber _ i) -> pure $ PIR.embedTerm $ PLC.mkConstant annMayInline i @@ -155,8 +153,9 @@ compileLiteral = \case GHC.LitNullAddr -> throwPlain $ UnsupportedError "Literal null" GHC.LitRubbish{} -> throwPlain $ UnsupportedError "Literal rubbish" --- | Get the bytestring content of a string expression, if possible. --- Follows (Haskell) variable references! +{-| Get the bytestring content of a string expression, if possible. +Follows (Haskell) variable references! +-} tryStringLiteralAsBytes :: GHC.CoreExpr -> Maybe BS.ByteString tryStringLiteralAsBytes coreExpr = case coreExpr of GHC.Lit (GHC.LitString bytes) -> @@ -167,7 +166,6 @@ tryStringLiteralAsBytes coreExpr = case coreExpr of GHC.Var isUnpackCStringUtf8 `GHC.App` GHC.Lit (GHC.LitString bytes) | GHC.getName isUnpackCStringUtf8 == GHC.unpackCStringUtf8Name -> Just bytes - {- See Note [unpackFoldrCString#] Example GHC Core expr this pattern matches: @@ -181,7 +179,7 @@ tryStringLiteralAsBytes coreExpr = case coreExpr of | GHC.getName build == GHC.buildName , GHC.getName unpack == GHC.unpackCStringFoldrName , GHC.getName charTyCon == GHC.charTyConName -> - tryStringLiteralAsBytes expr + tryStringLiteralAsBytes expr {- Example GHC Core expr this pattern matches: GHC.Types.: @GHC.Types.Char (GHC.Types.C# 'f'#) expr @@ -194,26 +192,25 @@ tryStringLiteralAsBytes coreExpr = case coreExpr of , Just consDataCon <- GHC.isDataConId_maybe consId , GHC.consDataCon == consDataCon , Just charDataCon <- GHC.isDataConId_maybe cSharp - , GHC.charDataCon == charDataCon -> - BSC.cons c <$> tryStringLiteralAsBytes expr - + , GHC.charDataCon == charDataCon -> + BSC.cons c <$> tryStringLiteralAsBytes expr -- GHC helpfully generates an empty list for the empty string literal instead -- of a 'LitString' GHC.Var nil `GHC.App` GHC.Type (GHC.tyConAppTyCon_maybe -> Just tc) | nil == GHC.dataConWorkId GHC.nilDataCon , GHC.getName tc == GHC.charTyConName -> - Just mempty - + Just mempty -- Chase variable references! GHC likes to lift string constants to variables, -- that is not good for us! GHC.Var (GHC.maybeUnfoldingTemplate . GHC.realIdUnfolding -> Just unfolding) -> tryStringLiteralAsBytes unfolding _ -> Nothing --- | Given a GHC Core expression representing a string literal --- extracts a ByteString from it. +{-| Given a GHC Core expression representing a string literal +extracts a ByteString from it. +-} stringLiteralAsBytes - :: Compiling uni fun m ann + :: (Compiling uni fun m ann) => GHC.Name -- ^ is used for error reporting. -> GHC.CoreExpr @@ -222,68 +219,72 @@ stringLiteralAsBytes stringLiteralAsBytes name coreExpr = case tryStringLiteralAsBytes coreExpr of Just bytes -> pure bytes - Nothing -> throwSd CompilationError $ - "Use of fromString @" - GHC.<+> GHC.ppr name - GHC.<+> "with inscrutable content: " - GHC.<+> GHC.ppr coreExpr - --- | Given a GHC Core expression representing a string literal --- extracts UTF-8 encoded ByteString from it and decodes it as Text -stringLiteralAsText :: Compiling uni fun m ann => GHC.Name -> GHC.CoreExpr -> m T.Text + Nothing -> + throwSd CompilationError $ + "Use of fromString @" + GHC.<+> GHC.ppr name + GHC.<+> "with inscrutable content: " + GHC.<+> GHC.ppr coreExpr + +{-| Given a GHC Core expression representing a string literal +extracts UTF-8 encoded ByteString from it and decodes it as Text +-} +stringLiteralAsText :: (Compiling uni fun m ann) => GHC.Name -> GHC.CoreExpr -> m T.Text stringLiteralAsText name coreExpr = do bytes <- stringLiteralAsBytes name coreExpr case TE.decodeUtf8' bytes of Right txt -> pure txt - Left err -> throwSd CompilationError $ - "Invalid UTF-8 in string literal:" - GHC.<+> GHC.text (displayException err) + Left err -> + throwSd CompilationError $ + "Invalid UTF-8 in string literal:" + GHC.<+> GHC.text (displayException err) -{- | Tries to recover original bytes from a UTF-8 encoded bytestring literal. +{-| Tries to recover original bytes from a UTF-8 encoded bytestring literal. This isn't a full UTF-8 decoder: it only decodes the subset of UTF-8 that is expected to be found in bytestring literals: 0x00 - 0xFF If 'ByteString' contains a codepoint that is not in this range, the function will throw an error. -} -utf8CodePointsAsBytes :: Compiling uni fun m ann => BS.ByteString -> m BS.ByteString +utf8CodePointsAsBytes :: (Compiling uni fun m ann) => BS.ByteString -> m BS.ByteString utf8CodePointsAsBytes bs = case tryUtf8CodePointsAsBytes bs of Just bytes -> pure bytes - Nothing -> throwPlain . CompilationError $ - "ByteString literal is expected to contain only codepoints in the range 0 - 255 (0x00 - 0xFF)" + Nothing -> + throwPlain . CompilationError $ + "ByteString literal is expected to contain only codepoints in the range 0 - 255 (0x00 - 0xFF)" tryUtf8CodePointsAsBytes :: BS.ByteString -> Maybe BS.ByteString tryUtf8CodePointsAsBytes = fmap BS.pack . gracefullyDecodeUtf8Bytes . BS.unpack - where - {- - Why not use 'Data.Text.Encoding'? - 1. Some bytes never appear in UTF-8 encoded text (0xC0, 0xC1, 0xF5-0xFF). - 2. GHC Core could contain such bytes in bytestring literals, - e.g. "\0\1" is stored as "\192\128\SOH". - 3. The UTF-8 parser from 'Data.Text.Encoding' chokes on these bytes: - ghci> TE.decodeUtf8 "\192\128\SOH" - *** Exception: Cannot decode byte '\xc0': Data.Text.Encoding: Invalid UTF-8 stream - 4. In the custom parsing logic below we can handle these bytes: - -} - gracefullyDecodeUtf8Bytes :: [Word8] -> Maybe [Word8] - gracefullyDecodeUtf8Bytes = \case - [] -> Just [] - 192 : 128 : rest -> (0x00 :) <$> gracefullyDecodeUtf8Bytes rest - 194 : b : rest | b > 127 && b < 192 -> (b :) <$> gracefullyDecodeUtf8Bytes rest - 195 : b : rest | b > 127 && b < 192 -> ((b + 64) :) <$> gracefullyDecodeUtf8Bytes rest - b : rest | b > 0 && b < 128 -> (b :) <$> gracefullyDecodeUtf8Bytes rest - _ -> Nothing - -{- | Strip off irrelevant things when we're trying to match a particular pattern in the code. Mostly ticks. + where + {- + Why not use 'Data.Text.Encoding'? + 1. Some bytes never appear in UTF-8 encoded text (0xC0, 0xC1, 0xF5-0xFF). + 2. GHC Core could contain such bytes in bytestring literals, + e.g. "\0\1" is stored as "\192\128\SOH". + 3. The UTF-8 parser from 'Data.Text.Encoding' chokes on these bytes: + ghci> TE.decodeUtf8 "\192\128\SOH" + *** Exception: Cannot decode byte '\xc0': Data.Text.Encoding: Invalid UTF-8 stream + 4. In the custom parsing logic below we can handle these bytes: + -} + gracefullyDecodeUtf8Bytes :: [Word8] -> Maybe [Word8] + gracefullyDecodeUtf8Bytes = \case + [] -> Just [] + 192 : 128 : rest -> (0x00 :) <$> gracefullyDecodeUtf8Bytes rest + 194 : b : rest | b > 127 && b < 192 -> (b :) <$> gracefullyDecodeUtf8Bytes rest + 195 : b : rest | b > 127 && b < 192 -> ((b + 64) :) <$> gracefullyDecodeUtf8Bytes rest + b : rest | b > 0 && b < 128 -> (b :) <$> gracefullyDecodeUtf8Bytes rest + _ -> Nothing + +{-| Strip off irrelevant things when we're trying to match a particular pattern in the code. Mostly ticks. We only need to do this as part of a complex pattern match: if we're just compiling the expression in question we will strip this off anyway. -} strip :: GHC.CoreExpr -> GHC.CoreExpr strip = \case GHC.Var n `GHC.App` GHC.Type _ `GHC.App` expr | GHC.getName n == GHC.noinlineIdName -> strip expr - GHC.Tick _ expr -> strip expr - expr -> expr + GHC.Tick _ expr -> strip expr + expr -> expr -- | Convert a reference to a data constructor, i.e. a call to it. compileDataConRef :: (CompilingDefault uni fun m ann) => GHC.DataCon -> m (PIRTerm uni fun) @@ -299,19 +300,19 @@ compileDataConRef dc = do CompilationError "Data constructor not in the type constructor's list of constructors" pure $ constrs !! index - where - tc = GHC.dataConTyCon dc + where + tc = GHC.dataConTyCon dc -- | Make alternatives with non-delayed and delayed bodies for a given 'CoreAlt'. -compileAlt :: - (CompilingDefault uni fun m ann) => - -- | The 'CoreAlt' representing the branch itself. - GHC.CoreAlt -> - -- | The instantiated type arguments for the data constructor. - [GHC.Type] -> - PIRTerm uni fun -> - -- | Non-delayed and delayed - m (PIRTerm uni fun, PIRTerm uni fun) +compileAlt + :: (CompilingDefault uni fun m ann) + => GHC.CoreAlt + -- ^ The 'CoreAlt' representing the branch itself. + -> [GHC.Type] + -- ^ The instantiated type arguments for the data constructor. + -> PIRTerm uni fun + -> m (PIRTerm uni fun, PIRTerm uni fun) + -- ^ Non-delayed and delayed compileAlt (GHC.Alt alt vars body) instArgTys defaultBody = traceCompilation 3 ("Creating alternative:" GHC.<+> GHC.ppr alt) $ case alt of GHC.LitAlt _ -> throwPlain $ UnsupportedError "Literal case" @@ -319,7 +320,7 @@ compileAlt (GHC.Alt alt vars body) instArgTys defaultBody = -- vars into scope whose body is the body of the case alternative. -- See Note [Iterated abstraction and application] -- See Note [Case expressions and laziness] - GHC.DataAlt _ -> withVarsScoped ((, Nothing) <$> vars) $ \vars' -> do + GHC.DataAlt _ -> withVarsScoped ((,Nothing) <$> vars) $ \vars' -> do b <- compileExpr body delayed <- delay b return (PLC.mkIterLamAbs vars' b, PLC.mkIterLamAbs vars' delayed) @@ -329,13 +330,14 @@ compileAlt (GHC.Alt alt vars body) instArgTys defaultBody = nonDelayed <- wrapDefaultAlt compiledBody delayed <- delay compiledBody >>= wrapDefaultAlt return (nonDelayed, delayed) - where - wrapDefaultAlt :: (CompilingDefault uni fun m ann) => PIRTerm uni fun -> m (PIRTerm uni fun) - wrapDefaultAlt body' = do - -- need to consume the args - argTypes <- mapM compileTypeNorm instArgTys - argNames <- forM [0 .. (length argTypes - 1)] (\i -> safeFreshName $ "default_arg" <> (T.pack $ show i)) - pure $ PIR.mkIterLamAbs (zipWith (PIR.VarDecl annMayInline) argNames argTypes) body' + where + wrapDefaultAlt :: (CompilingDefault uni fun m ann) => PIRTerm uni fun -> m (PIRTerm uni fun) + wrapDefaultAlt body' = do + -- need to consume the args + argTypes <- mapM compileTypeNorm instArgTys + argNames <- + forM [0 .. (length argTypes - 1)] (\i -> safeFreshName $ "default_arg" <> (T.pack $ show i)) + pure $ PIR.mkIterLamAbs (zipWith (PIR.VarDecl annMayInline) argNames argTypes) body' -- See Note [GHC runtime errors] isErrorId :: GHC.Id -> Bool @@ -345,7 +347,8 @@ isErrorId ghcId = ghcId `elem` GHC.errorIds isProbablyBytestringEq :: GHC.Id -> Bool isProbablyBytestringEq (GHC.getName -> n) | Just m <- GHC.nameModule_maybe n - , GHC.moduleNameString (GHC.moduleName m) == "Data.ByteString.Internal" || GHC.moduleNameString (GHC.moduleName m) == "Data.ByteString.Lazy.Internal" + , GHC.moduleNameString (GHC.moduleName m) == "Data.ByteString.Internal" + || GHC.moduleNameString (GHC.moduleName m) == "Data.ByteString.Lazy.Internal" , GHC.occNameString (GHC.nameOccName n) == "eq" = True isProbablyBytestringEq _ = False @@ -358,40 +361,43 @@ isProbablyIntegerEq (GHC.getName -> n) True isProbablyIntegerEq _ = False --- | Check for literal ranges like [1..9] and [1, 5..101]. This will also --- return `True` if there's an explicit use of `enumFromTo` or similar. +{-| Check for literal ranges like [1..9] and [1, 5..101]. This will also +return `True` if there's an explicit use of `enumFromTo` or similar. +-} isProbablyBoundedRange :: GHC.Id -> Bool isProbablyBoundedRange (GHC.getName -> n) - | Just m <- GHC.nameModule_maybe n - , GHC.moduleNameString (GHC.moduleName m) == "GHC.Enum" = - ("$fEnum" `isPrefixOf` methodName && - ( "_$cenumFromTo" `isSuffixOf` methodName -- [1..100] - || "_$cenumFromThenTo" `isSuffixOf` methodName -- [1,3..100] - ) - ) + | Just m <- GHC.nameModule_maybe n + , GHC.moduleNameString (GHC.moduleName m) == "GHC.Enum" = + ( "$fEnum" `isPrefixOf` methodName + && ( "_$cenumFromTo" `isSuffixOf` methodName -- [1..100] + || "_$cenumFromThenTo" `isSuffixOf` methodName -- [1,3..100] + ) + ) || "enumDeltaToInteger" `isPrefixOf` methodName - -- ^ These are introduced by inlining for Integer ranges in - -- GHC.Enum. This also happens for Char, Word, and Int, but those types - -- aren't supported in Plutus Core. - where methodName = GHC.occNameString (GHC.nameOccName n) + where + -- \^ These are introduced by inlining for Integer ranges in + -- GHC.Enum. This also happens for Char, Word, and Int, but those types + -- aren't supported in Plutus Core. + methodName = GHC.occNameString (GHC.nameOccName n) isProbablyBoundedRange _ = False --- | Check for literal ranges like [1..] and [1, 5..]. This will also return --- `True` if there's an explicit use of `enumFrom` or similar. +{-| Check for literal ranges like [1..] and [1, 5..]. This will also return +`True` if there's an explicit use of `enumFrom` or similar. +-} isProbablyUnboundedRange :: GHC.Id -> Bool isProbablyUnboundedRange (GHC.getName -> n) - | Just m <- GHC.nameModule_maybe n - , GHC.moduleNameString (GHC.moduleName m) == "GHC.Enum" = - ("$fEnum" `isPrefixOf` methodName && - ( "_$cenumFrom" `isSuffixOf` methodName -- [1..] - || "_$cenumFromThen" `isSuffixOf` methodName -- [1,3..] - ) - ) - || "enumDeltaInteger" `isPrefixOf` methodName -- Introduced by inlining - where methodName = GHC.occNameString (GHC.nameOccName n) + | Just m <- GHC.nameModule_maybe n + , GHC.moduleNameString (GHC.moduleName m) == "GHC.Enum" = + ( "$fEnum" `isPrefixOf` methodName + && ( "_$cenumFrom" `isSuffixOf` methodName -- [1..] + || "_$cenumFromThen" `isSuffixOf` methodName -- [1,3..] + ) + ) + || "enumDeltaInteger" `isPrefixOf` methodName -- Introduced by inlining + where + methodName = GHC.occNameString (GHC.nameOccName n) isProbablyUnboundedRange _ = False - {- Note [GHC runtime errors] GHC has a number of runtime errors for things like pattern matching failures and so on. @@ -604,11 +610,11 @@ for any variables that were freshly created by the simplifier. That's easy to fi ourselves before we start. -} -hoistExpr :: - (CompilingDefault uni fun m ann) => - GHC.Var -> - GHC.CoreExpr -> - m (PIRTerm uni fun) +hoistExpr + :: (CompilingDefault uni fun m ann) + => GHC.Var + -> GHC.CoreExpr + -> m (PIRTerm uni fun) hoistExpr var t = do wrapUnsafeDataAsConstrName <- lookupGhcName 'PlutusTx.AsData.Internal.wrapUnsafeDataAsConstr @@ -625,7 +631,8 @@ hoistExpr var t = do -- with it. ann = (if hasAlwaysInlinePragma var then annAlwaysInline else annMayInline) - { annIsAsDataMatcher = isAsDataMatcher } + { annIsAsDataMatcher = isAsDataMatcher + } -- See Note [Dependency tracking] modifyCurDeps (Set.insert lexName) maybeDef <- PIR.lookupTerm lexName @@ -648,7 +655,8 @@ hoistExpr var t = do PIR.modifyTermDef lexName (const $ PIR.Def var' (t', PIR.NonStrict)) pure $ PIR.mkVar var' -maybeProfileRhs :: (CompilingDefault uni fun m ann) => PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun) +maybeProfileRhs + :: (CompilingDefault uni fun m ann) => PLCVar uni -> PIRTerm uni fun -> m (PIRTerm uni fun) maybeProfileRhs var t = do CompileContext{ccOpts = compileOpts} <- ask let ty = PLC._varDeclType var @@ -662,24 +670,24 @@ maybeProfileRhs var t = do pure $ entryExitTracingInside thunk displayName t ty else pure t -mkTrace :: - (uni `PLC.HasTermLevel` T.Text) => - PLC.Type PLC.TyName uni Ann -> - T.Text -> - PIRTerm uni PLC.DefaultFun -> - PIRTerm uni PLC.DefaultFun +mkTrace + :: (uni `PLC.HasTermLevel` T.Text) + => PLC.Type PLC.TyName uni Ann + -> T.Text + -> PIRTerm uni PLC.DefaultFun + -> PIRTerm uni PLC.DefaultFun mkTrace ty str v = PLC.mkIterApp (PIR.TyInst annMayInline (PIR.Builtin annMayInline PLC.Trace) ty) ((annMayInline,) <$> [PLC.mkConstant annMayInline str, v]) -- `mkLazyTrace ty str v` builds the term `force (trace str (delay v))` if `v` has type `ty` -mkLazyTrace :: - (CompilingDefault uni fun m ann) => - PLC.Type PLC.TyName uni Ann -> - T.Text -> - PIRTerm uni PLC.DefaultFun -> - m (PIRTerm uni fun) +mkLazyTrace + :: (CompilingDefault uni fun m ann) + => PLC.Type PLC.TyName uni Ann + -> T.Text + -> PIRTerm uni PLC.DefaultFun + -> m (PIRTerm uni fun) mkLazyTrace ty str v = do delayedBody <- delay v delayedType <- delayType ty @@ -725,45 +733,45 @@ f :: Identity (a -> a) f = Identity (\x -> x) -} -{- | Add entry/exit tracing inside a term's leading arguments, both term and type arguments. +{-| Add entry/exit tracing inside a term's leading arguments, both term and type arguments. @(/\a -> \b -> body)@ into @/\a -> \b -> entryExitTracing body@. -} -entryExitTracingInside :: - PIR.Name -> - T.Text -> - PIRTerm PLC.DefaultUni PLC.DefaultFun -> - PLCType PLC.DefaultUni -> - PIRTerm PLC.DefaultUni PLC.DefaultFun +entryExitTracingInside + :: PIR.Name + -> T.Text + -> PIRTerm PLC.DefaultUni PLC.DefaultFun + -> PLCType PLC.DefaultUni + -> PIRTerm PLC.DefaultUni PLC.DefaultFun entryExitTracingInside lamName displayName = go mempty - where - go :: - Map.Map PLC.TyName (PLCType PLC.DefaultUni) -> - PIRTerm PLC.DefaultUni PLC.DefaultFun -> - PLCType PLC.DefaultUni -> - PIRTerm PLC.DefaultUni PLC.DefaultFun - go subst (LamAbs ann n t body) (PLC.TyFun _ _dom cod) = - -- when t = \x -> body, => \x -> entryExitTracingInside body - LamAbs ann n t $ go subst body cod - go subst (TyAbs ann tn1 k body) (PLC.TyForall _ tn2 _k ty) = - -- when t = /\x -> body, => /\x -> entryExitTracingInside body - -- See Note [Profiling polymorphic functions] - let subst' = Map.insert tn2 (PLC.TyVar annMayInline tn1) subst - in TyAbs ann tn1 k $ go subst' body ty - -- See Note [Term/type argument mismatches] - -- Even if there still look like there are arguments on the term or the type level, because we've hit - -- a mismatch we go ahead and insert our profiling traces here. - go subst e ty = - -- See Note [Profiling polymorphic functions] - let ty' = PLC.typeSubstTyNames (\tn -> Map.lookup tn subst) ty - in entryExitTracing lamName displayName e ty' + where + go + :: Map.Map PLC.TyName (PLCType PLC.DefaultUni) + -> PIRTerm PLC.DefaultUni PLC.DefaultFun + -> PLCType PLC.DefaultUni + -> PIRTerm PLC.DefaultUni PLC.DefaultFun + go subst (LamAbs ann n t body) (PLC.TyFun _ _dom cod) = + -- when t = \x -> body, => \x -> entryExitTracingInside body + LamAbs ann n t $ go subst body cod + go subst (TyAbs ann tn1 k body) (PLC.TyForall _ tn2 _k ty) = + -- when t = /\x -> body, => /\x -> entryExitTracingInside body + -- See Note [Profiling polymorphic functions] + let subst' = Map.insert tn2 (PLC.TyVar annMayInline tn1) subst + in TyAbs ann tn1 k $ go subst' body ty + -- See Note [Term/type argument mismatches] + -- Even if there still look like there are arguments on the term or the type level, because we've hit + -- a mismatch we go ahead and insert our profiling traces here. + go subst e ty = + -- See Note [Profiling polymorphic functions] + let ty' = PLC.typeSubstTyNames (\tn -> Map.lookup tn subst) ty + in entryExitTracing lamName displayName e ty' -- | Add tracing before entering and after exiting a term. -entryExitTracing :: - PLC.Name -> - T.Text -> - PIRTerm PLC.DefaultUni PLC.DefaultFun -> - PLC.Type PLC.TyName PLC.DefaultUni Ann -> - PIRTerm PLC.DefaultUni PLC.DefaultFun +entryExitTracing + :: PLC.Name + -> T.Text + -> PIRTerm PLC.DefaultUni PLC.DefaultFun + -> PLC.Type PLC.TyName PLC.DefaultUni Ann + -> PIRTerm PLC.DefaultUni PLC.DefaultFun entryExitTracing lamName displayName e ty = let defaultUnitTy = PLC.TyBuiltin annMayInline (PLC.SomeTypeIn PLC.DefaultUniUnit) defaultUnit = PIR.Constant annMayInline (PLC.someValueOf PLC.DefaultUniUnit ()) @@ -819,7 +827,7 @@ entryExitTracing lamName displayName e ty = an unfolding. -} -compileExpr :: CompilingDefault uni fun m ann => GHC.CoreExpr -> m (PIRTerm uni fun) +compileExpr :: (CompilingDefault uni fun m ann) => GHC.CoreExpr -> m (PIRTerm uni fun) compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do -- See Note [Scopes] CompileContext @@ -827,7 +835,8 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do , ccModBreaks = maybeModBreaks , ccBuiltinsInfo = binfo , ccSafeToInline = safeToInline - } <- ask + } <- + ask -- TODO: Maybe share this to avoid repeated lookups. Probably cheap, though. builtinIntegerTyCon <- lookupGhcTyCon ''BI.BuiltinInteger @@ -856,30 +865,31 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do Covered by this spec: plutus-tx-plugin/test/ShortCircuit/Spec.hs -} -- Lazy || - GHC.App (GHC.App (GHC.Var var) a) b | GHC.getName var == boolOperatorOr -> - compileExpr $ GHC.mkIfThenElse a (GHC.Var GHC.trueDataConId) b + GHC.App (GHC.App (GHC.Var var) a) b + | GHC.getName var == boolOperatorOr -> + compileExpr $ GHC.mkIfThenElse a (GHC.Var GHC.trueDataConId) b -- Lazy && - GHC.App (GHC.App (GHC.Var var) a) b | GHC.getName var == boolOperatorAnd -> - compileExpr $ GHC.mkIfThenElse a b (GHC.Var GHC.falseDataConId) + GHC.App (GHC.App (GHC.Var var) a) b + | GHC.getName var == boolOperatorAnd -> + compileExpr $ GHC.mkIfThenElse a b (GHC.Var GHC.falseDataConId) -- `inline f` or `inline (f x ... xn)` GHC.App (GHC.App (GHC.Var var) (GHC.Type _aTy)) e' | GHC.getName var == inlineName || GHC.getName var == GHC.inlineIdName -> - case GHC.collectArgs (strip e') of - (strip -> GHC.Var f, args) -> - case GHC.maybeUnfoldingTemplate (GHC.realIdUnfolding f) of - Nothing -> - case lookupName scope (GHC.getName f) of - -- If `f` is locally bound, and its definition has already been compiled, - -- we use it directly. - -- This only supports `inline f`, not `inline (f x1 ... xn)`. - Just (_var, Just def) | null args -> pure def - _ -> compileExpr e' - Just unfolding - -- `f` is recursive. We do not inline recursive bindings. - | any (== f) (universeBi unfolding) -> compileExpr e' - | otherwise -> compileExpr (GHC.mkCoreApps unfolding args) - _ -> compileExpr e' - + case GHC.collectArgs (strip e') of + (strip -> GHC.Var f, args) -> + case GHC.maybeUnfoldingTemplate (GHC.realIdUnfolding f) of + Nothing -> + case lookupName scope (GHC.getName f) of + -- If `f` is locally bound, and its definition has already been compiled, + -- we use it directly. + -- This only supports `inline f`, not `inline (f x1 ... xn)`. + Just (_var, Just def) | null args -> pure def + _ -> compileExpr e' + Just unfolding + -- `f` is recursive. We do not inline recursive bindings. + | any (== f) (universeBi unfolding) -> compileExpr e' + | otherwise -> compileExpr (GHC.mkCoreApps unfolding args) + _ -> compileExpr e' -- See Note [String literals] -- See Note [IsString instances and UTF-8 encoded string literals] -- IsString has only one method, so it's enough to know that it's an IsString method @@ -888,41 +898,52 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do -- we won't accept any applications of fromString that aren't creating literals of -- the types we support. (strip -> GHC.Var (GHC.idDetails -> GHC.ClassOpId cls)) - `GHC.App` GHC.Type ty `GHC.App` _dict `GHC.App` (strip -> content) - | GHC.getName cls == GHC.isStringClassName -> do - let throwUnsupported = - throwSd UnsupportedError $ "" - GHC.$$ "Use of fromString is only supported for the following types:" - GHC.$$ "-" GHC.<+> GHC.ppr stringTyName - GHC.$$ "-" GHC.<+> GHC.ppr builtinByteStringTyName - GHC.$$ "-" GHC.<+> GHC.ppr builtinByteStringHexTyName - GHC.$$ "-" GHC.<+> GHC.ppr builtinByteStringUtf8TyName - GHC.$$ "" - GHC.$$ "Using fromString for" GHC.<+> GHC.ppr ty GHC.<+> "is not supported." - case GHC.tyConAppTyCon_maybe ty of -- extract Type constructor without arguments + `GHC.App` GHC.Type ty + `GHC.App` _dict + `GHC.App` (strip -> content) + | GHC.getName cls == GHC.isStringClassName -> do + let throwUnsupported = + throwSd UnsupportedError $ + "" + GHC.$$ "Use of fromString is only supported for the following types:" + GHC.$$ "-" + GHC.<+> GHC.ppr stringTyName + GHC.$$ "-" + GHC.<+> GHC.ppr builtinByteStringTyName + GHC.$$ "-" + GHC.<+> GHC.ppr builtinByteStringHexTyName + GHC.$$ "-" + GHC.<+> GHC.ppr builtinByteStringUtf8TyName + GHC.$$ "" + GHC.$$ "Using fromString for" + GHC.<+> GHC.ppr ty + GHC.<+> "is not supported." + case GHC.tyConAppTyCon_maybe ty of -- extract Type constructor without arguments -- BuiltinByteString - Just tyCtor | GHC.getName tyCtor == builtinByteStringTyName -> do - bytes <- stringLiteralAsBytes builtinByteStringTyName content - PIR.Constant annMayInline . PLC.someValue <$> utf8CodePointsAsBytes bytes - -- BuiltinByteStringUtf8 - Just tyCtor | GHC.getName tyCtor == builtinByteStringUtf8TyName -> - PIR.Constant annMayInline . PLC.someValue - <$> stringLiteralAsBytes builtinByteStringUtf8TyName content - -- BuiltinByteStringHex - Just tyCtor | GHC.getName tyCtor == builtinByteStringHexTyName -> do - hexBytes <- stringLiteralAsBytes builtinByteStringHexTyName content - case Base16.decode hexBytes of - Left err -> throwSd UnsupportedError $ "Invalid hex encoding:" GHC.<+> GHC.text err - Right bs -> pure $ PIR.Constant annMayInline $ PLC.someValue bs - -- BuiltinString - Just tyCtor | GHC.getName tyCtor == stringTyName -> - PIR.Constant annMayInline . PLC.someValue - <$> stringLiteralAsText stringTyName content - -- For other unsupported types we have to fail compilation here, - -- because it won't succeed anyway: - -- 'fromString' function contains 'Data.Char' type in its definition - -- and plugin can't compile it. - _ -> throwUnsupported + Just tyCtor | GHC.getName tyCtor == builtinByteStringTyName -> do + bytes <- stringLiteralAsBytes builtinByteStringTyName content + PIR.Constant annMayInline . PLC.someValue <$> utf8CodePointsAsBytes bytes + -- BuiltinByteStringUtf8 + Just tyCtor + | GHC.getName tyCtor == builtinByteStringUtf8TyName -> + PIR.Constant annMayInline . PLC.someValue + <$> stringLiteralAsBytes builtinByteStringUtf8TyName content + -- BuiltinByteStringHex + Just tyCtor | GHC.getName tyCtor == builtinByteStringHexTyName -> do + hexBytes <- stringLiteralAsBytes builtinByteStringHexTyName content + case Base16.decode hexBytes of + Left err -> throwSd UnsupportedError $ "Invalid hex encoding:" GHC.<+> GHC.text err + Right bs -> pure $ PIR.Constant annMayInline $ PLC.someValue bs + -- BuiltinString + Just tyCtor + | GHC.getName tyCtor == stringTyName -> + PIR.Constant annMayInline . PLC.someValue + <$> stringLiteralAsText stringTyName content + -- For other unsupported types we have to fail compilation here, + -- because it won't succeed anyway: + -- 'fromString' function contains 'Data.Char' type in its definition + -- and plugin can't compile it. + _ -> throwUnsupported -- 'stringToBuiltinByteString' invocation (strip -> GHC.Var n) `GHC.App` (strip -> content) @@ -933,22 +954,20 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do -- 'stringToBuiltinByteStringUtf8' invocation (strip -> GHC.Var n) `GHC.App` (strip -> content) | GHC.getName n == stringToBuiltinByteStringUtf8Name -> - PIR.Constant annMayInline . PLC.someValue - <$> stringLiteralAsBytes builtinByteStringTyName content - + PIR.Constant annMayInline . PLC.someValue + <$> stringLiteralAsBytes builtinByteStringTyName content -- 'stringToBuiltinByteStringHex' invocation (strip -> GHC.Var n) `GHC.App` (strip -> content) | GHC.getName n == stringToBuiltinByteStringHexName -> do - hexBytes <- stringLiteralAsBytes builtinByteStringHexTyName content - case Base16.decode hexBytes of - Left err -> throwSd UnsupportedError $ "Invalid hex encoding:" GHC.<+> GHC.text err - Right bs -> pure $ PIR.Constant annMayInline $ PLC.someValue bs + hexBytes <- stringLiteralAsBytes builtinByteStringHexTyName content + case Base16.decode hexBytes of + Left err -> throwSd UnsupportedError $ "Invalid hex encoding:" GHC.<+> GHC.text err + Right bs -> pure $ PIR.Constant annMayInline $ PLC.someValue bs -- 'stringToBuiltinString' invocation (strip -> GHC.Var n) `GHC.App` (strip -> arg) | GHC.getName n == stringToBuiltinStringName -> - PIR.Constant annMayInline . PLC.someValue <$> stringLiteralAsText stringTyName arg - + PIR.Constant annMayInline . PLC.someValue <$> stringLiteralAsText stringTyName arg -- See Note [Literals] GHC.Lit lit -> compileLiteral lit -- These are all wrappers around string and char literals, but keeping them allows us to give better errors @@ -956,7 +975,8 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do GHC.Var n `GHC.App` expr | GHC.getName n == GHC.unpackCStringName -> compileExpr expr -- See Note [unpackFoldrCString#] GHC.Var build `GHC.App` _ `GHC.App` GHC.Lam _ (GHC.Var unpack `GHC.App` _ `GHC.App` expr) - | GHC.getName build == GHC.buildName && GHC.getName unpack == GHC.unpackCStringFoldrName -> compileExpr expr + | GHC.getName build == GHC.buildName && GHC.getName unpack == GHC.unpackCStringFoldrName -> + compileExpr expr -- C# is just a wrapper around a literal GHC.Var (GHC.idDetails -> GHC.DataConWorkId dc) `GHC.App` arg | dc == GHC.charDataCon -> compileExpr arg -- Handle constructors of 'Integer' @@ -996,32 +1016,45 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do _ -> throwPlain $ CompilationError "'mkNil' applied to an unknown type" GHC.Var n | GHC.getName n == useToOpaqueName -> - throwPlain $ UnsupportedError "It is no longer possible to use 'toBuiltin' with a script, use 'toOpaque' instead" + throwPlain $ + UnsupportedError "It is no longer possible to use 'toBuiltin' with a script, use 'toOpaque' instead" GHC.Var n | GHC.getName n == useFromOpaqueName -> - throwPlain $ UnsupportedError "It is no longer possible to use 'fromBuiltin' with a script, use 'fromOpaque' instead" + throwPlain $ + UnsupportedError + "It is no longer possible to use 'fromBuiltin' with a script, use 'fromOpaque' instead" -- See Note [Uses of Eq] GHC.Var n | GHC.getName n == GHC.eqName -> throwPlain $ UnsupportedError "Use of == from the Haskell Eq typeclass" GHC.Var n | isProbablyIntegerEq n -> - throwPlain $ UnsupportedError "Use of Haskell Integer equality, possibly via the Haskell Eq typeclass" + throwPlain $ + UnsupportedError "Use of Haskell Integer equality, possibly via the Haskell Eq typeclass" GHC.Var n | isProbablyBytestringEq n -> - throwPlain $ UnsupportedError "Use of Haskell ByteString equality, possibly via the Haskell Eq typeclass" + throwPlain $ + UnsupportedError "Use of Haskell ByteString equality, possibly via the Haskell Eq typeclass" GHC.Var n -- Try to produce a sensible error message if a range like [1..9] is encountered. This works -- by looking for occurrences of GHC.Enum.enumFromTo and similar functions; the same error -- occurs if these functions are used explicitly. | isProbablyBoundedRange n -> - throwPlain $ UnsupportedError $ T.pack ("Use of enumFromTo or enumFromThenTo, possibly via range syntax. " ++ - "Please use PlutusTx.Enum.enumFromTo or PlutusTx.Enum.enumFromThenTo instead.") + throwPlain $ + UnsupportedError $ + T.pack + ( "Use of enumFromTo or enumFromThenTo, possibly via range syntax. " + ++ "Please use PlutusTx.Enum.enumFromTo or PlutusTx.Enum.enumFromThenTo instead." + ) -- Throw an error if we find an infinite range like [1..] GHC.Var n | isProbablyUnboundedRange n -> - throwPlain $ UnsupportedError $ T.pack ("Use of enumFrom or enumFromThen, possibly via range syntax. " ++ - "Unbounded ranges are not supported.") + throwPlain $ + UnsupportedError $ + T.pack + ( "Use of enumFrom or enumFromThen, possibly via range syntax. " + ++ "Unbounded ranges are not supported." + ) -- locally bound vars GHC.Var (lookupName scope . GHC.getName -> Just (var, _def)) -> pure $ PIR.mkVar var -- Special kinds of id @@ -1095,8 +1128,8 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do GHC.Lam b@(GHC.isTyVar -> True) body -> -- Ignore type binders for runtime rep variables, see Note [Runtime reps] if GHC.isRuntimeRepTy $ GHC.varType b - then compileExpr body - else mkTyAbsScoped b $ compileExpr body + then compileExpr body + else mkTyAbsScoped b $ compileExpr body -- otherwise it's a normal lambda GHC.Lam b body -> do let ann = if safeToInline then annSafeToInline else annMayInline @@ -1105,24 +1138,25 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do -- the binding is in scope for the body, but not for the arg rhs' <- compileExpr rhs ty <- case rhs of - GHC.Lit (GHC.LitNumber{}) | GHC.eqType (GHC.varType b) GHC.byteArrayPrimTy -> - -- Handle the following case: - -- - -- ```PlutusTx - -- let !x = 12345678901234567890 - -- in PlutusTx.equalsInteger x y - -- ``` - -- - -- ```GHC Core - -- let { - -- x_sfhW :: ByteArray# - -- x_sfhW = 12345678901234567890 } in - -- equalsInteger (IP x_sfhW) y_X0 - -- ``` - -- - -- What we do here is ignoring the `ByteArray#`, and pretending that - --`12345678901234567890` is an Integer. - pure $ PIR.mkTyBuiltin @_ @Integer @PLC.DefaultUni annMayInline + GHC.Lit (GHC.LitNumber{}) + | GHC.eqType (GHC.varType b) GHC.byteArrayPrimTy -> + -- Handle the following case: + -- + -- ```PlutusTx + -- let !x = 12345678901234567890 + -- in PlutusTx.equalsInteger x y + -- ``` + -- + -- ```GHC Core + -- let { + -- x_sfhW :: ByteArray# + -- x_sfhW = 12345678901234567890 } in + -- equalsInteger (IP x_sfhW) y_X0 + -- ``` + -- + -- What we do here is ignoring the `ByteArray#`, and pretending that + -- `12345678901234567890` is an Integer. + pure $ PIR.mkTyBuiltin @_ @Integer @PLC.DefaultUni annMayInline _ -> compileTypeNorm $ GHC.varType b -- See Note [Non-strict let-bindings] withVarTyScoped b ty $ \v -> do @@ -1140,10 +1174,8 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do pure $ PIR.TermBind annMayInline PIR.NonStrict v rhs' body' <- compileExpr body pure $ PIR.mkLet annMayInline PIR.Rec binds body' - GHC.Case scrutinee b t alts -> compileCase (const . GHC.isDeadOcc . GHC.occInfo . GHC.idInfo) True binfo scrutinee b t alts - -- we can use source notes to get a better context for the inner expression -- these are put in when you compile with -g -- See Note [What source locations to cover] @@ -1162,40 +1194,41 @@ compileExpr e = traceCompilation 2 ("Compiling expr:" GHC.<+> GHC.ppr e) $ do GHC.Type _ -> throwPlain $ UnsupportedError "Types as standalone expressions" GHC.Coercion _ -> throwPlain $ UnsupportedError "Coercions as expressions" -compileCase :: - (CompilingDefault uni fun m ann) => - -- | Whether the variable is dead in the expr - (GHC.Var -> GHC.CoreExpr -> Bool) -> - -- | Whether we should try to rewrite unnecessary constructor applications - Bool -> - BuiltinsInfo uni fun -> - GHC.CoreExpr -> - GHC.Var -> - GHC.Type -> - [GHC.CoreAlt] -> - m (PIRTerm uni fun) +compileCase + :: (CompilingDefault uni fun m ann) + => (GHC.Var -> GHC.CoreExpr -> Bool) + -- ^ Whether the variable is dead in the expr + -> Bool + -- ^ Whether we should try to rewrite unnecessary constructor applications + -> BuiltinsInfo uni fun + -> GHC.CoreExpr + -> GHC.Var + -> GHC.Type + -> [GHC.CoreAlt] + -> m (PIRTerm uni fun) compileCase isDead rewriteConApps binfo scrutinee binder t alts = do wrapTailName <- lookupGhcName 'PlutusTx.AsData.Internal.wrapTail - let -- See Note [Compiling AsData Matchers and Their Invocations] - isWrapTailApp = - case GHC.collectArgs (strip scrutinee) of - (strip -> GHC.Var f, _args) -> GHC.getName f == wrapTailName - _ -> False - binderAnn - | hasAlwaysInlinePragma binder = annAlwaysInline - | isWrapTailApp = annSafeToInline - | otherwise = annMayInline + let + -- See Note [Compiling AsData Matchers and Their Invocations] + isWrapTailApp = + case GHC.collectArgs (strip scrutinee) of + (strip -> GHC.Var f, _args) -> GHC.getName f == wrapTailName + _ -> False + binderAnn + | hasAlwaysInlinePragma binder = annAlwaysInline + | isWrapTailApp = annSafeToInline + | otherwise = annMayInline case alts of [GHC.Alt con bs body] -- See Note [Evaluation-only cases] | all (`isDead` body) bs -> do - -- See Note [At patterns] - scrutinee' <- compileExpr scrutinee - withVarScoped binder binderAnn (Just scrutinee') $ \v -> do - body' <- compileExpr body -- See Note [At patterns] - let binds = [PIR.TermBind annMayInline PIR.Strict v scrutinee'] - pure $ PIR.mkLet annMayInline PIR.NonRec binds body' + scrutinee' <- compileExpr scrutinee + withVarScoped binder binderAnn (Just scrutinee') $ \v -> do + body' <- compileExpr body + -- See Note [At patterns] + let binds = [PIR.TermBind annMayInline PIR.Strict v scrutinee'] + pure $ PIR.mkLet annMayInline PIR.NonRec binds body' | rewriteConApps , GHC.DataAlt dataCon <- con -> do -- Attempt to rewrite constructor applications, since sometimes they cannot be @@ -1216,11 +1249,11 @@ compileCase isDead rewriteConApps binfo scrutinee binder t alts = do -- `all (`isDead` body) bs` branch of `compileCase`. let f (GHC.collectArgs -> (GHC.Var (GHC.isDataConId_maybe -> Just dataCon'), args0)) | dataCon == dataCon' - -- Discard type arguments - , let args = mapMaybe (\case GHC.Var v -> Just v; _ -> Nothing) args0 + , -- Discard type arguments + let args = mapMaybe (\case GHC.Var v -> Just v; _ -> Nothing) args0 , length bs == length args , and (zipWith (==) bs args) = - GHC.Var binder + GHC.Var binder f other = other -- This time we can no longer use `GHC.isDeadOcc`. Instead we check manually. isDead' b = not . any (== b) . universeBi @@ -1228,75 +1261,79 @@ compileCase isDead rewriteConApps binfo scrutinee binder t alts = do -- constructor applications again, which will loop), hence `False`. compileCase isDead' False binfo scrutinee binder t [GHC.Alt con bs (transform f body)] _ -> do - -- See Note [At patterns] - scrutinee' <- compileExpr scrutinee - let scrutineeType = GHC.varType binder - - -- the variable for the scrutinee is bound inside the cases, but not in the scrutinee expression itself - withVarScoped binder binderAnn (Just scrutinee') $ \v -> do - (tc, argTys) <- case GHC.splitTyConApp_maybe scrutineeType of - Just (tc, argTys) -> pure (tc, argTys) - Nothing -> - throwSd UnsupportedError $ - "Cannot case on a value of type:" GHC.<+> GHC.ppr scrutineeType - dcs <- getDataCons tc - - -- it's important to instantiate the match before alts compilation - match <- getMatchInstantiated scrutineeType - let matched = PIR.Apply annMayInline match scrutinee' - - let (rest, mdef) = GHC.findDefault alts - -- This does two things: - -- 1. Ensure that every set of alternatives has a DEFAULT alt (See Note [We always need DEFAULT]) - -- 2. Compile the body of the DEFAULT alt ahead of time so it can be shared (See Note [Sharing DEFAULT bodies]) - (alts', defCompiled) <- case mdef of - Just d -> do - defCompiled <- compileExpr d - pure (GHC.addDefault rest (Just d), defCompiled) - Nothing -> do - let d = GHC.mkImpossibleExpr t "unreachable alternative" - defCompiled <- compileExpr d - pure (GHC.addDefault alts (Just d), defCompiled) - defName <- PLC.freshName "defaultBody" - - -- See Note [Case expressions and laziness] - compiledAlts <- forM dcs $ \dc -> do - let alt = GHC.findAlt (GHC.DataAlt dc) alts' - -- these are the instantiated type arguments, e.g. for the data constructor Just when - -- matching on Maybe Int it is [Int] (crucially, not [a]) - instArgTys = GHC.scaledThing <$> GHC.dataConInstOrigArgTys dc argTys - case alt of - Just a -> do - -- pass in the body to use for default alternatives, see Note [Sharing DEFAULT bodies] - (nonDelayedAlt, delayedAlt) <- compileAlt a instArgTys (PIR.Var annMayInline defName) - return (nonDelayedAlt, delayedAlt) - Nothing -> throwSd CompilationError $ "No alternative for:" GHC.<+> GHC.ppr dc - let - isPureAlt = compiledAlts <&> \(nonDelayed, _) -> PIR.isPure binfo mempty nonDelayed - lazyCase = not (and isPureAlt || length dcs == 1) - branches = - compiledAlts <&> \(nonDelayedAlt, delayedAlt) -> - if lazyCase then delayedAlt else nonDelayedAlt - - -- See Note [Scott encoding of datatypes] - -- we need this for the default case body - originalResultType <- compileTypeNorm t - -- See Note [Scott encoding of datatypes] - -- we're going to delay the body, so the matcher needs to be instantiated at the delayed type - resultType <- maybeDelayType lazyCase originalResultType - let instantiated = PIR.TyInst annMayInline matched resultType - - let applied = PIR.mkIterApp instantiated $ (annMayInline,) <$> branches - -- See Note [Case expressions and laziness] - mainCase <- maybeForce lazyCase applied - - let binds = - [ -- See Note [At patterns] - PIR.TermBind annMayInline PIR.NonStrict v scrutinee' - , -- Bind the default body, see Note [Sharing DEFAULT bodies] - PIR.TermBind annMayInline PIR.NonStrict (PIR.VarDecl annMayInline defName originalResultType) defCompiled - ] - pure $ PIR.mkLet annMayInline PIR.NonRec binds mainCase + -- See Note [At patterns] + scrutinee' <- compileExpr scrutinee + let scrutineeType = GHC.varType binder + + -- the variable for the scrutinee is bound inside the cases, but not in the scrutinee expression itself + withVarScoped binder binderAnn (Just scrutinee') $ \v -> do + (tc, argTys) <- case GHC.splitTyConApp_maybe scrutineeType of + Just (tc, argTys) -> pure (tc, argTys) + Nothing -> + throwSd UnsupportedError $ + "Cannot case on a value of type:" GHC.<+> GHC.ppr scrutineeType + dcs <- getDataCons tc + + -- it's important to instantiate the match before alts compilation + match <- getMatchInstantiated scrutineeType + let matched = PIR.Apply annMayInline match scrutinee' + + let (rest, mdef) = GHC.findDefault alts + -- This does two things: + -- 1. Ensure that every set of alternatives has a DEFAULT alt (See Note [We always need DEFAULT]) + -- 2. Compile the body of the DEFAULT alt ahead of time so it can be shared (See Note [Sharing DEFAULT bodies]) + (alts', defCompiled) <- case mdef of + Just d -> do + defCompiled <- compileExpr d + pure (GHC.addDefault rest (Just d), defCompiled) + Nothing -> do + let d = GHC.mkImpossibleExpr t "unreachable alternative" + defCompiled <- compileExpr d + pure (GHC.addDefault alts (Just d), defCompiled) + defName <- PLC.freshName "defaultBody" + + -- See Note [Case expressions and laziness] + compiledAlts <- forM dcs $ \dc -> do + let alt = GHC.findAlt (GHC.DataAlt dc) alts' + -- these are the instantiated type arguments, e.g. for the data constructor Just when + -- matching on Maybe Int it is [Int] (crucially, not [a]) + instArgTys = GHC.scaledThing <$> GHC.dataConInstOrigArgTys dc argTys + case alt of + Just a -> do + -- pass in the body to use for default alternatives, see Note [Sharing DEFAULT bodies] + (nonDelayedAlt, delayedAlt) <- compileAlt a instArgTys (PIR.Var annMayInline defName) + return (nonDelayedAlt, delayedAlt) + Nothing -> throwSd CompilationError $ "No alternative for:" GHC.<+> GHC.ppr dc + let + isPureAlt = compiledAlts <&> \(nonDelayed, _) -> PIR.isPure binfo mempty nonDelayed + lazyCase = not (and isPureAlt || length dcs == 1) + branches = + compiledAlts <&> \(nonDelayedAlt, delayedAlt) -> + if lazyCase then delayedAlt else nonDelayedAlt + + -- See Note [Scott encoding of datatypes] + -- we need this for the default case body + originalResultType <- compileTypeNorm t + -- See Note [Scott encoding of datatypes] + -- we're going to delay the body, so the matcher needs to be instantiated at the delayed type + resultType <- maybeDelayType lazyCase originalResultType + let instantiated = PIR.TyInst annMayInline matched resultType + + let applied = PIR.mkIterApp instantiated $ (annMayInline,) <$> branches + -- See Note [Case expressions and laziness] + mainCase <- maybeForce lazyCase applied + + let binds = + [ -- See Note [At patterns] + PIR.TermBind annMayInline PIR.NonStrict v scrutinee' + , -- Bind the default body, see Note [Sharing DEFAULT bodies] + PIR.TermBind + annMayInline + PIR.NonStrict + (PIR.VarDecl annMayInline defName originalResultType) + defCompiled + ] + pure $ PIR.mkLet annMayInline PIR.NonRec binds mainCase {- Note [What source locations to cover] We try to get as much coverage information as we can out of GHC. This means that @@ -1345,20 +1382,20 @@ getVarSourceSpan = GHC.srcSpanToRealSrcSpan . GHC.nameSrcSpan . GHC.varName srcSpanIso :: Iso' GHC.RealSrcSpan SrcSpan srcSpanIso = iso fromGHC toGHC - where - fromGHC sp = - SrcSpan - { srcSpanFile = GHC.unpackFS (GHC.srcSpanFile sp) - , srcSpanSLine = GHC.srcSpanStartLine sp - , srcSpanSCol = GHC.srcSpanStartCol sp - , srcSpanELine = GHC.srcSpanEndLine sp - , srcSpanECol = GHC.srcSpanEndCol sp - } - toGHC sp = - GHC.mkRealSrcSpan - (GHC.mkRealSrcLoc (fileNameFs sp) (srcSpanSLine sp) (srcSpanSCol sp)) - (GHC.mkRealSrcLoc (fileNameFs sp) (srcSpanELine sp) (srcSpanECol sp)) - fileNameFs = GHC.fsLit . srcSpanFile + where + fromGHC sp = + SrcSpan + { srcSpanFile = GHC.unpackFS (GHC.srcSpanFile sp) + , srcSpanSLine = GHC.srcSpanStartLine sp + , srcSpanSCol = GHC.srcSpanStartCol sp + , srcSpanELine = GHC.srcSpanEndLine sp + , srcSpanECol = GHC.srcSpanEndCol sp + } + toGHC sp = + GHC.mkRealSrcSpan + (GHC.mkRealSrcLoc (fileNameFs sp) (srcSpanSLine sp) (srcSpanSCol sp)) + (GHC.mkRealSrcLoc (fileNameFs sp) (srcSpanELine sp) (srcSpanECol sp)) + fileNameFs = GHC.fsLit . srcSpanFile -- | Obviously this function computes a GHC.RealSrcSpan from a CovLoc toCovLoc :: GHC.RealSrcSpan -> CovLoc @@ -1375,19 +1412,19 @@ toCovLoc sp = -- See Note [Coverage order] -- | Annotate a term for coverage -coverageCompile :: - (CompilingDefault uni fun m ann) => - -- | The original expression - GHC.CoreExpr -> - -- | The type of the expression - GHC.Type -> - -- | The source location of this expression - GHC.RealSrcSpan -> - -- | The current term (this is what we add coverage tracking to) - PIRTerm uni fun -> - -- | The type of coverage to do next - CoverageType -> - m (PIRTerm uni fun) +coverageCompile + :: (CompilingDefault uni fun m ann) + => GHC.CoreExpr + -- ^ The original expression + -> GHC.Type + -- ^ The type of the expression + -> GHC.RealSrcSpan + -- ^ The source location of this expression + -> PIRTerm uni fun + -- ^ The current term (this is what we add coverage tracking to) + -> CoverageType + -- ^ The type of coverage to do next + -> m (PIRTerm uni fun) coverageCompile originalExpr exprType src compiledTerm covT = case covT of -- Add a location coverage annotation to tell us "we've executed this piece of code" @@ -1402,7 +1439,7 @@ coverageCompile originalExpr exprType src compiledTerm covT = -- Check if the thing we are compiling is a boolean boolName <- lookupGhcName ''Bool trueName <- lookupGhcName 'True - falseName <-lookupGhcName 'False + falseName <- lookupGhcName 'False let tyHeadName = GHC.getName <$> GHC.tyConAppTyCon_maybe exprType headSymName = GHC.getName <$> findHeadSymbol originalExpr isTrueOrFalse = case originalExpr of @@ -1419,8 +1456,10 @@ coverageCompile originalExpr exprType src compiledTerm covT = -- traceBool "" "" compiledTerm -- ``` traceBoolCompiled <- compileExpr . GHC.Var =<< lookupGhcId 'traceBool - let mkMetadata = CoverageMetadata . foldMap - (Set.singleton . ApplicationHeadSymbol . GHC.getOccString) + let mkMetadata = + CoverageMetadata + . foldMap + (Set.singleton . ApplicationHeadSymbol . GHC.getOccString) fc <- addBoolCaseToCoverageIndex (toCovLoc src) False (mkMetadata headSymName) tc <- addBoolCaseToCoverageIndex (toCovLoc src) True (mkMetadata headSymName) pure . PLC.mkIterApp traceBoolCompiled $ @@ -1429,23 +1468,24 @@ coverageCompile originalExpr exprType src compiledTerm covT = , PLC.mkConstant annMayInline (T.pack . show $ fc) , compiledTerm ] - where - findHeadSymbol :: GHC.CoreExpr -> Maybe GHC.Id - findHeadSymbol (GHC.Var n) = Just n - findHeadSymbol (GHC.App t _) = findHeadSymbol t - findHeadSymbol (GHC.Lam _ t) = findHeadSymbol t - findHeadSymbol (GHC.Tick _ t) = findHeadSymbol t - findHeadSymbol (GHC.Let _ t) = findHeadSymbol t - findHeadSymbol (GHC.Cast t _) = findHeadSymbol t - findHeadSymbol _ = Nothing + where + findHeadSymbol :: GHC.CoreExpr -> Maybe GHC.Id + findHeadSymbol (GHC.Var n) = Just n + findHeadSymbol (GHC.App t _) = findHeadSymbol t + findHeadSymbol (GHC.Lam _ t) = findHeadSymbol t + findHeadSymbol (GHC.Tick _ t) = findHeadSymbol t + findHeadSymbol (GHC.Let _ t) = findHeadSymbol t + findHeadSymbol (GHC.Cast t _) = findHeadSymbol t + findHeadSymbol _ = Nothing hasAlwaysInlinePragma :: GHC.Var -> Bool hasAlwaysInlinePragma = GHC.isInlinePragma . GHC.idInlinePragma --- | We cannot compile the unfolding of `GHC.Num.Integer.integerNegate`, which is --- important because GHC inserts calls to it when it sees negations, even negations --- of literals (unless NegativeLiterals is on, which it usually isn't). So we directly --- define a PIR term for it: @integerNegate = \x -> 0 - x@. +{-| We cannot compile the unfolding of `GHC.Num.Integer.integerNegate`, which is +important because GHC inserts calls to it when it sees negations, even negations +of literals (unless NegativeLiterals is on, which it usually isn't). So we directly +define a PIR term for it: @integerNegate = \x -> 0 - x@. +-} defineIntegerNegate :: (CompilingDefault PLC.DefaultUni fun m ann) => m () defineIntegerNegate = do ghcId <- lookupGhcId 'GHC.Num.Integer.integerNegate @@ -1483,13 +1523,14 @@ lookupIntegerNegate = do ghcName <- lookupGhcName 'GHC.Num.Integer.integerNegate PIR.lookupTerm (LexName ghcName) >>= \case Just t -> pure t - Nothing -> throwPlain $ - CompilationError "Cannot find the definition of integerNegate. Please file a bug report." + Nothing -> + throwPlain $ + CompilationError "Cannot find the definition of integerNegate. Please file a bug report." -compileExprWithDefs :: - (CompilingDefault uni fun m ann) => - GHC.CoreExpr -> - m (PIRTerm uni fun) +compileExprWithDefs + :: (CompilingDefault uni fun m ann) + => GHC.CoreExpr + -> m (PIRTerm uni fun) compileExprWithDefs e = do defineBuiltinTypes defineBuiltinTerms diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Kind.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Kind.hs index 858a62e2f75..96177f7436a 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Kind.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Kind.hs @@ -15,14 +15,14 @@ import GHC.Plugins qualified as GHC import PlutusCore qualified as PLC -compileKind :: Compiling uni fun m ann => GHC.Kind -> m (PLC.Kind ()) +compileKind :: (Compiling uni fun m ann) => GHC.Kind -> m (PLC.Kind ()) compileKind k = traceCompilation 2 ("Compiling kind:" GHC.<+> GHC.ppr k) $ case k of - -- this is a bit weird because GHC uses 'Type' to represent kinds, so '* -> *' is a 'TyFun' - (GHC.isLiftedTypeKind -> True) -> pure $ PLC.Type () - (GHC.splitFunTy_maybe -> Just r) -> case r of - (_t, _m, i, o) -> PLC.KindArrow () <$> compileKind i <*> compileKind o - -- Ignore type binders for runtime rep variables, see Note [Runtime reps] - (GHC.splitForAllTyCoVar_maybe -> Just (tvar, ty)) | (GHC.isRuntimeRepTy . GHC.varType) tvar -> compileKind ty - -- Interpret 'TYPE rep' as 'TYPE LiftedRep', for any rep, see Note [Runtime reps] - (GHC.isTypeLikeKind -> True) -> pure $ PLC.Type () - _ -> throwSd UnsupportedError $ "Kind:" GHC.<+> (GHC.ppr k) + -- this is a bit weird because GHC uses 'Type' to represent kinds, so '* -> *' is a 'TyFun' + (GHC.isLiftedTypeKind -> True) -> pure $ PLC.Type () + (GHC.splitFunTy_maybe -> Just r) -> case r of + (_t, _m, i, o) -> PLC.KindArrow () <$> compileKind i <*> compileKind o + -- Ignore type binders for runtime rep variables, see Note [Runtime reps] + (GHC.splitForAllTyCoVar_maybe -> Just (tvar, ty)) | (GHC.isRuntimeRepTy . GHC.varType) tvar -> compileKind ty + -- Interpret 'TYPE rep' as 'TYPE LiftedRep', for any rep, see Note [Runtime reps] + (GHC.isTypeLikeKind -> True) -> pure $ PLC.Type () + _ -> throwSd UnsupportedError $ "Kind:" GHC.<+> (GHC.ppr k) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Laziness.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Laziness.hs index 3902c28c131..80a7c103627 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Laziness.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Laziness.hs @@ -25,35 +25,43 @@ with the standard library because it makes the generated terms simpler without t a simplifier pass. Also, PLC isn't lazy, so combinators work less well. -} -delay :: Compiling uni fun m ann => PIRTerm uni fun -> m (PIRTerm uni fun) -delay body = PIR.TyAbs annMayInline <$> liftQuote (freshTyName "dead") <*> pure (PIR.Type annMayInline) <*> pure body +delay :: (Compiling uni fun m ann) => PIRTerm uni fun -> m (PIRTerm uni fun) +delay body = + PIR.TyAbs annMayInline + <$> liftQuote (freshTyName "dead") + <*> pure (PIR.Type annMayInline) + <*> pure body -delayType :: Compiling uni fun m ann => PIRType uni -> m (PIRType uni) -delayType orig = PIR.TyForall annMayInline <$> liftQuote (freshTyName "dead") <*> pure (PIR.Type annMayInline) <*> pure orig +delayType :: (Compiling uni fun m ann) => PIRType uni -> m (PIRType uni) +delayType orig = + PIR.TyForall annMayInline + <$> liftQuote (freshTyName "dead") + <*> pure (PIR.Type annMayInline) + <*> pure orig -delayVar :: Compiling uni fun m ann => PIRVar uni -> m (PIRVar uni) +delayVar :: (Compiling uni fun m ann) => PIRVar uni -> m (PIRVar uni) delayVar (PIR.VarDecl ann n ty) = do - ty' <- delayType ty - pure $ PIR.VarDecl ann n ty' + ty' <- delayType ty + pure $ PIR.VarDecl ann n ty' force - :: CompilingDefault uni fun m ann - => PIRTerm uni fun -> m (PIRTerm uni fun) + :: (CompilingDefault uni fun m ann) + => PIRTerm uni fun -> m (PIRTerm uni fun) force thunk = do - a <- liftQuote (freshTyName "dead") - let fakeTy = PIR.TyForall annMayInline a (PIR.Type annMayInline) (PIR.TyVar annMayInline a) - pure $ PIR.TyInst annMayInline thunk fakeTy + a <- liftQuote (freshTyName "dead") + let fakeTy = PIR.TyForall annMayInline a (PIR.Type annMayInline) (PIR.TyVar annMayInline a) + pure $ PIR.TyInst annMayInline thunk fakeTy -maybeDelay :: Compiling uni fun m ann => Bool -> PIRTerm uni fun -> m (PIRTerm uni fun) +maybeDelay :: (Compiling uni fun m ann) => Bool -> PIRTerm uni fun -> m (PIRTerm uni fun) maybeDelay yes t = if yes then delay t else pure t -maybeDelayVar :: Compiling uni fun m ann => Bool -> PIRVar uni -> m (PIRVar uni) +maybeDelayVar :: (Compiling uni fun m ann) => Bool -> PIRVar uni -> m (PIRVar uni) maybeDelayVar yes v = if yes then delayVar v else pure v -maybeDelayType :: Compiling uni fun m ann => Bool -> PIRType uni -> m (PIRType uni) +maybeDelayType :: (Compiling uni fun m ann) => Bool -> PIRType uni -> m (PIRType uni) maybeDelayType yes t = if yes then delayType t else pure t maybeForce - :: CompilingDefault uni fun m ann - => Bool -> PIRTerm uni fun -> m (PIRTerm uni fun) + :: (CompilingDefault uni fun m ann) + => Bool -> PIRTerm uni fun -> m (PIRTerm uni fun) maybeForce yes t = if yes then force t else pure t diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Names.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Names.hs index 7483f3525ce..6be98999120 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Names.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Names.hs @@ -28,7 +28,7 @@ import Data.Text qualified as T lookupName :: Scope uni fun -> GHC.Name -> Maybe (PLCVar uni, Maybe (PIRTerm uni fun)) lookupName (Scope ns _) n = Map.lookup n ns -{- | +{-| Reverses the OccName tidying that GHC does, see 'tidyOccEnv' and accompanying Notes. @@ -57,15 +57,15 @@ compileVarFresh ann v = do n' <- compileNameFresh $ GHC.getName v pure $ PLC.VarDecl ann n' t' -{- | Like `compileVarFresh`, but takes a `PIRType` instead of obtaining the +{-| Like `compileVarFresh`, but takes a `PIRType` instead of obtaining the PIR type from the given `GHC.Var`. -} -compileVarWithTyFresh :: - (CompilingDefault uni fun m ann) => - Ann -> - GHC.Var -> - PIRType uni -> - m (PLCVar uni) +compileVarWithTyFresh + :: (CompilingDefault uni fun m ann) + => Ann + -> GHC.Var + -> PIRType uni + -> m (PLCVar uni) compileVarWithTyFresh ann v t = do n' <- compileNameFresh $ GHC.getName v pure $ PLC.VarDecl ann n' t @@ -91,7 +91,7 @@ compileTcTyVarFresh tc = do pushName :: GHC.Name -> PLCVar uni -> Maybe (PIRTerm uni fun) -> Scope uni fun -> Scope uni fun pushName ghcName n def (Scope ns tyns) = Scope (Map.insert ghcName (n, def) ns) tyns -pushNames :: [(GHC.Name, PLCVar uni, Maybe (PIRTerm uni fun ))] -> Scope uni fun -> Scope uni fun +pushNames :: [(GHC.Name, PLCVar uni, Maybe (PIRTerm uni fun))] -> Scope uni fun -> Scope uni fun pushNames mappings scope = foldl' (\acc (n, v, def) -> pushName n v def acc) scope mappings pushTyName :: GHC.Name -> PLCTyVar -> Scope uni fun -> Scope uni fun diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Trace.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Trace.hs index a2deed02ce0..55c07314fa0 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Trace.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Trace.hs @@ -16,32 +16,35 @@ import Data.Text (Text) import Debug.Trace import GHC.Plugins qualified as GHC --- | A combination of `withContextM` and `traceCompilationStep`. --- --- `withContextM` emits a stack trace when the compilation fails, and can be --- turned on via `-fcontext-level=`. --- --- `traceCompilationStep` dumps the full compilation trace, and can be --- turned on via `-fdump-compilation-trace`. -traceCompilation :: - (MonadReader (CompileContext uni fun) m, MonadState CompileState m - , MonadError (WithContext Text e) m) => - -- | Context level - Int -> - -- | The thing (expr, type, kind, etc.) being compiled - GHC.SDoc -> - -- | The compilation action - m a -> - m a +{-| A combination of `withContextM` and `traceCompilationStep`. + +`withContextM` emits a stack trace when the compilation fails, and can be +turned on via `-fcontext-level=`. + +`traceCompilationStep` dumps the full compilation trace, and can be +turned on via `-fdump-compilation-trace`. +-} +traceCompilation + :: ( MonadReader (CompileContext uni fun) m + , MonadState CompileState m + , MonadError (WithContext Text e) m + ) + => Int + -- ^ Context level + -> GHC.SDoc + -- ^ The thing (expr, type, kind, etc.) being compiled + -> m a + -- ^ The compilation action + -> m a traceCompilation p sd = withContextM p (sdToTxt sd) . traceCompilationStep sd -traceCompilationStep :: - (MonadReader (CompileContext uni fun) m, MonadState CompileState m) => - -- | The thing (expr, type, kind, etc.) being compiled - GHC.SDoc -> - -- | The compilation action - m a -> - m a +traceCompilationStep + :: (MonadReader (CompileContext uni fun) m, MonadState CompileState m) + => GHC.SDoc + -- ^ The thing (expr, type, kind, etc.) being compiled + -> m a + -- ^ The compilation action + -> m a traceCompilationStep sd compile = ifM (notM (asks ccDebugTraceOn)) compile $ do CompileState nextStep prevSteps <- get put $ CompileState (nextStep + 1) (nextStep : prevSteps) diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs index 3e75c292cb4..312fd3d43b1 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Type.hs @@ -4,7 +4,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{- | Functions for compiling GHC types into PlutusCore types, as well as compiling constructors, +{-| Functions for compiling GHC types into PlutusCore types, as well as compiling constructors, matchers, and pattern match alternatives. -} module PlutusTx.Compiler.Type ( @@ -63,7 +63,7 @@ TODO: use topNormaliseType to be more efficient and handle newtypes as well. Pro is dealing with recursive newtypes. -} -{- | Compile a type, first of all normalizing it to remove type family redexes. +{-| Compile a type, first of all normalizing it to remove type family redexes. Generally, we need to call this whenever we are compiling a "new" type from the program. If we are compiling a part of a type we are already processing then it has likely been @@ -99,8 +99,8 @@ compileType t = traceCompilation 2 ("Compiling type:" GHC.<+> GHC.ppr t) $ do (GHC.splitForAllTyCoVar_maybe -> Just (tv, tpe)) -> -- Ignore type binders for runtime rep variables, see Note [Runtime reps] if (GHC.isRuntimeRepTy . GHC.varType) tv - then compileType tpe - else mkTyForallScoped tv (compileType tpe) + then compileType tpe + else mkTyForallScoped tv (compileType tpe) -- I think it's safe to ignore the coercion here (GHC.splitCastTy_maybe -> Just (tpe, _)) -> compileType tpe _ -> throwSd UnsupportedError $ "Type" GHC.<+> GHC.ppr t @@ -122,11 +122,11 @@ we just have to ban recursive newtypes, and we do this by blackholing the name w definition, and dying if we see it again. -} -compileTyCon :: - forall uni fun m ann. - (CompilingDefault uni fun m ann) => - GHC.TyCon -> - m (PIRType uni) +compileTyCon + :: forall uni fun m ann + . (CompilingDefault uni fun m ann) + => GHC.TyCon + -> m (PIRType uni) compileTyCon tc | tc == GHC.intTyCon = throwPlain $ UnsupportedError "Int: use Integer instead" | tc == GHC.intPrimTyCon = @@ -251,20 +251,20 @@ sortConstructors tc cs = getDataCons :: (Compiling uni fun m ann) => GHC.TyCon -> m [GHC.DataCon] getDataCons tc' = sortConstructors tc' <$> extractDcs tc' - where - extractDcs tc - | GHC.isAlgTyCon tc || GHC.isTupleTyCon tc = case GHC.algTyConRhs tc of - GHC.AbstractTyCon -> - throwSd UnsupportedError $ - "Abstract type:" GHC.<+> GHC.ppr tc - GHC.DataTyCon{GHC.data_cons = dcs} -> pure dcs - GHC.TupleTyCon{GHC.data_con = dc} -> pure [dc] - GHC.SumTyCon{GHC.data_cons = dcs} -> pure dcs - GHC.NewTyCon{GHC.data_con = dc} -> pure [dc] - | GHC.isFamilyTyCon tc = + where + extractDcs tc + | GHC.isAlgTyCon tc || GHC.isTupleTyCon tc = case GHC.algTyConRhs tc of + GHC.AbstractTyCon -> throwSd UnsupportedError $ - "Irreducible type family application:" GHC.<+> GHC.ppr tc - | otherwise = throwSd UnsupportedError $ "Type constructor:" GHC.<+> GHC.ppr tc + "Abstract type:" GHC.<+> GHC.ppr tc + GHC.DataTyCon{GHC.data_cons = dcs} -> pure dcs + GHC.TupleTyCon{GHC.data_con = dc} -> pure [dc] + GHC.SumTyCon{GHC.data_cons = dcs} -> pure dcs + GHC.NewTyCon{GHC.data_con = dc} -> pure [dc] + | GHC.isFamilyTyCon tc = + throwSd UnsupportedError $ + "Irreducible type family application:" GHC.<+> GHC.ppr tc + | otherwise = throwSd UnsupportedError $ "Type constructor:" GHC.<+> GHC.ppr tc {- Note [On data constructor workers and wrappers] By default GHC has 'unbox-small-strict-fields' flag enabled. @@ -278,7 +278,7 @@ That fixes the type mismatch problem when the GHC unpacks the field but we infer the type of the original code without that information. -} -{- | Makes the type of the constructor corresponding to the given 'DataCon', with the +{-| Makes the type of the constructor corresponding to the given 'DataCon', with the type variables free. -} mkConstructorType :: (CompilingDefault uni fun m ann) => GHC.DataCon -> m (PIRType uni) @@ -322,7 +322,7 @@ getMatch tc = do throwSd UnsupportedError $ "Cannot case on a value on type:" GHC.<+> GHC.ppr tc GHC.$+$ ghcStrictnessNote -{- | Get the matcher of the given 'Type' (which must be equal to a type constructor application) +{-| Get the matcher of the given 'Type' (which must be equal to a type constructor application) as a PLC term instantiated for the type constructor argument types. -} getMatchInstantiated :: (CompilingDefault uni fun m ann) => GHC.Type -> m (PIRTerm uni fun) @@ -338,7 +338,7 @@ getMatchInstantiated t = throwSd CompilationError $ "Cannot case on a value of a type which is not a datatype:" GHC.<+> GHC.ppr t -{- | Drops prefix of 'RuntimeRep' type variables (similar to 'dropRuntimeRepArgs'). +{-| Drops prefix of 'RuntimeRep' type variables (similar to 'dropRuntimeRepArgs'). Useful for e.g. dropping 'LiftedRep type variables arguments of unboxed tuple type applications: dropRuntimeRepVars [ k0, k1, a, b ] == [a, b] diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs index cd762e39525..009d89a37ee 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Types.hs @@ -8,9 +8,9 @@ {-# LANGUAGE TypeOperators #-} module PlutusTx.Compiler.Types ( - module PlutusTx.Compiler.Types, - module PlutusCore.Annotation - ) where + module PlutusTx.Compiler.Types, + module PlutusCore.Annotation, +) where import PlutusTx.Compiler.Error import PlutusTx.Coverage @@ -45,76 +45,85 @@ import Prettyprinter type NameInfo = Map.Map TH.Name GHC.TyThing -- | Compilation options. -data CompileOptions = CompileOptions { - coProfile :: ProfileOpts - , coCoverage :: CoverageOpts - , coRemoveTrace :: Bool - , coInlineFix :: Bool - } - -data CompileContext uni fun = CompileContext { - ccOpts :: CompileOptions, - ccFlags :: GHC.DynFlags, - ccFamInstEnvs :: GHC.FamInstEnvs, - ccNameInfo :: NameInfo, - ccScope :: Scope uni fun, - ccBlackholed :: Set.Set GHC.Name, - ccCurDef :: Maybe LexName, - ccModBreaks :: Maybe GHC.ModBreaks, - ccBuiltinsInfo :: PIR.BuiltinsInfo uni fun, - ccBuiltinCostModel :: PLC.CostingPart uni fun, - ccDebugTraceOn :: Bool, - ccRewriteRules :: PIR.RewriteRules uni fun, - ccSafeToInline :: Bool - } +data CompileOptions = CompileOptions + { coProfile :: ProfileOpts + , coCoverage :: CoverageOpts + , coRemoveTrace :: Bool + , coInlineFix :: Bool + } + +data CompileContext uni fun = CompileContext + { ccOpts :: CompileOptions + , ccFlags :: GHC.DynFlags + , ccFamInstEnvs :: GHC.FamInstEnvs + , ccNameInfo :: NameInfo + , ccScope :: Scope uni fun + , ccBlackholed :: Set.Set GHC.Name + , ccCurDef :: Maybe LexName + , ccModBreaks :: Maybe GHC.ModBreaks + , ccBuiltinsInfo :: PIR.BuiltinsInfo uni fun + , ccBuiltinCostModel :: PLC.CostingPart uni fun + , ccDebugTraceOn :: Bool + , ccRewriteRules :: PIR.RewriteRules uni fun + , ccSafeToInline :: Bool + } data CompileState = CompileState - { -- | The ID of the next step to be taken by the PlutusTx compiler. - -- This is used when generating debug traces. - csNextStep :: Int - -- | The IDs of the previous steps taken by the PlutusTx compiler leading up to - -- the current point. This is used when generating debug traces. - , csPreviousSteps :: [Int] - } + { csNextStep :: Int + {- ^ The ID of the next step to be taken by the PlutusTx compiler. + This is used when generating debug traces. + -} + , csPreviousSteps :: [Int] + {- ^ The IDs of the previous steps taken by the PlutusTx compiler leading up to + the current point. This is used when generating debug traces. + -} + } -- | Verbosity level of the Plutus Tx compiler. -data Verbosity = - Quiet - | Verbose - | Debug - deriving stock (Eq, Show) +data Verbosity + = Quiet + | Verbose + | Debug + deriving stock (Eq, Show) instance Pretty Verbosity where - pretty = viaShow + pretty = viaShow -- | Profiling options. @All@ profiles everything. @None@ is the default. -data ProfileOpts = - All -- set this with -fplugin-opt PlutusTx.Plugin:profile-all - | None - deriving stock (Eq, Show) +data ProfileOpts + = All -- set this with -fplugin-opt PlutusTx.Plugin:profile-all + | None + deriving stock (Eq, Show) instance Pretty ProfileOpts where - pretty = viaShow + pretty = viaShow --- | Coverage options --- See Note [Coverage annotations] -data CoverageOpts = CoverageOpts { unCoverageOpts :: Set CoverageType } +{-| Coverage options +See Note [Coverage annotations] +-} +data CoverageOpts = CoverageOpts {unCoverageOpts :: Set CoverageType} -- | Get the coverage types we are using activeCoverageTypes :: CompileOptions -> Set CoverageType activeCoverageTypes = unCoverageOpts . coCoverage --- | Option `{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-all #-}` enables all these --- See Note [Adding more coverage annotations]. --- See Note [Coverage order] -data CoverageType = LocationCoverage -- ^ Check that all source locations that we can identify in GHC Core have been covered. - -- For this to work at all we need `{-# OPTIONS_GHC -g #-}` - -- turn on with `{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-location #-}` - | BooleanCoverage -- ^ Check that every boolean valued expression that isn't `True` or `False` for which - -- we know the source location have been covered. For this to work at all we need - -- `{-# OPTIONS_GHC -g #-}` turn on with - -- `{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-boolean #-}` - deriving stock (Ord, Eq, Show, Enum, Bounded) +{-| Option `{\-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-all #-\}` enables all these +See Note [Adding more coverage annotations]. +See Note [Coverage order] +-} +data CoverageType + = {-| Check that all source locations that we can identify in GHC Core have been covered. + For this to work at all we need `{\-# OPTIONS_GHC -g #-\}` + turn on with `{\-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-location #-\}` + -} + LocationCoverage + | {-| Check that every boolean valued expression that isn't `True` or `False` for which + we know the source location have been covered. For this to work at all we need + `{\-# OPTIONS_GHC -g #-\}` turn on with + `{\-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:coverage-boolean #-\}` + -} + BooleanCoverage + deriving stock (Ord, Eq, Show, Enum, Bounded) {- Note [Coverage order] The order in which `CoverageType` constructors appear in the type determine the order in @@ -126,27 +135,28 @@ data CoverageType = LocationCoverage -- ^ Check that all source locations that w and you've read the code of `coverageCompile` carefully. -} --- | A wrapper around 'GHC.Name' with a stable 'Ord' instance. Use this where the ordering --- will affect the output of the compiler, i.e. when sorting or so on. It's fine to use --- 'GHC.Name' if we're just putting them in a 'Set.Set', for example. --- --- The 'Eq' instance we derive - it's also not stable across builds, but I believe this is only --- a problem if you compare things from different builds, which we don't do. +{-| A wrapper around 'GHC.Name' with a stable 'Ord' instance. Use this where the ordering +will affect the output of the compiler, i.e. when sorting or so on. It's fine to use +'GHC.Name' if we're just putting them in a 'Set.Set', for example. + +The 'Eq' instance we derive - it's also not stable across builds, but I believe this is only +a problem if you compare things from different builds, which we don't do. +-} newtype LexName = LexName GHC.Name - deriving stock (Eq) + deriving stock (Eq) instance Show LexName where - show (LexName n) = GHC.occNameString $ GHC.occName n + show (LexName n) = GHC.occNameString $ GHC.occName n instance Ord LexName where - compare (LexName n1) (LexName n2) = - case stableNameCmp n1 n2 of - -- This case is not sound if the names are generated, so we have to - -- fall back on the default sound comparison for names. This is - -- non-deterministic! But we care even more about not mixing up things - -- that are different than we do about determinism. - EQ -> compare n1 n2 - o -> o + compare (LexName n1) (LexName n2) = + case stableNameCmp n1 n2 of + -- This case is not sound if the names are generated, so we have to + -- fall back on the default sound comparison for names. This is + -- non-deterministic! But we care even more about not mixing up things + -- that are different than we do about determinism. + EQ -> compare n1 n2 + o -> o {- Note [Stable name comparisons] GHC defines `stableNameCmp` which does a good job of being a stable name @@ -174,50 +184,52 @@ the same, but e.g. we can't look directly at the "sort" of a `Name`. -- | Our own version of 'GHC.stableNameCmp'. stableNameCmp :: GHC.Name -> GHC.Name -> Ordering stableNameCmp n1 n2 = - (GHC.occName n1 `compare` GHC.occName n2) <> + (GHC.occName n1 `compare` GHC.occName n2) + <> -- See Note [Stable name comparisons] maybeCmp stableModuleCmp (GHC.nameModule_maybe n1) (GHC.nameModule_maybe n2) - where - maybeCmp :: (a -> a -> Ordering) -> Maybe a -> Maybe a -> Ordering - maybeCmp cmp (Just l) (Just r) = l `cmp` r - maybeCmp _ Nothing (Just _) = LT - maybeCmp _ (Just _) Nothing = GT - maybeCmp _ Nothing Nothing = EQ + where + maybeCmp :: (a -> a -> Ordering) -> Maybe a -> Maybe a -> Ordering + maybeCmp cmp (Just l) (Just r) = l `cmp` r + maybeCmp _ Nothing (Just _) = LT + maybeCmp _ (Just _) Nothing = GT + maybeCmp _ Nothing Nothing = EQ -- | Our own version of 'GHC.stableModuleCmp'. stableModuleCmp :: GHC.Module -> GHC.Module -> Ordering stableModuleCmp m1 m2 = - (GHC.moduleName m1 `GHC.stableModuleNameCmp` GHC.moduleName m2) <> + (GHC.moduleName m1 `GHC.stableModuleNameCmp` GHC.moduleName m2) + <> -- See Note [Stable name comparisons] (GHC.moduleUnit m1 `GHC.stableUnitCmp` GHC.moduleUnit m2) -- See Note [Scopes] type Compiling uni fun m ann = - ( MonadError (CompileError uni fun ann) m - , MonadQuote m - , MonadReader (CompileContext uni fun) m - , MonadState CompileState m - , MonadDefs LexName uni fun Ann m - , MonadWriter CoverageIndex m - ) + ( MonadError (CompileError uni fun ann) m + , MonadQuote m + , MonadReader (CompileContext uni fun) m + , MonadState CompileState m + , MonadDefs LexName uni fun Ann m + , MonadWriter CoverageIndex m + ) -- Packing up equality constraints gives us a nice way of writing type signatures as this way -- we don't need to write 'PLC.DefaultUni' everywhere (in 'PIRTerm', 'PIRType' etc) and instead -- can write the short @uni@ and know that it actually means 'PLC.DefaultUni'. Same regarding -- 'DefaultFun'. type CompilingDefault uni fun m ann = - ( uni ~ PLC.DefaultUni - , fun ~ PLC.DefaultFun - , Compiling uni fun m ann - ) + ( uni ~ PLC.DefaultUni + , fun ~ PLC.DefaultFun + , Compiling uni fun m ann + ) -blackhole :: MonadReader (CompileContext uni fun) m => GHC.Name -> m a -> m a -blackhole name = local (\cc -> cc {ccBlackholed=Set.insert name (ccBlackholed cc)}) +blackhole :: (MonadReader (CompileContext uni fun) m) => GHC.Name -> m a -> m a +blackhole name = local (\cc -> cc{ccBlackholed = Set.insert name (ccBlackholed cc)}) -blackholed :: MonadReader (CompileContext uni fun) m => GHC.Name -> m Bool +blackholed :: (MonadReader (CompileContext uni fun) m) => GHC.Name -> m Bool blackholed name = do - CompileContext {ccBlackholed=bh} <- ask - pure $ Set.member name bh + CompileContext{ccBlackholed = bh} <- ask + pure $ Set.member name bh {- Note [Scopes] We need a notion of scope, because we have to make sure that if we convert a GHC @@ -228,20 +240,20 @@ appropriately. We keep the scope in a `Reader` monad, so any modifications are only local. -} -data Scope uni fun = - Scope - (Map.Map GHC.Name (PLCVar uni, Maybe (PIRTerm uni fun))) - (Map.Map GHC.Name PLCTyVar) +data Scope uni fun + = Scope + (Map.Map GHC.Name (PLCVar uni, Maybe (PIRTerm uni fun))) + (Map.Map GHC.Name PLCTyVar) initialScope :: Scope uni fun initialScope = Scope Map.empty Map.empty -withCurDef :: Compiling uni fun m ann => LexName -> m a -> m a -withCurDef name = local (\cc -> cc {ccCurDef=Just name}) +withCurDef :: (Compiling uni fun m ann) => LexName -> m a -> m a +withCurDef name = local (\cc -> cc{ccCurDef = Just name}) -modifyCurDeps :: Compiling uni fun m ann => (Set.Set LexName -> Set.Set LexName) -> m () +modifyCurDeps :: (Compiling uni fun m ann) => (Set.Set LexName -> Set.Set LexName) -> m () modifyCurDeps f = do - cur <- asks ccCurDef - case cur of - Nothing -> pure () - Just n -> modifyDeps n f + cur <- asks ccCurDef + case cur of + Nothing -> pure () + Just n -> modifyDeps n f diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Utils.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Utils.hs index 63129385d83..90f8b691d22 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Utils.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Utils.hs @@ -22,75 +22,78 @@ import Language.Haskell.TH.Syntax qualified as TH import Data.Map qualified as Map import Data.Text qualified as T --- | Get the 'GHC.TyCon' for a given 'TH.Name' stored in the builtin name info, --- failing if it is missing. -lookupGhcTyCon :: Compiling uni fun m ann => TH.Name -> m GHC.TyCon +{-| Get the 'GHC.TyCon' for a given 'TH.Name' stored in the builtin name info, +failing if it is missing. +-} +lookupGhcTyCon :: (Compiling uni fun m ann) => TH.Name -> m GHC.TyCon lookupGhcTyCon thName = do - CompileContext { ccNameInfo } <- ask + CompileContext{ccNameInfo} <- ask case Map.lookup thName ccNameInfo of Just (GHC.ATyCon tc) -> pure tc _ -> throwPlain $ CompilationError $ "TyCon not found: " <> T.pack (show thName) --- | Get the 'GHC.Name' for a given 'TH.Name' stored in the builtin name info, --- failing if it is missing. -lookupGhcName :: Compiling uni fun m ann => TH.Name -> m GHC.Name +{-| Get the 'GHC.Name' for a given 'TH.Name' stored in the builtin name info, +failing if it is missing. +-} +lookupGhcName :: (Compiling uni fun m ann) => TH.Name -> m GHC.Name lookupGhcName thName = do - CompileContext { ccNameInfo } <- ask + CompileContext{ccNameInfo} <- ask case Map.lookup thName ccNameInfo of Just thing -> pure (GHC.getName thing) Nothing -> throwPlain $ CompilationError $ "Name not found: " <> T.pack (show thName) --- | Get the 'GHC.Id' for a given 'TH.Name' stored in the builtin name info, --- failing if it is missing. -lookupGhcId :: Compiling uni fun m ann => TH.Name -> m GHC.Id +{-| Get the 'GHC.Id' for a given 'TH.Name' stored in the builtin name info, +failing if it is missing. +-} +lookupGhcId :: (Compiling uni fun m ann) => TH.Name -> m GHC.Id lookupGhcId thName = do - CompileContext { ccNameInfo } <- ask + CompileContext{ccNameInfo} <- ask case Map.lookup thName ccNameInfo of Just (GHC.AnId ghcId) -> pure ghcId _ -> throwPlain $ CompilationError $ "Id not found: " <> T.pack (show thName) -sdToStr :: MonadReader (CompileContext uni fun) m => GHC.SDoc -> m String +sdToStr :: (MonadReader (CompileContext uni fun) m) => GHC.SDoc -> m String sdToStr sd = do - CompileContext { ccFlags=flags } <- ask + CompileContext{ccFlags = flags} <- ask pure $ GHC.showSDocForUser flags GHC.emptyUnitState GHC.alwaysQualify sd -sdToTxt :: MonadReader (CompileContext uni fun) m => GHC.SDoc -> m T.Text +sdToTxt :: (MonadReader (CompileContext uni fun) m) => GHC.SDoc -> m T.Text sdToTxt = fmap T.pack . sdToStr -throwSd :: - (MonadError (CompileError uni fun ann) m, MonadReader (CompileContext uni fun) m) => - (T.Text -> Error uni fun ann) -> - GHC.SDoc -> - m a +throwSd + :: (MonadError (CompileError uni fun ann) m, MonadReader (CompileContext uni fun) m) + => (T.Text -> Error uni fun ann) + -> GHC.SDoc + -> m a throwSd constr = (throwPlain . constr) <=< sdToTxt tyConsOfExpr :: GHC.CoreExpr -> GHC.UniqSet GHC.TyCon tyConsOfExpr = \case - GHC.Type ty -> GHC.tyConsOfType ty - GHC.Coercion co -> GHC.tyConsOfType $ GHC.mkCoercionTy co - GHC.Var v -> GHC.tyConsOfType (GHC.varType v) - GHC.Lit _ -> mempty - -- ignore anything in the ann - GHC.Tick _ e -> tyConsOfExpr e - GHC.App e1 e2 -> tyConsOfExpr e1 <> tyConsOfExpr e2 - GHC.Lam bndr e -> tyConsOfBndr bndr <> tyConsOfExpr e - GHC.Cast e co -> tyConsOfExpr e <> GHC.tyConsOfType (GHC.mkCoercionTy co) - GHC.Case scrut bndr ty alts -> - tyConsOfExpr scrut <> - tyConsOfBndr bndr <> - GHC.tyConsOfType ty <> - foldMap tyConsOfAlt alts - GHC.Let bind body -> tyConsOfBind bind <> tyConsOfExpr body + GHC.Type ty -> GHC.tyConsOfType ty + GHC.Coercion co -> GHC.tyConsOfType $ GHC.mkCoercionTy co + GHC.Var v -> GHC.tyConsOfType (GHC.varType v) + GHC.Lit _ -> mempty + -- ignore anything in the ann + GHC.Tick _ e -> tyConsOfExpr e + GHC.App e1 e2 -> tyConsOfExpr e1 <> tyConsOfExpr e2 + GHC.Lam bndr e -> tyConsOfBndr bndr <> tyConsOfExpr e + GHC.Cast e co -> tyConsOfExpr e <> GHC.tyConsOfType (GHC.mkCoercionTy co) + GHC.Case scrut bndr ty alts -> + tyConsOfExpr scrut + <> tyConsOfBndr bndr + <> GHC.tyConsOfType ty + <> foldMap tyConsOfAlt alts + GHC.Let bind body -> tyConsOfBind bind <> tyConsOfExpr body tyConsOfBndr :: GHC.CoreBndr -> GHC.UniqSet GHC.TyCon tyConsOfBndr = GHC.tyConsOfType . GHC.varType tyConsOfBind :: GHC.Bind GHC.CoreBndr -> GHC.UniqSet GHC.TyCon tyConsOfBind = \case - GHC.NonRec bndr rhs -> binderTyCons bndr rhs - GHC.Rec bndrs -> foldMap (uncurry binderTyCons) bndrs - where - binderTyCons bndr rhs = tyConsOfBndr bndr <> tyConsOfExpr rhs + GHC.NonRec bndr rhs -> binderTyCons bndr rhs + GHC.Rec bndrs -> foldMap (uncurry binderTyCons) bndrs + where + binderTyCons bndr rhs = tyConsOfBndr bndr <> tyConsOfExpr rhs tyConsOfAlt :: GHC.CoreAlt -> GHC.UniqSet GHC.TyCon tyConsOfAlt (GHC.Alt _ vars e) = foldMap tyConsOfBndr vars <> tyConsOfExpr e diff --git a/plutus-tx-plugin/src/PlutusTx/Options.hs b/plutus-tx-plugin/src/PlutusTx/Options.hs index 14461b73c9a..dfa9d775fa4 100644 --- a/plutus-tx-plugin/src/PlutusTx/Options.hs +++ b/plutus-tx-plugin/src/PlutusTx/Options.hs @@ -39,7 +39,6 @@ import Text.Megaparsec.Char (alphaNumChar, char, upperChar) import Text.Read (readMaybe) import Type.Reflection - data PluginOptions = PluginOptions { _posPlcTargetVersion :: PLC.Version , _posDoTypecheck :: Bool @@ -88,7 +87,8 @@ type OptionValue = Text data Implication a = forall b. Implication (a -> Bool) (Lens' PluginOptions b) b -- | A plugin option definition for a `PluginOptions` field of type @a@. -data PluginOption = forall a. +data PluginOption + = forall a. (Pretty a) => PluginOption { poTypeRep :: TypeRep a @@ -96,13 +96,15 @@ data PluginOption = forall a. , poFun :: Maybe OptionValue -> Validation ParseError (a -> a) -- ^ Consumes an optional value, and either updates the field or reports an error. , poLens :: Lens' PluginOptions a - -- ^ Lens focusing on the field. This is for modifying the field, as well as - -- getting the field value from `defaultPluginOptions` for pretty printing. + {- ^ Lens focusing on the field. This is for modifying the field, as well as + getting the field value from `defaultPluginOptions` for pretty printing. + -} , poDescription :: Text -- ^ A description of the option. , poImplications :: [Implication a] - -- ^ Implications of this option being set to a particular value. - -- An option should not imply itself. + {- ^ Implications of this option being set to a particular value. + An option should not imply itself. + -} } data ParseError @@ -156,15 +158,15 @@ pluginOptions = , let k = "defer-errors" desc = "If a compilation error happens and this option is turned on, " - <> "the compilation error is suppressed and the original Haskell " - <> "expression is replaced with a runtime-error expression." + <> "the compilation error is suppressed and the original Haskell " + <> "expression is replaced with a runtime-error expression." in (k, PluginOption typeRep (setTrue k) posDeferErrors desc []) , let k = "conservative-optimisation" desc = "When conservative optimisation is used, only the optimisations that " - <> "never make the program worse (in terms of cost or size) are employed. " - <> "Implies `no-relaxed-float-in`, `no-inline-constants`, `no-inline-fix`, " - <> "`no-simplifier-evaluate-builtins`, and `preserve-logging`." + <> "never make the program worse (in terms of cost or size) are employed. " + <> "Implies `no-relaxed-float-in`, `no-inline-constants`, `no-inline-fix`, " + <> "`no-simplifier-evaluate-builtins`, and `preserve-logging`." in ( k , PluginOption typeRep @@ -202,20 +204,20 @@ pluginOptions = , let k = "inline-callsite-growth" desc = "Sets the inlining threshold for callsites. 0 disables inlining a binding at a " - <> "callsite if it increases the AST size; `n` allows inlining if the AST size grows by " - <> "no more than `n`. Keep in mind that doing so does not mean the final program " - <> "will be bigger, since inlining can often unlock further optimizations." + <> "callsite if it increases the AST size; `n` allows inlining if the AST size grows by " + <> "no more than `n`. Keep in mind that doing so does not mean the final program " + <> "will be bigger, since inlining can often unlock further optimizations." in (k, PluginOption typeRep (readOption k) posInlineCallsiteGrowth desc []) , let k = "inline-constants" desc = "Always inline constants. Inlining constants always reduces script " - <> "costs slightly, but may increase script sizes if a large constant " - <> "is used more than once. Implied by `no-conservative-optimisation`." + <> "costs slightly, but may increase script sizes if a large constant " + <> "is used more than once. Implied by `no-conservative-optimisation`." in (k, PluginOption typeRep (setTrue k) posInlineConstants desc []) , let k = "inline-fix" desc = "Always inline fixed point combinators. This is generally preferable as " - <> "it often enables further optimization, though it may increase script size." + <> "it often enables further optimization, though it may increase script size." in (k, PluginOption typeRep (setTrue k) posInlineFix desc []) , let k = "optimize" desc = "Run optimization passes such as simplification and floating let-bindings." @@ -255,7 +257,7 @@ pluginOptions = , let k = "simplifier-evaluate-builtins" desc = "Run a simplification pass that evaluates fully saturated builtin applications. " - <> "Implied by `no-conservative-optimisation`." + <> "Implied by `no-conservative-optimisation`." in (k, PluginOption typeRep (setTrue k) posDoSimplifierEvaluateBuiltins desc []) , let k = "simplifier-inline" desc = "Run a simplification pass that performs inlining" @@ -281,13 +283,13 @@ pluginOptions = , let k = "relaxed-float-in" desc = "Use a more aggressive float-in pass, which often leads to reduced costs " - <> "but may occasionally lead to slightly increased costs. Implied by " - <> "`no-conservative-optimisation`." + <> "but may occasionally lead to slightly increased costs. Implied by " + <> "`no-conservative-optimisation`." in (k, PluginOption typeRep (setTrue k) posRelaxedFloatin desc []) , let k = "preserve-logging" desc = "Turn off optimisations that may alter (i.e., add, remove or change the " - <> "order of) trace messages. Implied by `conservative-optimisation`." + <> "order of) trace messages. Implied by `conservative-optimisation`." in (k, PluginOption typeRep (setTrue k) posPreserveLogging desc []) , let k = "remove-trace" desc = "Eliminate calls to `trace` from Plutus Core" @@ -298,10 +300,10 @@ pluginOptions = , let k = "certify" desc = "Produce a certificate for the compiled program, with the given name. " - <> "This certificate provides evidence that the compiler optimizations have " - <> "preserved the functional behavior of the original program. " - <> "Currently, this is only supported for the UPLC compilation pipeline. " - <> "Warning: this is an experimental feature and may not work as expected." + <> "This certificate provides evidence that the compiler optimizations have " + <> "preserved the functional behavior of the original program. " + <> "Currently, this is only supported for the UPLC compilation pipeline. " + <> "Warning: this is an experimental feature and may not work as expected." p = optional $ do firstC <- upperChar rest <- many (alphaNumChar <|> char '_' <|> char '\\') @@ -331,12 +333,12 @@ readOption k = \case Nothing -> Failure $ MissingValue k -- | Obtain an option value of type @a@ from an `Int`. -fromReadOption :: - (Read a) => - OptionKey -> - (a -> Validation ParseError b) -> - Maybe OptionValue -> - Validation ParseError (b -> b) +fromReadOption + :: (Read a) + => OptionKey + -> (a -> Validation ParseError b) + -> Maybe OptionValue + -> Validation ParseError (b -> b) fromReadOption k f = \case Just v | Just i <- readMaybe (Text.unpack v) -> const <$> f i @@ -381,10 +383,10 @@ defaultPluginOptions = , _posCertify = Nothing } -processOne :: - OptionKey -> - Maybe OptionValue -> - Validation ParseError (PluginOptions -> PluginOptions) +processOne + :: OptionKey + -> Maybe OptionValue + -> Validation ParseError (PluginOptions -> PluginOptions) processOne key val | Just (PluginOption _ f field _ impls) <- Map.lookup key pluginOptions = fmap (applyImplications field impls) . over field <$> f val @@ -408,9 +410,9 @@ applyImplications field = ) id -processAll :: - [(OptionKey, Maybe OptionValue)] -> - Validation ParseErrors [PluginOptions -> PluginOptions] +processAll + :: [(OptionKey, Maybe OptionValue)] + -> Validation ParseErrors [PluginOptions -> PluginOptions] processAll = traverse $ first (ParseErrors . pure) . uncurry processOne toKeyValue :: GHC.CommandLineOption -> (OptionKey, Maybe OptionValue) @@ -420,7 +422,7 @@ toKeyValue opt = case List.elemIndex '=' opt of let (lhs, rhs) = splitAt idx opt in (Text.pack lhs, Just (Text.pack (drop 1 rhs))) -{- | Parses the arguments that were given to ghc at commandline as +{-| Parses the arguments that were given to ghc at commandline as "-fplugin-opt PlutusTx.Plugin:opt" or "-fplugin-opt PlutusTx.Plugin:opt=val" -} parsePluginOptions :: [GHC.CommandLineOption] -> Validation ParseErrors PluginOptions diff --git a/plutus-tx-plugin/src/PlutusTx/Plugin.hs b/plutus-tx-plugin/src/PlutusTx/Plugin.hs index aef78bef7b3..f6fb1e92351 100644 --- a/plutus-tx-plugin/src/PlutusTx/Plugin.hs +++ b/plutus-tx-plugin/src/PlutusTx/Plugin.hs @@ -6,9 +6,9 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ViewPatterns #-} - -- For some reason this module is very slow to compile otherwise {-# OPTIONS_GHC -O0 #-} + module PlutusTx.Plugin (plugin, plc) where import Data.Bifunctor @@ -86,12 +86,12 @@ import System.IO.Unsafe (unsafePerformIO) import Certifier data PluginCtx = PluginCtx - { pcOpts :: PluginOptions - , pcFamEnvs :: GHC.FamInstEnvs - , pcMarkerName :: GHC.Name - , pcModuleName :: GHC.ModuleName - , pcModuleModBreaks :: Maybe GHC.ModBreaks - } + { pcOpts :: PluginOptions + , pcFamEnvs :: GHC.FamInstEnvs + , pcMarkerName :: GHC.Name + , pcModuleName :: GHC.ModuleName + , pcModuleModBreaks :: Maybe GHC.ModBreaks + } {- Note [Making sure unfoldings are present] Our plugin runs at the start of the Core pipeline. If we look around us, we will find @@ -121,23 +121,26 @@ PIRs, PLCs and UPLCs, causing test failures. Replacing them with `coerce` avoids -} plugin :: GHC.Plugin -plugin = GHC.defaultPlugin { GHC.pluginRecompile = GHC.flagRecompile - , GHC.installCoreToDos = install - } - where - install :: [GHC.CommandLineOption] -> [GHC.CoreToDo] -> GHC.CoreM [GHC.CoreToDo] - install args rest = do - -- create simplifier pass to be placed at the front - simplPass <- mkSimplPass <$> GHC.getDynFlags - -- instantiate our plugin pass - pluginPass <- mkPluginPass <$> case parsePluginOptions args of - Success opts -> pure opts - Failure errs -> liftIO $ throwIO errs - -- return the pipeline - pure $ - simplPass - : pluginPass - : rest +plugin = + GHC.defaultPlugin + { GHC.pluginRecompile = GHC.flagRecompile + , GHC.installCoreToDos = install + } + where + install :: [GHC.CommandLineOption] -> [GHC.CoreToDo] -> GHC.CoreM [GHC.CoreToDo] + install args rest = do + -- create simplifier pass to be placed at the front + simplPass <- mkSimplPass <$> GHC.getDynFlags + -- instantiate our plugin pass + pluginPass <- + mkPluginPass <$> case parsePluginOptions args of + Success opts -> pure opts + Failure errs -> liftIO $ throwIO errs + -- return the pipeline + pure $ + simplPass + : pluginPass + : rest {- Note [GHC.sm_pre_inline] We run a GHC simplifier pass before the plugin, in which we turn on `sm_pre_inline`, which @@ -184,35 +187,37 @@ See https://gitlab.haskell.org/ghc/ghc/-/issues/23337. mkSimplPass :: GHC.DynFlags -> GHC.CoreToDo mkSimplPass dflags = -- See Note [Making sure unfoldings are present] - GHC.CoreDoSimplify $ GHC.SimplifyOpts - { GHC.so_dump_core_sizes = False - , GHC.so_iterations = 1 - , GHC.so_mode = simplMode - , GHC.so_pass_result_cfg = Nothing - , GHC.so_hpt_rules = GHC.emptyRuleBase - , GHC.so_top_env_cfg = GHC.TopEnvConfig 0 0 - } - where - simplMode = GHC.SimplMode - { GHC.sm_names = ["Ensure unfoldings are present"] - , GHC.sm_phase = GHC.InitialPhase - , GHC.sm_uf_opts = GHC.defaultUnfoldingOpts - , GHC.sm_rules = False - , GHC.sm_cast_swizzle = True - -- See Note [GHC.sm_pre_inline] - , GHC.sm_pre_inline = True - -- You might think you would need this, but apparently not - , GHC.sm_inline = False - , GHC.sm_case_case = False - , GHC.sm_eta_expand = False - , GHC.sm_float_enable = GHC.FloatDisabled - , GHC.sm_do_eta_reduction = False - , GHC.sm_arity_opts = GHC.ArityOpts False False - , GHC.sm_rule_opts = GHC.RuleOpts (GHC.targetPlatform dflags) False True False - , GHC.sm_case_folding = False - , GHC.sm_case_merge = False - , GHC.sm_co_opt_opts = GHC.OptCoercionOpts False - } + GHC.CoreDoSimplify $ + GHC.SimplifyOpts + { GHC.so_dump_core_sizes = False + , GHC.so_iterations = 1 + , GHC.so_mode = simplMode + , GHC.so_pass_result_cfg = Nothing + , GHC.so_hpt_rules = GHC.emptyRuleBase + , GHC.so_top_env_cfg = GHC.TopEnvConfig 0 0 + } + where + simplMode = + GHC.SimplMode + { GHC.sm_names = ["Ensure unfoldings are present"] + , GHC.sm_phase = GHC.InitialPhase + , GHC.sm_uf_opts = GHC.defaultUnfoldingOpts + , GHC.sm_rules = False + , GHC.sm_cast_swizzle = True + , -- See Note [GHC.sm_pre_inline] + GHC.sm_pre_inline = True + , -- You might think you would need this, but apparently not + GHC.sm_inline = False + , GHC.sm_case_case = False + , GHC.sm_eta_expand = False + , GHC.sm_float_enable = GHC.FloatDisabled + , GHC.sm_do_eta_reduction = False + , GHC.sm_arity_opts = GHC.ArityOpts False False + , GHC.sm_rule_opts = GHC.RuleOpts (GHC.targetPlatform dflags) False True False + , GHC.sm_case_folding = False + , GHC.sm_case_merge = False + , GHC.sm_co_opt_opts = GHC.OptCoercionOpts False + } {- Note [Marker resolution] We use TH's 'foo exact syntax for resolving the 'plc marker's ghc name, as explained in: @@ -233,53 +238,59 @@ This dynamic approach comes with its own downsides however, because the user may have imported "plc" qualified or aliased it, which will fail to resolve. -} - --- | Our plugin works at haskell-module level granularity; the plugin --- looks at the module's top-level bindings for plc markers and compiles their right-hand-side core --- expressions. +{-| Our plugin works at haskell-module level granularity; the plugin +looks at the module's top-level bindings for plc markers and compiles their right-hand-side core +expressions. +-} mkPluginPass :: PluginOptions -> GHC.CoreToDo -mkPluginPass opts = GHC.CoreDoPluginPass "Core to PLC" $ \ guts -> do - -- Family env code borrowed from SimplCore - p_fam_env <- GHC.getPackageFamInstEnv +mkPluginPass opts = GHC.CoreDoPluginPass "Core to PLC" $ \guts -> do + -- Family env code borrowed from SimplCore + p_fam_env <- GHC.getPackageFamInstEnv + -- See Note [Marker resolution] + maybeMarkerName <- GHC.thNameToGhcName 'plc + case maybeMarkerName of + -- TODO: test that this branch can happen using TH's 'plc exact syntax. -- See Note [Marker resolution] - maybeMarkerName <- GHC.thNameToGhcName 'plc - case maybeMarkerName of - -- TODO: test that this branch can happen using TH's 'plc exact syntax. - -- See Note [Marker resolution] - Nothing -> pure guts - Just markerName -> - let pctx = PluginCtx { pcOpts = opts - , pcFamEnvs = (p_fam_env, GHC.mg_fam_inst_env guts) - , pcMarkerName = markerName - , pcModuleName = GHC.moduleName $ GHC.mg_module guts - , pcModuleModBreaks = GHC.mg_modBreaks guts - } - -- start looking for plc calls from the top-level binds - in GHC.bindsOnlyPass (runPluginM pctx . traverse compileBind) guts - --- | The monad where the plugin runs in for each module. --- It is a core->core compiler monad, called PluginM, augmented with pure errors. + Nothing -> pure guts + Just markerName -> + let pctx = + PluginCtx + { pcOpts = opts + , pcFamEnvs = (p_fam_env, GHC.mg_fam_inst_env guts) + , pcMarkerName = markerName + , pcModuleName = GHC.moduleName $ GHC.mg_module guts + , pcModuleModBreaks = GHC.mg_modBreaks guts + } + in -- start looking for plc calls from the top-level binds + GHC.bindsOnlyPass (runPluginM pctx . traverse compileBind) guts + +{-| The monad where the plugin runs in for each module. +It is a core->core compiler monad, called PluginM, augmented with pure errors. +-} type PluginM uni fun = ReaderT PluginCtx (ExceptT (CompileError uni fun Ann) GHC.CoreM) -- | Runs the plugin monad in a given context; throws a Ghc.Exception when compilation fails. runPluginM - :: (PLC.PrettyUni uni, PP.Pretty fun) - => PluginCtx -> PluginM uni fun a -> GHC.CoreM a + :: (PLC.PrettyUni uni, PP.Pretty fun) + => PluginCtx -> PluginM uni fun a -> GHC.CoreM a runPluginM pctx act = do - res <- runExceptT $ runReaderT act pctx - case res of - Right x -> pure x - Left err -> - let errInGhc = GHC.ProgramError . show $ "GHC Core to PLC plugin:" PP.<+> PP.pretty err - in liftIO $ GHC.throwGhcExceptionIO errInGhc + res <- runExceptT $ runReaderT act pctx + case res of + Right x -> pure x + Left err -> + let errInGhc = GHC.ProgramError . show $ "GHC Core to PLC plugin:" PP.<+> PP.pretty err + in liftIO $ GHC.throwGhcExceptionIO errInGhc -- | Compiles all the marked expressions in the given binder into PLC literals. compileBind :: GHC.CoreBind -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreBind compileBind = \case - GHC.NonRec b rhs -> GHC.NonRec b <$> compileMarkedExprs rhs - GHC.Rec bindsRhses -> GHC.Rec <$> (for bindsRhses $ \(b, rhs) -> do - rhs' <- compileMarkedExprs rhs - pure (b, rhs')) + GHC.NonRec b rhs -> GHC.NonRec b <$> compileMarkedExprs rhs + GHC.Rec bindsRhses -> + GHC.Rec + <$> ( for bindsRhses $ \(b, rhs) -> do + rhs' <- compileMarkedExprs rhs + pure (b, rhs') + ) {- Note [Hooking in the plugin] Working out what to process and where to put it is tricky. We are going to turn the result in @@ -303,358 +314,400 @@ resulting 'CompiledCode' because that's impredicative polymorphism. -- | Compiles all the core-expressions surrounded by plc in the given expression into PLC literals. compileMarkedExprs :: GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr compileMarkedExprs expr = do - markerName <- asks pcMarkerName - case expr of - GHC.App (GHC.App (GHC.App (GHC.App - -- function id - -- sometimes GHCi sticks ticks around this for some reason - (stripTicks -> (GHC.Var fid)) - -- first type argument, must be a string literal type - (GHC.Type (GHC.isStrLitTy -> Just fs_locStr))) - -- second type argument - (GHC.Type codeTy)) - _) - -- value argument - inner - | markerName == GHC.idName fid -> compileMarkedExprOrDefer (show fs_locStr) codeTy inner - e@(GHC.Var fid) | markerName == GHC.idName fid -> - throwError . NoContext . InvalidMarkerError . GHC.showSDocUnsafe $ GHC.ppr e - GHC.App e a -> GHC.App <$> compileMarkedExprs e <*> compileMarkedExprs a - GHC.Lam b e -> GHC.Lam b <$> compileMarkedExprs e - GHC.Let bnd e -> GHC.Let <$> compileBind bnd <*> compileMarkedExprs e - GHC.Case e b t alts -> do - e' <- compileMarkedExprs e - let expAlt (GHC.Alt a bs rhs) = GHC.Alt a bs <$> compileMarkedExprs rhs - alts' <- mapM expAlt alts - pure $ GHC.Case e' b t alts' - GHC.Cast e c -> flip GHC.Cast c <$> compileMarkedExprs e - GHC.Tick t e -> GHC.Tick t <$> compileMarkedExprs e - e@(GHC.Coercion _) -> pure e - e@(GHC.Lit _) -> pure e - e@(GHC.Var _) -> pure e - e@(GHC.Type _) -> pure e - --- | Behaves the same as 'compileMarkedExpr', unless a compilation error occurs ; --- if a compilation error happens and the 'defer-errors' option is turned on, --- the compilation error is suppressed and the original hs expression is replaced with a --- haskell runtime-error expression. -compileMarkedExprOrDefer :: - String -> GHC.Type -> GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr + markerName <- asks pcMarkerName + case expr of + GHC.App + ( GHC.App + ( GHC.App + ( GHC.App + -- function id + -- sometimes GHCi sticks ticks around this for some reason + (stripTicks -> (GHC.Var fid)) + -- first type argument, must be a string literal type + (GHC.Type (GHC.isStrLitTy -> Just fs_locStr)) + ) + -- second type argument + (GHC.Type codeTy) + ) + _ + ) + -- value argument + inner + | markerName == GHC.idName fid -> compileMarkedExprOrDefer (show fs_locStr) codeTy inner + e@(GHC.Var fid) + | markerName == GHC.idName fid -> + throwError . NoContext . InvalidMarkerError . GHC.showSDocUnsafe $ GHC.ppr e + GHC.App e a -> GHC.App <$> compileMarkedExprs e <*> compileMarkedExprs a + GHC.Lam b e -> GHC.Lam b <$> compileMarkedExprs e + GHC.Let bnd e -> GHC.Let <$> compileBind bnd <*> compileMarkedExprs e + GHC.Case e b t alts -> do + e' <- compileMarkedExprs e + let expAlt (GHC.Alt a bs rhs) = GHC.Alt a bs <$> compileMarkedExprs rhs + alts' <- mapM expAlt alts + pure $ GHC.Case e' b t alts' + GHC.Cast e c -> flip GHC.Cast c <$> compileMarkedExprs e + GHC.Tick t e -> GHC.Tick t <$> compileMarkedExprs e + e@(GHC.Coercion _) -> pure e + e@(GHC.Lit _) -> pure e + e@(GHC.Var _) -> pure e + e@(GHC.Type _) -> pure e + +{-| Behaves the same as 'compileMarkedExpr', unless a compilation error occurs ; +if a compilation error happens and the 'defer-errors' option is turned on, +the compilation error is suppressed and the original hs expression is replaced with a +haskell runtime-error expression. +-} +compileMarkedExprOrDefer + :: String -> GHC.Type -> GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr compileMarkedExprOrDefer locStr codeTy origE = do - opts <- asks pcOpts - let compileAct = compileMarkedExpr locStr codeTy origE - if _posDeferErrors opts - -- TODO: we could perhaps move this catchError to the "runExceptT" module-level, but - -- it leads to uglier code and difficulty of handling other pure errors - then compileAct `catchError` emitRuntimeError codeTy - else compileAct - --- | Given an expected Haskell type 'a', it generates Haskell code which throws a GHC runtime error --- \"as\" 'CompiledCode a'. + opts <- asks pcOpts + let compileAct = compileMarkedExpr locStr codeTy origE + if _posDeferErrors opts + -- TODO: we could perhaps move this catchError to the "runExceptT" module-level, but + -- it leads to uglier code and difficulty of handling other pure errors + then compileAct `catchError` emitRuntimeError codeTy + else compileAct + +{-| Given an expected Haskell type 'a', it generates Haskell code which throws a GHC runtime error +\"as\" 'CompiledCode a'. +-} emitRuntimeError - :: (PLC.PrettyUni uni, PP.Pretty fun) - => GHC.Type -> CompileError uni fun Ann -> PluginM uni fun GHC.CoreExpr + :: (PLC.PrettyUni uni, PP.Pretty fun) + => GHC.Type -> CompileError uni fun Ann -> PluginM uni fun GHC.CoreExpr emitRuntimeError codeTy e = do - opts <- asks pcOpts - let shown = show $ PP.pretty (pruneContext (_posContextLevel opts) e) - tcName <- thNameToGhcNameOrFail ''CompiledCode - tc <- lift . lift $ GHC.lookupTyCon tcName - pure $ GHC.mkImpossibleExpr (GHC.mkTyConApp tc [codeTy]) shown - --- | Compile the core expression that is surrounded by a 'plc' marker, --- and return a core expression which evaluates to the compiled plc AST as a serialized bytestring, --- to be injected back to the Haskell program. -compileMarkedExpr :: - String -> GHC.Type -> GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr + opts <- asks pcOpts + let shown = show $ PP.pretty (pruneContext (_posContextLevel opts) e) + tcName <- thNameToGhcNameOrFail ''CompiledCode + tc <- lift . lift $ GHC.lookupTyCon tcName + pure $ GHC.mkImpossibleExpr (GHC.mkTyConApp tc [codeTy]) shown + +{-| Compile the core expression that is surrounded by a 'plc' marker, +and return a core expression which evaluates to the compiled plc AST as a serialized bytestring, +to be injected back to the Haskell program. +-} +compileMarkedExpr + :: String -> GHC.Type -> GHC.CoreExpr -> PluginM PLC.DefaultUni PLC.DefaultFun GHC.CoreExpr compileMarkedExpr locStr codeTy origE = do - flags <- GHC.getDynFlags - famEnvs <- asks pcFamEnvs - opts <- asks pcOpts - moduleName <- asks pcModuleName - let moduleNameStr = - GHC.showSDocForUser flags GHC.emptyUnitState GHC.alwaysQualify (GHC.ppr moduleName) - -- We need to do this out here, since it has to run in CoreM - nameInfo <- makePrimitiveNameInfo $ - builtinNames ++ - [''Bool - , 'False - , 'True - , 'traceBool - , 'GHC.Num.Integer.integerNegate - , '(PlutusTx.Bool.&&) - , '(PlutusTx.Bool.||) - , 'PlutusTx.AsData.Internal.wrapTail - , 'PlutusTx.AsData.Internal.wrapUnsafeDataAsConstr - , 'PlutusTx.Function.fix - , 'PlutusTx.Optimize.Inline.inline - , 'useToOpaque - , 'useFromOpaque - , 'mkNilOpaque - ] - modBreaks <- asks pcModuleModBreaks - let coverage = CoverageOpts . Set.fromList $ - [ l | _posCoverageAll opts, l <- [minBound .. maxBound]] - ++ [ LocationCoverage | _posCoverageLocation opts ] - ++ [ BooleanCoverage | _posCoverageBoolean opts ] - let ctx = CompileContext { - ccOpts = CompileOptions { - coProfile=_posProfile opts - ,coCoverage=coverage - ,coRemoveTrace=_posRemoveTrace opts - ,coInlineFix=_posInlineFix opts}, - ccFlags = flags, - ccFamInstEnvs = famEnvs, - ccNameInfo = nameInfo, - ccScope = initialScope, - ccBlackholed = mempty, - ccCurDef = Nothing, - ccModBreaks = modBreaks, - ccBuiltinsInfo = def, - ccBuiltinCostModel = def, - ccDebugTraceOn = _posDumpCompilationTrace opts, - ccRewriteRules = makeRewriteRules opts, - ccSafeToInline = False - } - st = CompileState 0 mempty - -- See Note [Occurrence analysis] - let origE' = GHC.occurAnalyseExpr origE - - ((pirP,uplcP), covIdx) <- runWriterT . runQuoteT . flip runReaderT ctx . flip evalStateT st $ - traceCompilation 1 ("Compiling expr at" GHC.<+> GHC.text locStr) $ - runCompiler moduleNameStr opts origE' - - -- serialize the PIR, PLC, and coverageindex outputs into a bytestring. - bsPir <- makeByteStringLiteral $ flat pirP - bsPlc <- makeByteStringLiteral $ flat (UPLC.UnrestrictedProgram uplcP) - covIdxFlat <- makeByteStringLiteral $ flat covIdx - - builder <- lift . lift . GHC.lookupId =<< thNameToGhcNameOrFail 'mkCompiledCode - - -- inject the three bytestrings back as Haskell code. - pure $ - GHC.Var builder - `GHC.App` GHC.Type codeTy - `GHC.App` bsPlc - `GHC.App` bsPir - `GHC.App` covIdxFlat - --- | The GHC.Core to PIR to PLC compiler pipeline. Returns both the PIR and PLC output. --- It invokes the whole compiler chain: Core expr -> PIR expr -> PLC expr -> UPLC expr. -runCompiler :: - forall uni fun m. - ( uni ~ PLC.DefaultUni - , fun ~ PLC.DefaultFun - , MonadReader (CompileContext uni fun) m - , MonadState CompileState m - , MonadWriter CoverageIndex m - , MonadQuote m - , MonadError (CompileError uni fun Ann) m - , MonadIO m - ) => - String -> - PluginOptions -> - GHC.CoreExpr -> - m (PIRProgram uni fun, UPLCProgram uni fun) + flags <- GHC.getDynFlags + famEnvs <- asks pcFamEnvs + opts <- asks pcOpts + moduleName <- asks pcModuleName + let moduleNameStr = + GHC.showSDocForUser flags GHC.emptyUnitState GHC.alwaysQualify (GHC.ppr moduleName) + -- We need to do this out here, since it has to run in CoreM + nameInfo <- + makePrimitiveNameInfo $ + builtinNames + ++ [ ''Bool + , 'False + , 'True + , 'traceBool + , 'GHC.Num.Integer.integerNegate + , '(PlutusTx.Bool.&&) + , '(PlutusTx.Bool.||) + , 'PlutusTx.AsData.Internal.wrapTail + , 'PlutusTx.AsData.Internal.wrapUnsafeDataAsConstr + , 'PlutusTx.Function.fix + , 'PlutusTx.Optimize.Inline.inline + , 'useToOpaque + , 'useFromOpaque + , 'mkNilOpaque + ] + modBreaks <- asks pcModuleModBreaks + let coverage = + CoverageOpts . Set.fromList $ + [l | _posCoverageAll opts, l <- [minBound .. maxBound]] + ++ [LocationCoverage | _posCoverageLocation opts] + ++ [BooleanCoverage | _posCoverageBoolean opts] + let ctx = + CompileContext + { ccOpts = + CompileOptions + { coProfile = _posProfile opts + , coCoverage = coverage + , coRemoveTrace = _posRemoveTrace opts + , coInlineFix = _posInlineFix opts + } + , ccFlags = flags + , ccFamInstEnvs = famEnvs + , ccNameInfo = nameInfo + , ccScope = initialScope + , ccBlackholed = mempty + , ccCurDef = Nothing + , ccModBreaks = modBreaks + , ccBuiltinsInfo = def + , ccBuiltinCostModel = def + , ccDebugTraceOn = _posDumpCompilationTrace opts + , ccRewriteRules = makeRewriteRules opts + , ccSafeToInline = False + } + st = CompileState 0 mempty + -- See Note [Occurrence analysis] + let origE' = GHC.occurAnalyseExpr origE + + ((pirP, uplcP), covIdx) <- + runWriterT . runQuoteT . flip runReaderT ctx . flip evalStateT st $ + traceCompilation 1 ("Compiling expr at" GHC.<+> GHC.text locStr) $ + runCompiler moduleNameStr opts origE' + + -- serialize the PIR, PLC, and coverageindex outputs into a bytestring. + bsPir <- makeByteStringLiteral $ flat pirP + bsPlc <- makeByteStringLiteral $ flat (UPLC.UnrestrictedProgram uplcP) + covIdxFlat <- makeByteStringLiteral $ flat covIdx + + builder <- lift . lift . GHC.lookupId =<< thNameToGhcNameOrFail 'mkCompiledCode + + -- inject the three bytestrings back as Haskell code. + pure $ + GHC.Var builder + `GHC.App` GHC.Type codeTy + `GHC.App` bsPlc + `GHC.App` bsPir + `GHC.App` covIdxFlat + +{-| The GHC.Core to PIR to PLC compiler pipeline. Returns both the PIR and PLC output. +It invokes the whole compiler chain: Core expr -> PIR expr -> PLC expr -> UPLC expr. +-} +runCompiler + :: forall uni fun m + . ( uni ~ PLC.DefaultUni + , fun ~ PLC.DefaultFun + , MonadReader (CompileContext uni fun) m + , MonadState CompileState m + , MonadWriter CoverageIndex m + , MonadQuote m + , MonadError (CompileError uni fun Ann) m + , MonadIO m + ) + => String + -> PluginOptions + -> GHC.CoreExpr + -> m (PIRProgram uni fun, UPLCProgram uni fun) runCompiler moduleName opts expr = do - -- Plc configuration - plcTcConfig <- PLC.getDefTypeCheckConfig PIR.noProvenance - let plcVersion = opts ^. posPlcTargetVersion - - let hints = UPLC.InlineHints $ \ann _ -> case ann of - -- See Note [The problem of inlining destructors] - -- We want to inline destructors, but even in UPLC our inlining heuristics - -- aren't quite smart enough to tell that they're good inlining candidates, - -- so we just explicitly tell the inliner to inline them all. - -- - -- In fact, this instructs the inliner to inline *any* binding inside a destructor, - -- which is a slightly large hammer but is actually what we want since it will mean - -- that we also aggressively reduce the bindings inside the destructor. - PIR.DatatypeComponent PIR.Destructor _ -> AlwaysInline - _ | AlwaysInline `elem` fmap annInline (toList ann) -> AlwaysInline - | SafeToInline `elem` fmap annInline (toList ann) -> SafeToInline - | otherwise -> MayInline - - rewriteRules <- asks ccRewriteRules - - -- Compilation configuration - -- pir's tc-config is based on plc tcconfig - let pirTcConfig = PIR.PirTCConfig plcTcConfig PIR.YesEscape - pirCtx = PIR.toDefaultCompilationCtx plcTcConfig - & set (PIR.ccOpts . PIR.coOptimize) (opts ^. posOptimize) - & set (PIR.ccOpts . PIR.coTypecheck) (opts ^. posDoTypecheck) - & set (PIR.ccOpts . PIR.coPedantic) (opts ^. posPedantic) - & set (PIR.ccOpts . PIR.coVerbose) (opts ^. posVerbosity == Verbose) - & set (PIR.ccOpts . PIR.coDebug) (opts ^. posVerbosity == Debug) - & set (PIR.ccOpts . PIR.coMaxSimplifierIterations) - (opts ^. posMaxSimplifierIterationsPir) - & set PIR.ccTypeCheckConfig pirTcConfig - -- Simplifier options - & set (PIR.ccOpts . PIR.coDoSimplifierUnwrapCancel) - (opts ^. posDoSimplifierUnwrapCancel) - & set (PIR.ccOpts . PIR.coDoSimplifierBeta) - (opts ^. posDoSimplifierBeta) - & set (PIR.ccOpts . PIR.coDoSimplifierInline) - (opts ^. posDoSimplifierInline) - & set (PIR.ccOpts . PIR.coDoSimplifierEvaluateBuiltins) - (opts ^. posDoSimplifierEvaluateBuiltins) - & set (PIR.ccOpts . PIR.coDoSimplifierStrictifyBindings) - (opts ^. posDoSimplifierStrictifyBindings) - & set (PIR.ccOpts . PIR.coDoSimplifierRemoveDeadBindings) - (opts ^. posDoSimplifierRemoveDeadBindings) - & set (PIR.ccOpts . PIR.coInlineConstants) - (opts ^. posInlineConstants) - & set (PIR.ccOpts . PIR.coInlineFix) - (opts ^. posInlineFix) - & set (PIR.ccOpts . PIR.coInlineHints) hints - & set (PIR.ccOpts . PIR.coInlineCallsiteGrowth) - (opts ^. posInlineCallsiteGrowth . to fromIntegral) - & set (PIR.ccOpts . PIR.coRelaxedFloatin) (opts ^. posRelaxedFloatin) - & set (PIR.ccOpts . PIR.coCaseOfCaseConservative) - (opts ^. posCaseOfCaseConservative) - & set (PIR.ccOpts . PIR.coPreserveLogging) (opts ^. posPreserveLogging) - -- We could make this configurable with an option, but: - -- 1. The only other choice you can make is new version + Scott encoding, and - -- there's really no reason to pick that - -- 2. This is consistent with what we do in Lift - & set (PIR.ccOpts . PIR.coDatatypes . PIR.dcoStyle) - (if plcVersion < PLC.plcVersion110 - then PIR.ScottEncoding else PIR.SumsOfProducts) - -- TODO: ensure the same as the one used in the plugin - & set PIR.ccBuiltinsInfo def - & set PIR.ccBuiltinCostModel def - & set PIR.ccRewriteRules rewriteRules - plcOpts = PLC.defaultCompilationOpts - & set (PLC.coSimplifyOpts . UPLC.soMaxSimplifierIterations) - (opts ^. posMaxSimplifierIterationsUPlc) - & set (PLC.coSimplifyOpts . UPLC.soMaxCseIterations) - (opts ^. posMaxCseIterations) - & set (PLC.coSimplifyOpts . UPLC.soConservativeOpts) - (opts ^. posConservativeOpts) - & set (PLC.coSimplifyOpts . UPLC.soInlineHints) hints - & set (PLC.coSimplifyOpts . UPLC.soInlineConstants) - (opts ^. posInlineConstants) - & set (PLC.coSimplifyOpts . UPLC.soInlineCallsiteGrowth) - (opts ^. posInlineCallsiteGrowth . to fromIntegral) - & set (PLC.coSimplifyOpts . UPLC.soPreserveLogging) - (opts ^. posPreserveLogging) - - -- GHC.Core -> Pir translation. - pirT <- original <$> (PIR.runDefT annMayInline $ compileExprWithDefs expr) - let pirP = PIR.Program noProvenance plcVersion pirT - when (opts ^. posDumpPir) . liftIO $ - dumpFlat (void pirP) "initial PIR program" (moduleName ++ "_initial.pir-flat") - - -- Pir -> (Simplified) Pir pass. We can then dump/store a more legible PIR program. - spirP <- flip runReaderT pirCtx $ PIR.compileToReadable pirP - when (opts ^. posDumpPir) . liftIO $ - dumpFlat (void spirP) "simplified PIR program" (moduleName ++ "_simplified.pir-flat") - - -- (Simplified) Pir -> Plc translation. - plcP <- flip runReaderT pirCtx $ PIR.compileReadableToPlc spirP - when (opts ^. posDumpPlc) . liftIO $ - dumpFlat (void plcP) "typed PLC program" (moduleName ++ ".tplc-flat") - - -- We do this after dumping the programs so that if we fail typechecking we still get the dump. - when (opts ^. posDoTypecheck) . void $ - liftExcept $ PLC.inferTypeOfProgram plcTcConfig (plcP $> annMayInline) - - let optCertify = opts ^. posCertify - (uplcP, simplTrace) <- flip runReaderT plcOpts $ PLC.compileProgramWithTrace plcP - liftIO $ case optCertify of - Just certName -> do - result <- runCertifier $ mkCertifier simplTrace certName - case result of - Right certSuccess -> - hPutStrLn stderr $ prettyCertifierSuccess certSuccess - Left err -> - hPutStrLn stderr $ prettyCertifierError err - Nothing -> pure () - dbP <- liftExcept $ traverseOf UPLC.progTerm UPLC.deBruijnTerm uplcP - when (opts ^. posDumpUPlc) . liftIO $ - dumpFlat - (UPLC.UnrestrictedProgram $ void dbP) - "untyped PLC program" - (moduleName ++ ".uplc-flat") - -- Discard the Provenance information at this point, just keep the SrcSpans - -- TODO: keep it and do something useful with it - pure (fmap getSrcSpans spirP, fmap getSrcSpans dbP) - where - -- ugly trick to take out the concrete plc.error and in case of error, map it / rethrow it - -- using our 'CompileError' - liftExcept :: ExceptT (PLC.Error PLC.DefaultUni PLC.DefaultFun Ann) m b -> m b - liftExcept act = do - plcTcError <- runExceptT act - -- also wrap the PLC Error annotations into Original provenances, to match our expected - -- 'CompileError' - liftEither $ first (view (re PIR._PLCError) . fmap PIR.Original) plcTcError - - dumpFlat :: Flat t => t -> String -> String -> IO () - dumpFlat t desc fileName = do - (tPath, tHandle) <- openBinaryTempFile "." fileName - putStrLn $ "!!! dumping " ++ desc ++ " to " ++ show tPath - BS.hPut tHandle $ flat t - - getSrcSpans :: PIR.Provenance Ann -> SrcSpans - getSrcSpans = SrcSpans . Set.unions . fmap (unSrcSpans . annSrcSpans) . toList + -- Plc configuration + plcTcConfig <- PLC.getDefTypeCheckConfig PIR.noProvenance + let plcVersion = opts ^. posPlcTargetVersion + + let hints = UPLC.InlineHints $ \ann _ -> case ann of + -- See Note [The problem of inlining destructors] + -- We want to inline destructors, but even in UPLC our inlining heuristics + -- aren't quite smart enough to tell that they're good inlining candidates, + -- so we just explicitly tell the inliner to inline them all. + -- + -- In fact, this instructs the inliner to inline *any* binding inside a destructor, + -- which is a slightly large hammer but is actually what we want since it will mean + -- that we also aggressively reduce the bindings inside the destructor. + PIR.DatatypeComponent PIR.Destructor _ -> AlwaysInline + _ + | AlwaysInline `elem` fmap annInline (toList ann) -> AlwaysInline + | SafeToInline `elem` fmap annInline (toList ann) -> SafeToInline + | otherwise -> MayInline + + rewriteRules <- asks ccRewriteRules + + -- Compilation configuration + -- pir's tc-config is based on plc tcconfig + let pirTcConfig = PIR.PirTCConfig plcTcConfig PIR.YesEscape + pirCtx = + PIR.toDefaultCompilationCtx plcTcConfig + & set (PIR.ccOpts . PIR.coOptimize) (opts ^. posOptimize) + & set (PIR.ccOpts . PIR.coTypecheck) (opts ^. posDoTypecheck) + & set (PIR.ccOpts . PIR.coPedantic) (opts ^. posPedantic) + & set (PIR.ccOpts . PIR.coVerbose) (opts ^. posVerbosity == Verbose) + & set (PIR.ccOpts . PIR.coDebug) (opts ^. posVerbosity == Debug) + & set + (PIR.ccOpts . PIR.coMaxSimplifierIterations) + (opts ^. posMaxSimplifierIterationsPir) + & set PIR.ccTypeCheckConfig pirTcConfig + -- Simplifier options + & set + (PIR.ccOpts . PIR.coDoSimplifierUnwrapCancel) + (opts ^. posDoSimplifierUnwrapCancel) + & set + (PIR.ccOpts . PIR.coDoSimplifierBeta) + (opts ^. posDoSimplifierBeta) + & set + (PIR.ccOpts . PIR.coDoSimplifierInline) + (opts ^. posDoSimplifierInline) + & set + (PIR.ccOpts . PIR.coDoSimplifierEvaluateBuiltins) + (opts ^. posDoSimplifierEvaluateBuiltins) + & set + (PIR.ccOpts . PIR.coDoSimplifierStrictifyBindings) + (opts ^. posDoSimplifierStrictifyBindings) + & set + (PIR.ccOpts . PIR.coDoSimplifierRemoveDeadBindings) + (opts ^. posDoSimplifierRemoveDeadBindings) + & set + (PIR.ccOpts . PIR.coInlineConstants) + (opts ^. posInlineConstants) + & set + (PIR.ccOpts . PIR.coInlineFix) + (opts ^. posInlineFix) + & set (PIR.ccOpts . PIR.coInlineHints) hints + & set + (PIR.ccOpts . PIR.coInlineCallsiteGrowth) + (opts ^. posInlineCallsiteGrowth . to fromIntegral) + & set (PIR.ccOpts . PIR.coRelaxedFloatin) (opts ^. posRelaxedFloatin) + & set + (PIR.ccOpts . PIR.coCaseOfCaseConservative) + (opts ^. posCaseOfCaseConservative) + & set (PIR.ccOpts . PIR.coPreserveLogging) (opts ^. posPreserveLogging) + -- We could make this configurable with an option, but: + -- 1. The only other choice you can make is new version + Scott encoding, and + -- there's really no reason to pick that + -- 2. This is consistent with what we do in Lift + & set + (PIR.ccOpts . PIR.coDatatypes . PIR.dcoStyle) + ( if plcVersion < PLC.plcVersion110 + then PIR.ScottEncoding + else PIR.SumsOfProducts + ) + -- TODO: ensure the same as the one used in the plugin + & set PIR.ccBuiltinsInfo def + & set PIR.ccBuiltinCostModel def + & set PIR.ccRewriteRules rewriteRules + plcOpts = + PLC.defaultCompilationOpts + & set + (PLC.coSimplifyOpts . UPLC.soMaxSimplifierIterations) + (opts ^. posMaxSimplifierIterationsUPlc) + & set + (PLC.coSimplifyOpts . UPLC.soMaxCseIterations) + (opts ^. posMaxCseIterations) + & set + (PLC.coSimplifyOpts . UPLC.soConservativeOpts) + (opts ^. posConservativeOpts) + & set (PLC.coSimplifyOpts . UPLC.soInlineHints) hints + & set + (PLC.coSimplifyOpts . UPLC.soInlineConstants) + (opts ^. posInlineConstants) + & set + (PLC.coSimplifyOpts . UPLC.soInlineCallsiteGrowth) + (opts ^. posInlineCallsiteGrowth . to fromIntegral) + & set + (PLC.coSimplifyOpts . UPLC.soPreserveLogging) + (opts ^. posPreserveLogging) + + -- GHC.Core -> Pir translation. + pirT <- original <$> (PIR.runDefT annMayInline $ compileExprWithDefs expr) + let pirP = PIR.Program noProvenance plcVersion pirT + when (opts ^. posDumpPir) . liftIO $ + dumpFlat (void pirP) "initial PIR program" (moduleName ++ "_initial.pir-flat") + + -- Pir -> (Simplified) Pir pass. We can then dump/store a more legible PIR program. + spirP <- flip runReaderT pirCtx $ PIR.compileToReadable pirP + when (opts ^. posDumpPir) . liftIO $ + dumpFlat (void spirP) "simplified PIR program" (moduleName ++ "_simplified.pir-flat") + + -- (Simplified) Pir -> Plc translation. + plcP <- flip runReaderT pirCtx $ PIR.compileReadableToPlc spirP + when (opts ^. posDumpPlc) . liftIO $ + dumpFlat (void plcP) "typed PLC program" (moduleName ++ ".tplc-flat") + + -- We do this after dumping the programs so that if we fail typechecking we still get the dump. + when (opts ^. posDoTypecheck) . void $ + liftExcept $ + PLC.inferTypeOfProgram plcTcConfig (plcP $> annMayInline) + + let optCertify = opts ^. posCertify + (uplcP, simplTrace) <- flip runReaderT plcOpts $ PLC.compileProgramWithTrace plcP + liftIO $ case optCertify of + Just certName -> do + result <- runCertifier $ mkCertifier simplTrace certName + case result of + Right certSuccess -> + hPutStrLn stderr $ prettyCertifierSuccess certSuccess + Left err -> + hPutStrLn stderr $ prettyCertifierError err + Nothing -> pure () + dbP <- liftExcept $ traverseOf UPLC.progTerm UPLC.deBruijnTerm uplcP + when (opts ^. posDumpUPlc) . liftIO $ + dumpFlat + (UPLC.UnrestrictedProgram $ void dbP) + "untyped PLC program" + (moduleName ++ ".uplc-flat") + -- Discard the Provenance information at this point, just keep the SrcSpans + -- TODO: keep it and do something useful with it + pure (fmap getSrcSpans spirP, fmap getSrcSpans dbP) + where + -- ugly trick to take out the concrete plc.error and in case of error, map it / rethrow it + -- using our 'CompileError' + liftExcept :: ExceptT (PLC.Error PLC.DefaultUni PLC.DefaultFun Ann) m b -> m b + liftExcept act = do + plcTcError <- runExceptT act + -- also wrap the PLC Error annotations into Original provenances, to match our expected + -- 'CompileError' + liftEither $ first (view (re PIR._PLCError) . fmap PIR.Original) plcTcError + + dumpFlat :: (Flat t) => t -> String -> String -> IO () + dumpFlat t desc fileName = do + (tPath, tHandle) <- openBinaryTempFile "." fileName + putStrLn $ "!!! dumping " ++ desc ++ " to " ++ show tPath + BS.hPut tHandle $ flat t + + getSrcSpans :: PIR.Provenance Ann -> SrcSpans + getSrcSpans = SrcSpans . Set.unions . fmap (unSrcSpans . annSrcSpans) . toList -- | Get the 'GHC.Name' corresponding to the given 'TH.Name', or throw an error if we can't get it. thNameToGhcNameOrFail :: TH.Name -> PluginM uni fun GHC.Name thNameToGhcNameOrFail name = do - maybeName <- lift . lift $ GHC.thNameToGhcName name - case maybeName of - Just n -> pure n - Nothing -> throwError . NoContext $ CoreNameLookupError name + maybeName <- lift . lift $ GHC.thNameToGhcName name + case maybeName of + Just n -> pure n + Nothing -> throwError . NoContext $ CoreNameLookupError name -- | Create a GHC Core expression that will evaluate to the given ByteString at runtime. makeByteStringLiteral :: BS.ByteString -> PluginM uni fun GHC.CoreExpr makeByteStringLiteral bs = do - flags <- GHC.getDynFlags - - {- - This entire section will crash horribly in a number of circumstances. Such is life. - - If any of the names we need can't be found as GHC Names - - If we then can't look up those GHC Names to get their IDs/types - - If we make any mistakes creating the Core expression - -} - - -- Get the names of functions/types that we need for our expression - upio <- lift . lift . GHC.lookupId =<< thNameToGhcNameOrFail 'unsafePerformIO - bsTc <- lift . lift . GHC.lookupTyCon =<< thNameToGhcNameOrFail ''BS.ByteString - upal <- lift . lift . GHC.lookupId =<< thNameToGhcNameOrFail 'BSUnsafe.unsafePackAddressLen - - -- We construct the following expression: - -- unsafePerformIO $ - -- unsafePackAddressLen - -- This technique gratefully borrowed from the file-embed package - - -- The flags here are so GHC can check whether the int is in range for the current platform. - let lenLit = GHC.mkIntExpr (GHC.targetPlatform flags) $ fromIntegral $ BS.length bs - -- This will have type Addr#, which is right for unsafePackAddressLen - let bsLit = GHC.Lit (GHC.LitString bs) - let upaled = GHC.mkCoreApps (GHC.Var upal) [lenLit, bsLit] - let upioed = GHC.mkCoreApps (GHC.Var upio) [GHC.Type (GHC.mkTyConTy bsTc), upaled] - - pure upioed + flags <- GHC.getDynFlags + + {- + This entire section will crash horribly in a number of circumstances. Such is life. + - If any of the names we need can't be found as GHC Names + - If we then can't look up those GHC Names to get their IDs/types + - If we make any mistakes creating the Core expression + -} + + -- Get the names of functions/types that we need for our expression + upio <- lift . lift . GHC.lookupId =<< thNameToGhcNameOrFail 'unsafePerformIO + bsTc <- lift . lift . GHC.lookupTyCon =<< thNameToGhcNameOrFail ''BS.ByteString + upal <- lift . lift . GHC.lookupId =<< thNameToGhcNameOrFail 'BSUnsafe.unsafePackAddressLen + + -- We construct the following expression: + -- unsafePerformIO $ + -- unsafePackAddressLen + -- This technique gratefully borrowed from the file-embed package + + -- The flags here are so GHC can check whether the int is in range for the current platform. + let lenLit = GHC.mkIntExpr (GHC.targetPlatform flags) $ fromIntegral $ BS.length bs + -- This will have type Addr#, which is right for unsafePackAddressLen + let bsLit = GHC.Lit (GHC.LitString bs) + let upaled = GHC.mkCoreApps (GHC.Var upal) [lenLit, bsLit] + let upioed = GHC.mkCoreApps (GHC.Var upio) [GHC.Type (GHC.mkTyConTy bsTc), upaled] + + pure upioed -- | Strips all enclosing 'GHC.Tick's off an expression. stripTicks :: GHC.CoreExpr -> GHC.CoreExpr stripTicks = \case - GHC.Tick _ e -> stripTicks e - e -> e + GHC.Tick _ e -> stripTicks e + e -> e -- | Helper to avoid doing too much construction of Core ourselves -mkCompiledCode :: forall a . BS.ByteString -> BS.ByteString -> BS.ByteString -> CompiledCode a +mkCompiledCode :: forall a. BS.ByteString -> BS.ByteString -> BS.ByteString -> CompiledCode a mkCompiledCode plcBS pirBS ci = SerializedCode plcBS (Just pirBS) (fold . unflat $ ci) --- | Make a 'NameInfo' mapping the given set of TH names to their --- 'GHC.TyThing's for later reference. +{-| Make a 'NameInfo' mapping the given set of TH names to their +'GHC.TyThing's for later reference. +-} makePrimitiveNameInfo :: [TH.Name] -> PluginM uni fun NameInfo makePrimitiveNameInfo names = do - infos <- for names $ \name -> do - ghcName <- thNameToGhcNameOrFail name - thing <- lift . lift $ GHC.lookupThing ghcName - pure (name, thing) - pure $ Map.fromList infos + infos <- for names $ \name -> do + ghcName <- thNameToGhcNameOrFail name + thing <- lift . lift $ GHC.lookupThing ghcName + pure (name, thing) + pure $ Map.fromList infos makeRewriteRules :: PluginOptions -> RewriteRules DefaultUni DefaultFun makeRewriteRules options = diff --git a/plutus-tx-plugin/test/Array/Spec.hs b/plutus-tx-plugin/test/Array/Spec.hs index 8e795948ce1..ed4363f7177 100644 --- a/plutus-tx-plugin/test/Array/Spec.hs +++ b/plutus-tx-plugin/test/Array/Spec.hs @@ -4,9 +4,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-optimize #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-simplifier-beta #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-simplifier-evaluate-builtins #-} diff --git a/plutus-tx-plugin/test/AsData/Budget/Spec.hs b/plutus-tx-plugin/test/AsData/Budget/Spec.hs index 6b93c94196e..bd0e230ad26 100644 --- a/plutus-tx-plugin/test/AsData/Budget/Spec.hs +++ b/plutus-tx-plugin/test/AsData/Budget/Spec.hs @@ -18,16 +18,21 @@ import PlutusTx.TH (compile) tests :: TestNested tests = - testNested ("AsData" "Budget") . pure $ testNestedGhc - [ goldenBundle "onlyUseFirstField" onlyUseFirstField (onlyUseFirstField `unsafeApplyCode` inp) - , goldenBundle "onlyUseFirstField-manual" onlyUseFirstFieldManual - (onlyUseFirstFieldManual `unsafeApplyCode` inp) - , goldenBundle "patternMatching" patternMatching (patternMatching `unsafeApplyCode` inp) - , goldenBundle "recordFields" recordFields (recordFields `unsafeApplyCode` inp) - , goldenBundle "destructSum" destructSum (destructSum `unsafeApplyCode` inpSum) - , goldenBundle "destructSum-manual" destructSumManual - (destructSumManual `unsafeApplyCode` inpSumM) - ] + testNested ("AsData" "Budget") . pure $ + testNestedGhc + [ goldenBundle "onlyUseFirstField" onlyUseFirstField (onlyUseFirstField `unsafeApplyCode` inp) + , goldenBundle + "onlyUseFirstField-manual" + onlyUseFirstFieldManual + (onlyUseFirstFieldManual `unsafeApplyCode` inp) + , goldenBundle "patternMatching" patternMatching (patternMatching `unsafeApplyCode` inp) + , goldenBundle "recordFields" recordFields (recordFields `unsafeApplyCode` inp) + , goldenBundle "destructSum" destructSum (destructSum `unsafeApplyCode` inpSum) + , goldenBundle + "destructSum-manual" + destructSumManual + (destructSumManual `unsafeApplyCode` inpSumM) + ] -- A function that only accesses the first field of `Ints`. onlyUseFirstField :: CompiledCode (PlutusTx.BuiltinData -> Integer) @@ -35,7 +40,7 @@ onlyUseFirstField = $$( compile [|| \d -> case PlutusTx.unsafeFromBuiltinData d of - Ints {int1 = x} -> x + Ints{int1 = x} -> x ||] ) @@ -44,7 +49,7 @@ onlyUseFirstFieldManual = $$( compile [|| \d -> case PlutusTx.unsafeFromBuiltinData d of - IntsManual {int1Manual = x} -> x + IntsManual{int1Manual = x} -> x ||] ) @@ -108,8 +113,9 @@ recordFields = destructSum :: CompiledCode (PlutusTx.BuiltinData -> Ints) destructSum = - $$(compile - [|| \d -> + $$( compile + [|| + \d -> case PlutusTx.unsafeFromBuiltinData d of ThisD is -> is ThatD is -> is @@ -119,13 +125,14 @@ destructSum = (y1 `PlutusTx.addInteger` y2) (z1 `PlutusTx.addInteger` z2) (w1 `PlutusTx.addInteger` w2) - ||] + ||] ) destructSumManual :: CompiledCode (PlutusTx.BuiltinData -> Ints) destructSumManual = - $$(compile - [|| \d -> + $$( compile + [|| + \d -> case PlutusTx.unsafeFromBuiltinData d of ThisDManual is -> is ThatDManual is -> is @@ -135,7 +142,7 @@ destructSumManual = (y1 `PlutusTx.addInteger` y2) (z1 `PlutusTx.addInteger` z2) (w1 `PlutusTx.addInteger` w2) - ||] + ||] ) inp :: CompiledCode PlutusTx.BuiltinData diff --git a/plutus-tx-plugin/test/Blueprint/Tests.hs b/plutus-tx-plugin/test/Blueprint/Tests.hs index ed4103d914d..ca395428dee 100644 --- a/plutus-tx-plugin/test/Blueprint/Tests.hs +++ b/plutus-tx-plugin/test/Blueprint/Tests.hs @@ -102,14 +102,14 @@ contractBlueprint = testAllRequredDefinitions :: UnrollAll - [ Params - , Param2a - , Param2b - , Redeemer - , Redeemer2 - , Datum - , Datum2 - ] + [ Params + , Param2a + , Param2b + , Redeemer + , Redeemer2 + , Datum + , Datum2 + ] :~: [ Params , Bool , () diff --git a/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs b/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs index 6ebffa2b69f..1f539fa0830 100644 --- a/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs +++ b/plutus-tx-plugin/test/Blueprint/Tests/Lib.hs @@ -16,10 +16,10 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -module Blueprint.Tests.Lib - ( module Blueprint.Tests.Lib - , module AsData - ) where +module Blueprint.Tests.Lib ( + module Blueprint.Tests.Lib, + module AsData, +) where import Blueprint.Tests.Lib.AsData.Decls as AsData (datum2) import Codec.Serialise (serialise) diff --git a/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Blueprint.hs b/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Blueprint.hs index 1d22bb0a8d6..bd12c85306d 100644 --- a/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Blueprint.hs +++ b/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Blueprint.hs @@ -5,7 +5,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{- | This module contains data type declarations to use in blueprints **only** +{-| This module contains data type declarations to use in blueprints **only** The problem with using the 'AsData' types in blueprints is that such types are opaque and do not reveal their schema when deriving a 'HasBlueprintSchema' instance for a blueprint. diff --git a/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Decls.hs b/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Decls.hs index b0ddc734a39..8254b3faea2 100644 --- a/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Decls.hs +++ b/plutus-tx-plugin/test/Blueprint/Tests/Lib/AsData/Decls.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskellQuotes #-} -{- | This module contains TH data type declarations from which 'AsData' declarations are derived. +{-| This module contains TH data type declarations from which 'AsData' declarations are derived. These declarations are used for two purposes: 1. To generate an 'AsData' type declaration to be used in real validators. diff --git a/plutus-tx-plugin/test/Budget/Spec.hs b/plutus-tx-plugin/test/Budget/Spec.hs index fb5739c6995..257ce340285 100644 --- a/plutus-tx-plugin/test/Budget/Spec.hs +++ b/plutus-tx-plugin/test/Budget/Spec.hs @@ -31,302 +31,447 @@ import PlutusTx.Show qualified as PlutusTx import PlutusTx.Test import PlutusTx.TH (compile) -AsData.asData [d| - data MaybeD a = JustD a | NothingD - |] +AsData.asData + [d| + data MaybeD a = JustD a | NothingD + |] makeLift ''MaybeD tests :: TestNested -tests = testNested "Budget" . pure $ testNestedGhc - [ goldenBundle' "sum" compiledSum - , goldenBundle' "anyCheap" compiledAnyCheap - , goldenBundle' "anyExpensive" compiledAnyExpensive - , goldenBundle' "anyEmptyList" compiledAnyEmptyList - , goldenBundle' "allCheap" compiledAllCheap - , goldenBundle' "allExpensive" compiledAllExpensive - , goldenBundle' "allEmptyList" compiledAllEmptyList - , goldenBundle' "findCheap" compiledFindCheap - , goldenBundle' "findExpensive" compiledFindExpensive - , goldenBundle' "findEmptyList" compiledFindEmptyList - , goldenBundle' "findIndexCheap" compiledFindIndexCheap - , goldenBundle' "findIndexExpensive" compiledFindIndexExpensive - , goldenBundle' "findIndexEmptyList" compiledFindIndexEmptyList - , goldenBundle' "filter" compiledFilter - , goldenBundle' "andCheap" compiledAndCheap - , goldenBundle' "andExpensive" compiledAndExpensive - , goldenBundle' "orCheap" compiledOrCheap - , goldenBundle' "orExpensive" compiledOrExpensive - , goldenBundle' "elemCheap" compiledElemCheap - , goldenBundle' "elemExpensive" compiledElemExpensive - , goldenBundle' "notElemCheap" compiledNotElemCheap - , goldenBundle' "notElemExpensive" compiledNotElemExpensive - , goldenBundle' "lte0" compiledLte0 - , goldenBundle' "gte0" compiledGte0 - , goldenBundle' "recursiveLte0" compiledRecursiveLte0 - , goldenBundle' "recursiveGte0" compiledRecursiveGte0 - , goldenBundle' "sumL" compiledSumL - , goldenBundle' "sumR" compiledSumR - , goldenBundle' "constAccL" compiledConstAccL - , goldenBundle' "constAccR" compiledConstAccR - , goldenBundle' "constElL" compiledConstElL - , goldenBundle' "constElR" compiledConstElR - , goldenBundle' "null" compiledNull - - , goldenBundle "listIndexing" compiledListIndexing (compiledListIndexing `unsafeApplyCode` liftCodeDef listIndexingInput) - - , goldenBundle' "toFromData" compiledToFromData - , goldenBundle' "not-not" compiledNotNot - , goldenBundle' "monadicDo" monadicDo - , goldenBundle "sumAtIndices" compiledSumAtIndices (compiledSumAtIndices `unsafeApplyCode` sumAtIndicesInput) - - -- These should be a little cheaper than the previous one, - -- less overhead from going via monadic functions - , goldenBundle' "applicative" applicative - , goldenBundle' "patternMatch" patternMatch - , goldenBundle' "show" compiledShow - - -- These test cases are for testing the float-in pass. - , goldenBundle' "ifThenElse1" compiledIfThenElse1 - , goldenBundle' "ifThenElse2" compiledIfThenElse2 - , goldenBundle' "matchAsDataE" matchAsData - - -- Demonstrate inconsistent handling of '&&' and '||' - -- With GHC optimisations turned on - , goldenBundle' "andWithGHCOpts" compiledAndWithGHCOpts - -- With GHC optimisations turned off - , goldenBundle' "andWithoutGHCOpts" compiledAndWithoutGHCOpts - -- With the function definition in the local module - , goldenBundle' "andWithLocal" compiledAndWithLocal - ] +tests = + testNested "Budget" . pure $ + testNestedGhc + [ goldenBundle' "sum" compiledSum + , goldenBundle' "anyCheap" compiledAnyCheap + , goldenBundle' "anyExpensive" compiledAnyExpensive + , goldenBundle' "anyEmptyList" compiledAnyEmptyList + , goldenBundle' "allCheap" compiledAllCheap + , goldenBundle' "allExpensive" compiledAllExpensive + , goldenBundle' "allEmptyList" compiledAllEmptyList + , goldenBundle' "findCheap" compiledFindCheap + , goldenBundle' "findExpensive" compiledFindExpensive + , goldenBundle' "findEmptyList" compiledFindEmptyList + , goldenBundle' "findIndexCheap" compiledFindIndexCheap + , goldenBundle' "findIndexExpensive" compiledFindIndexExpensive + , goldenBundle' "findIndexEmptyList" compiledFindIndexEmptyList + , goldenBundle' "filter" compiledFilter + , goldenBundle' "andCheap" compiledAndCheap + , goldenBundle' "andExpensive" compiledAndExpensive + , goldenBundle' "orCheap" compiledOrCheap + , goldenBundle' "orExpensive" compiledOrExpensive + , goldenBundle' "elemCheap" compiledElemCheap + , goldenBundle' "elemExpensive" compiledElemExpensive + , goldenBundle' "notElemCheap" compiledNotElemCheap + , goldenBundle' "notElemExpensive" compiledNotElemExpensive + , goldenBundle' "lte0" compiledLte0 + , goldenBundle' "gte0" compiledGte0 + , goldenBundle' "recursiveLte0" compiledRecursiveLte0 + , goldenBundle' "recursiveGte0" compiledRecursiveGte0 + , goldenBundle' "sumL" compiledSumL + , goldenBundle' "sumR" compiledSumR + , goldenBundle' "constAccL" compiledConstAccL + , goldenBundle' "constAccR" compiledConstAccR + , goldenBundle' "constElL" compiledConstElL + , goldenBundle' "constElR" compiledConstElR + , goldenBundle' "null" compiledNull + , goldenBundle + "listIndexing" + compiledListIndexing + (compiledListIndexing `unsafeApplyCode` liftCodeDef listIndexingInput) + , goldenBundle' "toFromData" compiledToFromData + , goldenBundle' "not-not" compiledNotNot + , goldenBundle' "monadicDo" monadicDo + , goldenBundle + "sumAtIndices" + compiledSumAtIndices + (compiledSumAtIndices `unsafeApplyCode` sumAtIndicesInput) + , -- These should be a little cheaper than the previous one, + -- less overhead from going via monadic functions + goldenBundle' "applicative" applicative + , goldenBundle' "patternMatch" patternMatch + , goldenBundle' "show" compiledShow + , -- These test cases are for testing the float-in pass. + goldenBundle' "ifThenElse1" compiledIfThenElse1 + , goldenBundle' "ifThenElse2" compiledIfThenElse2 + , goldenBundle' "matchAsDataE" matchAsData + , -- Demonstrate inconsistent handling of '&&' and '||' + -- With GHC optimisations turned on + goldenBundle' "andWithGHCOpts" compiledAndWithGHCOpts + , -- With GHC optimisations turned off + goldenBundle' "andWithoutGHCOpts" compiledAndWithoutGHCOpts + , -- With the function definition in the local module + goldenBundle' "andWithLocal" compiledAndWithLocal + ] compiledSum :: CompiledCode Integer -compiledSum = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in F.sum ls ||]) +compiledSum = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in F.sum ls + ||] + ) -- | The first element in the list satisfies the predicate. compiledAnyCheap :: CompiledCode Bool -compiledAnyCheap = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.any (10 PlutusTx.>) ls ||]) +compiledAnyCheap = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.any (10 PlutusTx.>) ls + ||] + ) -- | No element in the list satisfies the predicate. compiledAnyExpensive :: CompiledCode Bool -compiledAnyExpensive = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.any (1 PlutusTx.>) ls ||]) +compiledAnyExpensive = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.any (1 PlutusTx.>) ls + ||] + ) compiledAnyEmptyList :: CompiledCode Bool -compiledAnyEmptyList = $$(compile [|| - let ls = [] :: [Integer] - in List.any (1 PlutusTx.>) ls ||]) +compiledAnyEmptyList = + $$( compile + [|| + let ls = [] :: [Integer] + in List.any (1 PlutusTx.>) ls + ||] + ) -- | The first element in the list does not satisfy the predicate. compiledAllCheap :: CompiledCode Bool -compiledAllCheap = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.all (1 PlutusTx.>) ls ||]) +compiledAllCheap = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.all (1 PlutusTx.>) ls + ||] + ) -- | All elements in the list satisfy the predicate. compiledAllExpensive :: CompiledCode Bool -compiledAllExpensive = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.all (11 PlutusTx.>) ls ||]) +compiledAllExpensive = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.all (11 PlutusTx.>) ls + ||] + ) compiledAllEmptyList :: CompiledCode Bool -compiledAllEmptyList = $$(compile [|| - let ls = [] :: [Integer] - in List.all (1 PlutusTx.>) ls ||]) +compiledAllEmptyList = + $$( compile + [|| + let ls = [] :: [Integer] + in List.all (1 PlutusTx.>) ls + ||] + ) -- | The first element in the list satisfies the predicate. compiledFindCheap :: CompiledCode (Maybe Integer) -compiledFindCheap = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.find (10 PlutusTx.>) ls ||]) +compiledFindCheap = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.find (10 PlutusTx.>) ls + ||] + ) -- | No element in the list satisfies the predicate. compiledFindExpensive :: CompiledCode (Maybe Integer) -compiledFindExpensive = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.find (1 PlutusTx.>) ls ||]) +compiledFindExpensive = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.find (1 PlutusTx.>) ls + ||] + ) compiledFindEmptyList :: CompiledCode (Maybe Integer) -compiledFindEmptyList = $$(compile [|| - let ls = [] :: [Integer] - in List.find (1 PlutusTx.>) ls ||]) +compiledFindEmptyList = + $$( compile + [|| + let ls = [] :: [Integer] + in List.find (1 PlutusTx.>) ls + ||] + ) -- | The first element in the list satisfies the predicate. compiledFindIndexCheap :: CompiledCode (Maybe Integer) -compiledFindIndexCheap = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.findIndex (10 PlutusTx.>) ls ||]) +compiledFindIndexCheap = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.findIndex (10 PlutusTx.>) ls + ||] + ) -- | No element in the list satisfies the predicate. compiledFindIndexExpensive :: CompiledCode (Maybe Integer) -compiledFindIndexExpensive = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.findIndex (1 PlutusTx.>) ls ||]) +compiledFindIndexExpensive = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.findIndex (1 PlutusTx.>) ls + ||] + ) compiledFindIndexEmptyList :: CompiledCode (Maybe Integer) -compiledFindIndexEmptyList = $$(compile [|| - let ls = [] :: [Integer] - in List.findIndex (1 PlutusTx.>) ls ||]) +compiledFindIndexEmptyList = + $$( compile + [|| + let ls = [] :: [Integer] + in List.findIndex (1 PlutusTx.>) ls + ||] + ) compiledFilter :: CompiledCode [Integer] -compiledFilter = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.filter PlutusTx.even ls ||]) +compiledFilter = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.filter PlutusTx.even ls + ||] + ) -- | The first element is False so @and@ should short-circuit immediately. compiledAndCheap :: CompiledCode Bool -compiledAndCheap = $$(compile [|| - let ls = [False, True, True, True, True, True, True, True, True, True] - in List.and ls ||]) +compiledAndCheap = + $$( compile + [|| + let ls = [False, True, True, True, True, True, True, True, True, True] + in List.and ls + ||] + ) -- | All elements are True so @and@ cannot short-circuit. compiledAndExpensive :: CompiledCode Bool -compiledAndExpensive = $$(compile [|| - let ls = [True, True, True, True, True, True, True, True, True, True] - in List.and ls ||]) +compiledAndExpensive = + $$( compile + [|| + let ls = [True, True, True, True, True, True, True, True, True, True] + in List.and ls + ||] + ) -- | The first element is True so @or@ should short-circuit immediately. compiledOrCheap :: CompiledCode Bool -compiledOrCheap = $$(compile [|| - let ls = [True, False, False, False, False, False, False, False, False, False] - in List.or ls ||]) +compiledOrCheap = + $$( compile + [|| + let ls = [True, False, False, False, False, False, False, False, False, False] + in List.or ls + ||] + ) -- | All elements are False so @or@ cannot short-circuit. compiledOrExpensive :: CompiledCode Bool -compiledOrExpensive = $$(compile [|| - let ls = [False, False, False, False, False, False, False, False, False, False] - in List.or ls ||]) +compiledOrExpensive = + $$( compile + [|| + let ls = [False, False, False, False, False, False, False, False, False, False] + in List.or ls + ||] + ) -- | @elem@ can short-circuit compiledElemCheap :: CompiledCode Bool -compiledElemCheap = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.elem 1 ls ||]) +compiledElemCheap = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.elem 1 ls + ||] + ) -- | @elem@ cannot short-circuit compiledElemExpensive :: CompiledCode Bool -compiledElemExpensive = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.elem 0 ls ||]) +compiledElemExpensive = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.elem 0 ls + ||] + ) -- | @notElem@ can short-circuit compiledNotElemCheap :: CompiledCode Bool -compiledNotElemCheap = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.notElem 1 ls ||]) +compiledNotElemCheap = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.notElem 1 ls + ||] + ) -- | @notElem@ cannot short-circuit compiledNotElemExpensive :: CompiledCode Bool -compiledNotElemExpensive = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.notElem 0 ls ||]) +compiledNotElemExpensive = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.notElem 0 ls + ||] + ) -- | Check @0 <= 0@ a thousand times using @all@ that inlines. compiledLte0 :: CompiledCode Bool -compiledLte0 = $$(compile [|| - let ls = List.replicate 1000 0 :: [Integer] - in List.all (PlutusTx.<= 0) ls ||]) +compiledLte0 = + $$( compile + [|| + let ls = List.replicate 1000 0 :: [Integer] + in List.all (PlutusTx.<= 0) ls + ||] + ) -- | Check @0 >= 0@ a thousand times using @all@ that inlines. compiledGte0 :: CompiledCode Bool -compiledGte0 = $$(compile [|| - let ls = List.replicate 1000 0 :: [Integer] - in List.all (PlutusTx.>= 0) ls ||]) +compiledGte0 = + $$( compile + [|| + let ls = List.replicate 1000 0 :: [Integer] + in List.all (PlutusTx.>= 0) ls + ||] + ) -- | A version of @all@ that doesn't inline due to being recursive. recursiveAll :: forall a. (a -> Bool) -> [a] -> Bool -recursiveAll _ [] = True -recursiveAll f (x:xs) = if f x then recursiveAll f xs else False -{-# INLINABLE recursiveAll #-} +recursiveAll _ [] = True +recursiveAll f (x : xs) = if f x then recursiveAll f xs else False +{-# INLINEABLE recursiveAll #-} -- | Check @0 <= 0@ a thousand times using @all@ that doesn't inline. compiledRecursiveLte0 :: CompiledCode Bool -compiledRecursiveLte0 = $$(compile [|| - let ls = List.replicate 1000 0 :: [Integer] - in recursiveAll (PlutusTx.<= 0) ls ||]) +compiledRecursiveLte0 = + $$( compile + [|| + let ls = List.replicate 1000 0 :: [Integer] + in recursiveAll (PlutusTx.<= 0) ls + ||] + ) -- | Check @0 >= 0@ a thousand times using @all@ that doesn't inline. compiledRecursiveGte0 :: CompiledCode Bool -compiledRecursiveGte0 = $$(compile [|| - let ls = List.replicate 1000 0 :: [Integer] - in recursiveAll (PlutusTx.>= 0) ls ||]) +compiledRecursiveGte0 = + $$( compile + [|| + let ls = List.replicate 1000 0 :: [Integer] + in recursiveAll (PlutusTx.>= 0) ls + ||] + ) -- | Left-fold a list with a function summing its arguments. compiledSumL :: CompiledCode Integer -compiledSumL = $$(compile [|| - let ls = PlutusTx.enumFromTo 1 1000 :: [Integer] - in List.foldl (PlutusTx.+) 0 ls ||]) +compiledSumL = + $$( compile + [|| + let ls = PlutusTx.enumFromTo 1 1000 :: [Integer] + in List.foldl (PlutusTx.+) 0 ls + ||] + ) -- | Right-fold a list with a function summing its arguments. compiledSumR :: CompiledCode Integer -compiledSumR = $$(compile [|| - let ls = PlutusTx.enumFromTo 1 1000 :: [Integer] - in List.foldr (PlutusTx.+) 0 ls ||]) +compiledSumR = + $$( compile + [|| + let ls = PlutusTx.enumFromTo 1 1000 :: [Integer] + in List.foldr (PlutusTx.+) 0 ls + ||] + ) -- | Left-fold a list with a function returning the accumulator. compiledConstAccL :: CompiledCode Integer -compiledConstAccL = $$(compile [|| - let ls = List.replicate 1000 (1 :: Integer) - in List.foldl (\acc _ -> acc) 42 ls ||]) +compiledConstAccL = + $$( compile + [|| + let ls = List.replicate 1000 (1 :: Integer) + in List.foldl (\acc _ -> acc) 42 ls + ||] + ) -- | Right-fold a list with a function returning the accumulator. compiledConstAccR :: CompiledCode Integer -compiledConstAccR = $$(compile [|| - let ls = List.replicate 1000 (1 :: Integer) - in List.foldr (\_ acc -> acc) 42 ls ||]) +compiledConstAccR = + $$( compile + [|| + let ls = List.replicate 1000 (1 :: Integer) + in List.foldr (\_ acc -> acc) 42 ls + ||] + ) -- | Left-fold a list with a function returning a list element, the result is the last element. compiledConstElL :: CompiledCode Integer -compiledConstElL = $$(compile [|| - let ls = List.replicate 1000 (1 :: Integer) - in List.foldl (\_ el -> el) 42 ls ||]) +compiledConstElL = + $$( compile + [|| + let ls = List.replicate 1000 (1 :: Integer) + in List.foldl (\_ el -> el) 42 ls + ||] + ) -- | Right-fold a list with a function returning a list element, the result is the first element. compiledConstElR :: CompiledCode Integer -compiledConstElR = $$(compile [|| - let ls = List.replicate 1000 (1 :: Integer) - in List.foldr (\el _ -> el) 42 ls ||]) +compiledConstElR = + $$( compile + [|| + let ls = List.replicate 1000 (1 :: Integer) + in List.foldr (\el _ -> el) 42 ls + ||] + ) compiledNull :: CompiledCode Bool -compiledNull = $$(compile [|| - let ls = [1,2,3,4,5,6,7,8,9,10] :: [Integer] - in List.null ls ||]) +compiledNull = + $$( compile + [|| + let ls = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10] :: [Integer] + in List.null ls + ||] + ) compiledListIndexing :: CompiledCode ([PlutusTx.BuiltinData] -> PlutusTx.BuiltinData) -compiledListIndexing = $$(compile [|| - \xs -> xs List.!! 5 ||]) +compiledListIndexing = + $$( compile + [|| + \xs -> xs List.!! 5 + ||] + ) listIndexingInput :: [PlutusTx.BuiltinData] listIndexingInput = IsData.toBuiltinData <$> [1 :: Integer .. 10] compiledToFromData :: CompiledCode (Either Integer (Maybe (Bool, Integer, Bool))) -compiledToFromData = $$(compile [|| - let - v :: Either Integer (Maybe (Bool, Integer, Bool)) - v = Right (Just (True, 1, False)) - d :: PlutusTx.BuiltinData - d = IsData.toBuiltinData v - in IsData.unsafeFromBuiltinData d ||]) +compiledToFromData = + $$( compile + [|| + let + v :: Either Integer (Maybe (Bool, Integer, Bool)) + v = Right (Just (True, 1, False)) + d :: PlutusTx.BuiltinData + d = IsData.toBuiltinData v + in + IsData.unsafeFromBuiltinData d + ||] + ) doExample :: Maybe Integer -> Maybe Integer -> Maybe Integer doExample x y = do - x' <- x - y' <- y - PlutusTx.pure (x' PlutusTx.+ y') + x' <- x + y' <- y + PlutusTx.pure (x' PlutusTx.+ y') applicativeExample :: Maybe Integer -> Maybe Integer -> Maybe Integer applicativeExample x y = (PlutusTx.+) PlutusTx.<$> x PlutusTx.<*> y patternMatchExample :: Maybe Integer -> Maybe Integer -> Maybe Integer patternMatchExample x y = case x of - Just x' -> case y of - Just y' -> Just (x' PlutusTx.+ y') - Nothing -> Nothing + Just x' -> case y of + Just y' -> Just (x' PlutusTx.+ y') Nothing -> Nothing + Nothing -> Nothing sumAtIndices :: PlutusTx.BuiltinData -> Integer sumAtIndices d = @@ -336,12 +481,12 @@ sumAtIndices d = 'list [|s1 PlutusTx.+ s4 PlutusTx.+ s5|] ) - where - list :: List Integer - list = IsData.unsafeFromBuiltinData d + where + list :: List Integer + list = IsData.unsafeFromBuiltinData d compiledSumAtIndices :: CompiledCode (PlutusTx.BuiltinData -> Integer) -compiledSumAtIndices = $$(compile [|| sumAtIndices ||]) +compiledSumAtIndices = $$(compile [||sumAtIndices||]) sumAtIndicesInput :: CompiledCode PlutusTx.BuiltinData sumAtIndicesInput = liftCodeDef (IsData.toBuiltinData ([0, 10, 20, 30, 40, 50, 60] :: [Integer])) @@ -366,59 +511,85 @@ This is likely caused by the @$fApplicativeMaybe_$cpure@ in the CoreExpr. In GHC it is inlined into @Just@. -} monadicDo :: CompiledCode (Maybe Integer) -monadicDo = $$(compile [|| - let x = Just 1 - y = Just 2 - in doExample x y ||]) +monadicDo = + $$( compile + [|| + let x = Just 1 + y = Just 2 + in doExample x y + ||] + ) applicative :: CompiledCode (Maybe Integer) -applicative = $$(compile [|| - let x = Just 1 - y = Just 2 - in applicativeExample x y ||]) +applicative = + $$( compile + [|| + let x = Just 1 + y = Just 2 + in applicativeExample x y + ||] + ) patternMatch :: CompiledCode (Maybe Integer) -patternMatch = $$(compile [|| - let x = Just 1 - y = Just 2 - in patternMatchExample x y ||]) +patternMatch = + $$( compile + [|| + let x = Just 1 + y = Just 2 + in patternMatchExample x y + ||] + ) showExample :: Integer -> Integer showExample x = - let !a = PlutusTx.trace (PlutusTx.show x) x - !b = PlutusTx.trace "This is an example" a - !c = PlutusTx.trace (PlutusTx.show (PlutusTx.encodeUtf8 "This is an example")) b - !d = PlutusTx.trace (PlutusTx.show (PlutusTx.greaterThanInteger c 0)) c - !e = PlutusTx.trace (PlutusTx.show [a, b, c, d]) d - !f = PlutusTx.trace (PlutusTx.show (a, b, c, d, e)) e - in f `PlutusTx.multiplyInteger` 2 + let !a = PlutusTx.trace (PlutusTx.show x) x + !b = PlutusTx.trace "This is an example" a + !c = PlutusTx.trace (PlutusTx.show (PlutusTx.encodeUtf8 "This is an example")) b + !d = PlutusTx.trace (PlutusTx.show (PlutusTx.greaterThanInteger c 0)) c + !e = PlutusTx.trace (PlutusTx.show [a, b, c, d]) d + !f = PlutusTx.trace (PlutusTx.show (a, b, c, d, e)) e + in f `PlutusTx.multiplyInteger` 2 compiledShow :: CompiledCode Integer -compiledShow = $$(compile [|| - let x = -1234567890 - in showExample x ||]) +compiledShow = + $$( compile + [|| + let x = -1234567890 + in showExample x + ||] + ) --- | In this example, the float-in pass cannot reduce the cost unless it allows --- unconditionally floating into type abstractions. Both branches are --- turned into type abstractions (because the `a + a` branch is not a value). +{-| In this example, the float-in pass cannot reduce the cost unless it allows +unconditionally floating into type abstractions. Both branches are +turned into type abstractions (because the `a + a` branch is not a value). +-} compiledIfThenElse1 :: CompiledCode Integer -compiledIfThenElse1 = $$(compile [|| - let a = 1 PlutusTx.+ 2 - in if 3 PlutusTx.< (4 :: Integer) - then 5 - else a PlutusTx.+ a ||]) - --- | In this example, the float-in pass cannot reduce the cost unless it allows --- unconditionally floating into lambda abstractions. Both branches are --- lambda abstractions. +compiledIfThenElse1 = + $$( compile + [|| + let a = 1 PlutusTx.+ 2 + in if 3 PlutusTx.< (4 :: Integer) + then 5 + else a PlutusTx.+ a + ||] + ) + +{-| In this example, the float-in pass cannot reduce the cost unless it allows +unconditionally floating into lambda abstractions. Both branches are +lambda abstractions. +-} compiledIfThenElse2 :: CompiledCode Integer -compiledIfThenElse2 = $$(compile [|| - let a = 1 PlutusTx.+ 2 - in ( if 3 PlutusTx.< (4 :: Integer) - then \x -> x PlutusTx.+ 5 - else \x -> x PlutusTx.+ a PlutusTx.+ a - ) - (6 PlutusTx.+ 7) ||]) +compiledIfThenElse2 = + $$( compile + [|| + let a = 1 PlutusTx.+ 2 + in ( if 3 PlutusTx.< (4 :: Integer) + then \x -> x PlutusTx.+ 5 + else \x -> x PlutusTx.+ a PlutusTx.+ a + ) + (6 PlutusTx.+ 7) + ||] + ) -- TODO: this can be further optimized. compiledNotNot :: CompiledCode Bool @@ -426,28 +597,33 @@ compiledNotNot = $$( compile [|| \x -> - (\a -> if a then False else True) . (\a -> if a then False else True) PlutusTx.$ - if PlutusTx.lessThanInteger 0 x then True else False + (\a -> if a then False else True) + . (\a -> if a then False else True) + PlutusTx.$ if PlutusTx.lessThanInteger 0 x then True else False ||] ) `unsafeApplyCode` liftCodeDef 1 matchAsData :: CompiledCode Integer -matchAsData = $$(compile [|| - \case - JustD a -> a - NothingD -> 1 ||]) +matchAsData = + $$( compile + [|| + \case + JustD a -> a + NothingD -> 1 + ||] + ) `unsafeApplyCode` liftCodeDef (JustD 1) compiledAndWithGHCOpts :: CompiledCode Bool compiledAndWithGHCOpts = - let code = $$(compile [|| WithGHCOptTest.f ||]) + let code = $$(compile [||WithGHCOptTest.f||]) in flip unsafeApplyCode (liftCodeDef (4 :: Integer)) $ unsafeApplyCode code (liftCodeDef (4 :: Integer)) compiledAndWithoutGHCOpts :: CompiledCode Bool compiledAndWithoutGHCOpts = - let code = $$(compile [|| WithoutGHCOptTest.f ||]) + let code = $$(compile [||WithoutGHCOptTest.f||]) in flip unsafeApplyCode (liftCodeDef (4 :: Integer)) $ unsafeApplyCode code (liftCodeDef (4 :: Integer)) @@ -455,6 +631,6 @@ compiledAndWithLocal :: CompiledCode Bool compiledAndWithLocal = let f :: Integer -> Integer -> Bool f x y = (PlutusTx.&&) (x PlutusTx.< (3 :: Integer)) (y PlutusTx.< (3 :: Integer)) - code = $$(compile [|| f ||]) + code = $$(compile [||f||]) in flip unsafeApplyCode (liftCodeDef (4 :: Integer)) $ unsafeApplyCode code (liftCodeDef (4 :: Integer)) diff --git a/plutus-tx-plugin/test/Budget/WithGHCOptimisations.hs b/plutus-tx-plugin/test/Budget/WithGHCOptimisations.hs index 94f44dafd28..3a6d8f7be33 100644 --- a/plutus-tx-plugin/test/Budget/WithGHCOptimisations.hs +++ b/plutus-tx-plugin/test/Budget/WithGHCOptimisations.hs @@ -1,4 +1,5 @@ -{-#OPTIONS_GHC -O1 #-} +{-# OPTIONS_GHC -O1 #-} + module Budget.WithGHCOptimisations where import PlutusTx.Prelude qualified as PlutusTx diff --git a/plutus-tx-plugin/test/Budget/WithoutGHCOptimisations.hs b/plutus-tx-plugin/test/Budget/WithoutGHCOptimisations.hs index f861dc2d477..17f1d8a8ed3 100644 --- a/plutus-tx-plugin/test/Budget/WithoutGHCOptimisations.hs +++ b/plutus-tx-plugin/test/Budget/WithoutGHCOptimisations.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -O0 -fmax-simplifier-iterations=0 #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module Budget.WithoutGHCOptimisations where diff --git a/plutus-tx-plugin/test/BuiltinList/Budget/Spec.hs b/plutus-tx-plugin/test/BuiltinList/Budget/Spec.hs index 64367ac6d97..d9435fd0a54 100644 --- a/plutus-tx-plugin/test/BuiltinList/Budget/Spec.hs +++ b/plutus-tx-plugin/test/BuiltinList/Budget/Spec.hs @@ -43,7 +43,7 @@ all :: CompiledCode (P.BuiltinList Integer -> (Bool, Bool)) all = $$(compile [||\xs -> (L.all (P.>= 8) xs, L.all (P.>= 0) xs)||]) index :: CompiledCode (P.BuiltinList Integer -> Integer) -index = $$(compile [|| (L.!! 5) ||]) +index = $$(compile [||(L.!! 5)||]) l :: CompiledCode (P.BuiltinList Integer) l = liftCodeDef $ toBuiltin ([1 .. 10] :: [Integer]) diff --git a/plutus-tx-plugin/test/DataList/Budget/Spec.hs b/plutus-tx-plugin/test/DataList/Budget/Spec.hs index c799c3a3c71..5a7f3561067 100644 --- a/plutus-tx-plugin/test/DataList/Budget/Spec.hs +++ b/plutus-tx-plugin/test/DataList/Budget/Spec.hs @@ -23,10 +23,14 @@ tests = , goldenBundle "any" any (any `unsafeApplyCode` l) , goldenBundle "elem" elem (elem `unsafeApplyCode` l) , goldenBundle "partition" partition (partition `unsafeApplyCode` l) - , goldenBundle "makeList" makeList - (makeList `unsafeApplyCode` liftCodeDef 1 - `unsafeApplyCode` liftCodeDef 2 - `unsafeApplyCode` liftCodeDef 3) + , goldenBundle + "makeList" + makeList + ( makeList + `unsafeApplyCode` liftCodeDef 1 + `unsafeApplyCode` liftCodeDef 2 + `unsafeApplyCode` liftCodeDef 3 + ) ] length :: CompiledCode (L.List Integer -> Integer) diff --git a/plutus-tx-plugin/test/Inline/Spec.hs b/plutus-tx-plugin/test/Inline/Spec.hs index 154cc811306..a89146157e7 100644 --- a/plutus-tx-plugin/test/Inline/Spec.hs +++ b/plutus-tx-plugin/test/Inline/Spec.hs @@ -26,17 +26,19 @@ tests = , goldenBundle "inline-twice" inlineTwice (applyOneTwoThree inlineTwice) , goldenPirReadable "recursive" recursive , goldenUPlcReadable "recursive" recursive - , goldenBundle "inlineLocalOnce" compiledInlineLocalOnce - (compiledInlineLocalOnce `unsafeApplyCode` liftCodeDef 2) + , goldenBundle + "inlineLocalOnce" + compiledInlineLocalOnce + (compiledInlineLocalOnce `unsafeApplyCode` liftCodeDef 2) , goldenPirReadable "always-inline-local" compiledAlwaysInlineLocal , goldenUPlcReadable "always-inline-local" compiledAlwaysInlineLocal ] - where - applyOneTwoThree f = - f `unsafeApplyCode` liftCodeDef 1 - `unsafeApplyCode` liftCodeDef 2 - `unsafeApplyCode` liftCodeDef 3 - + where + applyOneTwoThree f = + f + `unsafeApplyCode` liftCodeDef 1 + `unsafeApplyCode` liftCodeDef 2 + `unsafeApplyCode` liftCodeDef 3 double :: Integer -> Integer double x = x `PlutusTx.addInteger` x @@ -114,8 +116,8 @@ in UPLC the inlining is reversed by CSE. -} inlineLocalOnce :: Integer -> Integer inlineLocalOnce x = square `PlutusTx.addInteger` square `PlutusTx.addInteger` inline square - where - !square = x `PlutusTx.multiplyInteger` x + where + !square = x `PlutusTx.multiplyInteger` x {-# INLINEABLE inlineLocalOnce #-} -- Use INLINE pragma on local variable `square` to make it always inlined. @@ -123,13 +125,13 @@ inlineLocalOnce x = square `PlutusTx.addInteger` square `PlutusTx.addInteger` in -- reversed by CSE in UPLC. alwaysInlineLocal :: Integer -> Integer alwaysInlineLocal x = square `PlutusTx.addInteger` square `PlutusTx.addInteger` square - where - !square = x `PlutusTx.multiplyInteger` x - {-# INLINE square #-} -{-# INLINABLE alwaysInlineLocal #-} + where + !square = x `PlutusTx.multiplyInteger` x + {-# INLINE square #-} +{-# INLINEABLE alwaysInlineLocal #-} compiledInlineLocalOnce :: CompiledCode (Integer -> Integer) -compiledInlineLocalOnce = $$(compile [|| inlineLocalOnce ||]) +compiledInlineLocalOnce = $$(compile [||inlineLocalOnce||]) compiledAlwaysInlineLocal :: CompiledCode (Integer -> Integer) -compiledAlwaysInlineLocal = $$(compile [|| alwaysInlineLocal ||]) +compiledAlwaysInlineLocal = $$(compile [||alwaysInlineLocal||]) diff --git a/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NegativeLiterals/Spec.hs b/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NegativeLiterals/Spec.hs index ec027ea86f8..b2a780f7b4c 100644 --- a/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NegativeLiterals/Spec.hs +++ b/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NegativeLiterals/Spec.hs @@ -1,15 +1,15 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} - {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE NoStrict #-} +{-# LANGUAGE TemplateHaskell #-} --- | This module tests that integer literals are handled correctly when @Strict@ is off --- and @NegativeLiterals@ is on. These two extensions affect the Core we get. When --- @NegativeLiterals@ is on, we can get @IN@ for negative integers. --- --- See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. +{-| This module tests that integer literals are handled correctly when @Strict@ is off +and @NegativeLiterals@ is on. These two extensions affect the Core we get. When +@NegativeLiterals@ is on, we can get @IN@ for negative integers. + +See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. +-} module IntegerLiterals.NoStrict.NegativeLiterals.Spec where import PlutusTx.Code @@ -20,9 +20,11 @@ import PlutusTx.TH (compile) import Test.Tasty.Extras tests :: TestNested -tests = testNested "IntegerLiterals" . pure $ testNestedGhc - [ goldenPirReadable "integerLiterals-NoStrict-NegativeLiterals" integerLiterals - ] +tests = + testNested "IntegerLiterals" . pure $ + testNestedGhc + [ goldenPirReadable "integerLiterals-NoStrict-NegativeLiterals" integerLiterals + ] integerLiterals :: CompiledCode (Integer -> Integer) integerLiterals = @@ -39,7 +41,8 @@ integerLiterals = ~bigLazy = 98765432109876543210 ~bigNegLazy = -99887766554433221100 ~bigDoubleNegLazy = -(-24680135792468013579) - in x PlutusTx.* smallStrict + in x + PlutusTx.* smallStrict PlutusTx.+ smallNegStrict PlutusTx.+ bigStrict PlutusTx.+ bigNegStrict diff --git a/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NoNegativeLiterals/Spec.hs b/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NoNegativeLiterals/Spec.hs index 0ec5f8062ef..a5218009b12 100644 --- a/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NoNegativeLiterals/Spec.hs +++ b/plutus-tx-plugin/test/IntegerLiterals/NoStrict/NoNegativeLiterals/Spec.hs @@ -1,14 +1,14 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} - {-# LANGUAGE NoNegativeLiterals #-} {-# LANGUAGE NoStrict #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| This module tests that integer literals are handled correctly when both @Strict@ +and @NegativeLiterals@ are off. These two extensions affect the Core we get. --- | This module tests that integer literals are handled correctly when both @Strict@ --- and @NegativeLiterals@ are off. These two extensions affect the Core we get. --- --- See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. +See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. +-} module IntegerLiterals.NoStrict.NoNegativeLiterals.Spec where import PlutusTx.Code @@ -19,9 +19,11 @@ import PlutusTx.TH (compile) import Test.Tasty.Extras tests :: TestNested -tests = testNested "IntegerLiterals" . pure $ testNestedGhc - [ goldenPirReadable "integerLiterals-NoStrict-NoNegativeLiterals" integerLiterals - ] +tests = + testNested "IntegerLiterals" . pure $ + testNestedGhc + [ goldenPirReadable "integerLiterals-NoStrict-NoNegativeLiterals" integerLiterals + ] integerLiterals :: CompiledCode (Integer -> Integer) integerLiterals = @@ -38,7 +40,8 @@ integerLiterals = ~bigLazy = 98765432109876543210 ~bigNegLazy = -99887766554433221100 ~bigDoubleNegLazy = -(-24680135792468013579) - in x PlutusTx.* smallStrict + in x + PlutusTx.* smallStrict PlutusTx.+ smallNegStrict PlutusTx.+ bigStrict PlutusTx.+ bigNegStrict diff --git a/plutus-tx-plugin/test/IntegerLiterals/Strict/NegativeLiterals/Spec.hs b/plutus-tx-plugin/test/IntegerLiterals/Strict/NegativeLiterals/Spec.hs index dd244b2e314..fa310482ce8 100644 --- a/plutus-tx-plugin/test/IntegerLiterals/Strict/NegativeLiterals/Spec.hs +++ b/plutus-tx-plugin/test/IntegerLiterals/Strict/NegativeLiterals/Spec.hs @@ -1,15 +1,15 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} - {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| This module tests that integer literals are handled correctly when both +@Strict@ and @NegativeLiterals@ are on. These two extensions affect the Core +we get. When @NegativeLiterals@ is on, we can get @IN@ for negative integers. --- | This module tests that integer literals are handled correctly when both --- @Strict@ and @NegativeLiterals@ are on. These two extensions affect the Core --- we get. When @NegativeLiterals@ is on, we can get @IN@ for negative integers. --- --- See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. +See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. +-} module IntegerLiterals.Strict.NegativeLiterals.Spec where import PlutusTx.Code @@ -20,9 +20,11 @@ import PlutusTx.TH (compile) import Test.Tasty.Extras tests :: TestNested -tests = testNested "IntegerLiterals" . pure $ testNestedGhc - [ goldenPirReadable "integerLiterals-Strict-NegativeLiterals" integerLiterals - ] +tests = + testNested "IntegerLiterals" . pure $ + testNestedGhc + [ goldenPirReadable "integerLiterals-Strict-NegativeLiterals" integerLiterals + ] integerLiterals :: CompiledCode (Integer -> Integer) integerLiterals = @@ -39,7 +41,8 @@ integerLiterals = ~bigLazy = 98765432109876543210 ~bigNegLazy = -99887766554433221100 ~bigDoubleNegLazy = -(-24680135792468013579) - in x PlutusTx.* smallStrict + in x + PlutusTx.* smallStrict PlutusTx.+ smallNegStrict PlutusTx.+ bigStrict PlutusTx.+ bigNegStrict diff --git a/plutus-tx-plugin/test/IntegerLiterals/Strict/NoNegativeLiterals/Spec.hs b/plutus-tx-plugin/test/IntegerLiterals/Strict/NoNegativeLiterals/Spec.hs index c6b5b82d8e6..296fd11eb70 100644 --- a/plutus-tx-plugin/test/IntegerLiterals/Strict/NoNegativeLiterals/Spec.hs +++ b/plutus-tx-plugin/test/IntegerLiterals/Strict/NoNegativeLiterals/Spec.hs @@ -1,14 +1,14 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} - {-# LANGUAGE NoNegativeLiterals #-} {-# LANGUAGE Strict #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| This module tests that integer literals are handled correctly when @Strict@ is on +and @NegativeLiterals@ is off. These two extensions affect the Core we get. --- | This module tests that integer literals are handled correctly when @Strict@ is on --- and @NegativeLiterals@ is off. These two extensions affect the Core we get. --- --- See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. +See Note [Running PIR and UPLC Simplifiers in Integer Literal Tests]. +-} module IntegerLiterals.Strict.NoNegativeLiterals.Spec where import PlutusTx.Code @@ -19,9 +19,11 @@ import PlutusTx.TH (compile) import Test.Tasty.Extras tests :: TestNested -tests = testNested "IntegerLiterals" . pure $ testNestedGhc - [ goldenPirReadable "integerLiterals-Strict-NoNegativeLiterals" integerLiterals - ] +tests = + testNested "IntegerLiterals" . pure $ + testNestedGhc + [ goldenPirReadable "integerLiterals-Strict-NoNegativeLiterals" integerLiterals + ] integerLiterals :: CompiledCode (Integer -> Integer) integerLiterals = @@ -38,7 +40,8 @@ integerLiterals = ~bigLazy = 98765432109876543210 ~bigNegLazy = -99887766554433221100 ~bigDoubleNegLazy = -(-24680135792468013579) - in x PlutusTx.* smallStrict + in x + PlutusTx.* smallStrict PlutusTx.+ smallNegStrict PlutusTx.+ bigStrict PlutusTx.+ bigNegStrict diff --git a/plutus-tx-plugin/test/IsData/Spec.hs b/plutus-tx-plugin/test/IsData/Spec.hs index 4be174dac3e..28fb8fcc1f0 100644 --- a/plutus-tx-plugin/test/IsData/Spec.hs +++ b/plutus-tx-plugin/test/IsData/Spec.hs @@ -10,14 +10,14 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} module IsData.Spec where @@ -44,19 +44,19 @@ IsData.unstableMakeIsData ''MyMonoData IsData.unstableMakeIsData ''MyMonoRecord IsData.unstableMakeIsData ''MyPolyData -data NestedRecord = NestedRecord { unNested :: Maybe (Integer, Integer) } +data NestedRecord = NestedRecord {unNested :: Maybe (Integer, Integer)} IsData.unstableMakeIsData ''NestedRecord instance P.Eq NestedRecord where - {-# INLINABLE (==) #-} - (NestedRecord i1) == (NestedRecord i2) = i1 P.== i2 + {-# INLINEABLE (==) #-} + (NestedRecord i1) == (NestedRecord i2) = i1 P.== i2 -data WrappedBS = WrappedBS { unWrap :: Builtins.BuiltinByteString } +data WrappedBS = WrappedBS {unWrap :: Builtins.BuiltinByteString} IsData.unstableMakeIsData ''WrappedBS instance P.Eq WrappedBS where - {-# INLINABLE (==) #-} - (WrappedBS i1) == (WrappedBS i2) = i1 P.== i2 + {-# INLINEABLE (==) #-} + (WrappedBS i1) == (WrappedBS i2) = i1 P.== i2 deconstructData :: CompiledCode (Builtins.BuiltinData -> Maybe (Integer, Integer)) deconstructData = plc (Proxy @"deconstructData4") (\(d :: Builtins.BuiltinData) -> IsData.fromBuiltinData d) @@ -64,45 +64,54 @@ deconstructData = plc (Proxy @"deconstructData4") (\(d :: Builtins.BuiltinData) unsafeDeconstructData :: CompiledCode (Builtins.BuiltinData -> Maybe (Integer, Integer)) unsafeDeconstructData = plc (Proxy @"deconstructData4") (\(d :: Builtins.BuiltinData) -> IsData.unsafeFromBuiltinData d) -isDataRoundtrip :: (IsData.FromData a, IsData.UnsafeFromData a, IsData.ToData a, P.Eq a) => a -> Bool +isDataRoundtrip + :: (IsData.FromData a, IsData.UnsafeFromData a, IsData.ToData a, P.Eq a) => a -> Bool isDataRoundtrip a = - let d = IsData.toBuiltinData a - safeRoundtrip = case IsData.fromBuiltinData d of - Just a' -> a P.== a' - Nothing -> False - unsafeRoundtrip = IsData.unsafeFromBuiltinData d P.== a - in safeRoundtrip && unsafeRoundtrip -{-# INLINABLE isDataRoundtrip #-} - -AsData.asData [d| - data SecretlyData = FirstC () | SecondC Integer - deriving newtype (P.Eq, IsData.FromData, IsData.UnsafeFromData, IsData.ToData) - |] - -AsData.asData [d| - data RecordConstructor a = RecordConstructor { x :: a, y :: Integer } - |] - -AsData.asData [d| - data MaybeD a = JustD a | NothingD - |] + let d = IsData.toBuiltinData a + safeRoundtrip = case IsData.fromBuiltinData d of + Just a' -> a P.== a' + Nothing -> False + unsafeRoundtrip = IsData.unsafeFromBuiltinData d P.== a + in safeRoundtrip && unsafeRoundtrip +{-# INLINEABLE isDataRoundtrip #-} + +AsData.asData + [d| + data SecretlyData = FirstC () | SecondC Integer + deriving newtype (P.Eq, IsData.FromData, IsData.UnsafeFromData, IsData.ToData) + |] + +AsData.asData + [d| + data RecordConstructor a = RecordConstructor {x :: a, y :: Integer} + |] + +AsData.asData + [d| + data MaybeD a = JustD a | NothingD + |] -- Features a nested field which is also defined with AsData matchAsData :: CompiledCode (MaybeD SecretlyData -> SecretlyData) -matchAsData = plc (Proxy @"matchAsData") ( - \case - JustD a -> a - NothingD -> FirstC ()) +matchAsData = + plc + (Proxy @"matchAsData") + ( \case + JustD a -> a + NothingD -> FirstC () + ) recordAsData :: CompiledCode (RecordConstructor Integer) recordAsData = plc (Proxy @"recordAsData") (RecordConstructor 1 2) dataToData :: CompiledCode (RecordConstructor Integer -> SecretlyData) -dataToData = plc (Proxy @"dataToData") - (\case - RecordConstructor a b | a P.== 3, b P.== 4 -> SecondC (Builtins.addInteger a b) - _ -> FirstC () - ) +dataToData = + plc + (Proxy @"dataToData") + ( \case + RecordConstructor a b | a P.== 3, b P.== 4 -> SecondC (Builtins.addInteger a b) + _ -> FirstC () + ) -- Should ultimately use equalsData equalityAsData :: CompiledCode (SecretlyData -> SecretlyData -> Bool) @@ -112,31 +121,54 @@ fieldAccessor :: CompiledCode (RecordConstructor Integer -> Integer) fieldAccessor = plc (Proxy @"fieldAccessor") (\r -> x r) tests :: TestNested -tests = testNested "IsData" . pure $ testNestedGhc - [ goldenUEval "int" [plc (Proxy @"int") (isDataRoundtrip (1::Integer))] - , goldenUEval "tuple" [plc (Proxy @"tuple") (isDataRoundtrip (1::Integer, 2::Integer))] - , goldenUEval "tupleInterop" [ - getPlcNoAnn (plc (Proxy @"tupleInterop") (\(d :: P.BuiltinData) -> case IsData.fromBuiltinData d of { Just t -> t P.== (1::Integer, 2::Integer); Nothing -> False})) - , UPLC.Program () (PLC.latestVersion) (PLC.mkConstant () (IsData.toData (1::Integer, 2::Integer)))] - , goldenUEval "unsafeTupleInterop" [ - getPlcNoAnn (plc (Proxy @"unsafeTupleInterop") (\(d :: P.BuiltinData) -> IsData.unsafeFromBuiltinData d P.== (1::Integer, 2::Integer))) - , UPLC.Program () (PLC.latestVersion) (PLC.mkConstant () (IsData.toData (1::Integer, 2::Integer)))] - , goldenUEval "unit" [plc (Proxy @"unit") (isDataRoundtrip ())] - , goldenUEval "unitInterop" [ - getPlcNoAnn (plc (Proxy @"unitInterop") (\(d :: P.BuiltinData) -> case IsData.fromBuiltinData d of { Just t -> t P.== (); Nothing -> False})) - , UPLC.Program () (PLC.latestVersion) (PLC.mkConstant () (IsData.toData ()))] - , goldenUEval "mono" [plc (Proxy @"mono") (isDataRoundtrip (Mono2 2))] - , goldenUEval "poly" [plc (Proxy @"poly") (isDataRoundtrip (Poly1 (1::Integer) (2::Integer)))] - , goldenUEval "record" [plc (Proxy @"record") (isDataRoundtrip (MyMonoRecord 1 2))] - , goldenUEval "list" [plc (Proxy @"list") (isDataRoundtrip ([1]::[Integer]))] - , goldenUEval "nested" [plc (Proxy @"nested") (isDataRoundtrip (NestedRecord (Just (1, 2))))] - , goldenUEval "bytestring" [plc (Proxy @"bytestring") (isDataRoundtrip (WrappedBS Builtins.emptyByteString))] - , goldenPirReadable "deconstructData" deconstructData - , goldenPirReadable "unsafeDeconstructData" unsafeDeconstructData - , goldenPirReadable "matchAsData" matchAsData - , goldenUEval "matchAsDataE" [toUPlc $ matchAsData, toUPlc $ plc (Proxy @"test") (SecondC 3)] - , goldenPirReadable "recordAsData" recordAsData - , goldenPirReadable "dataToData" dataToData - , goldenPirReadable "equalityAsData" equalityAsData - , goldenPirReadable "fieldAccessor" fieldAccessor - ] +tests = + testNested "IsData" . pure $ + testNestedGhc + [ goldenUEval "int" [plc (Proxy @"int") (isDataRoundtrip (1 :: Integer))] + , goldenUEval "tuple" [plc (Proxy @"tuple") (isDataRoundtrip (1 :: Integer, 2 :: Integer))] + , goldenUEval + "tupleInterop" + [ getPlcNoAnn + ( plc + (Proxy @"tupleInterop") + ( \(d :: P.BuiltinData) -> case IsData.fromBuiltinData d of Just t -> t P.== (1 :: Integer, 2 :: Integer); Nothing -> False + ) + ) + , UPLC.Program () (PLC.latestVersion) (PLC.mkConstant () (IsData.toData (1 :: Integer, 2 :: Integer))) + ] + , goldenUEval + "unsafeTupleInterop" + [ getPlcNoAnn + ( plc + (Proxy @"unsafeTupleInterop") + (\(d :: P.BuiltinData) -> IsData.unsafeFromBuiltinData d P.== (1 :: Integer, 2 :: Integer)) + ) + , UPLC.Program () (PLC.latestVersion) (PLC.mkConstant () (IsData.toData (1 :: Integer, 2 :: Integer))) + ] + , goldenUEval "unit" [plc (Proxy @"unit") (isDataRoundtrip ())] + , goldenUEval + "unitInterop" + [ getPlcNoAnn + ( plc + (Proxy @"unitInterop") + (\(d :: P.BuiltinData) -> case IsData.fromBuiltinData d of Just t -> t P.== (); Nothing -> False) + ) + , UPLC.Program () (PLC.latestVersion) (PLC.mkConstant () (IsData.toData ())) + ] + , goldenUEval "mono" [plc (Proxy @"mono") (isDataRoundtrip (Mono2 2))] + , goldenUEval "poly" [plc (Proxy @"poly") (isDataRoundtrip (Poly1 (1 :: Integer) (2 :: Integer)))] + , goldenUEval "record" [plc (Proxy @"record") (isDataRoundtrip (MyMonoRecord 1 2))] + , goldenUEval "list" [plc (Proxy @"list") (isDataRoundtrip ([1] :: [Integer]))] + , goldenUEval "nested" [plc (Proxy @"nested") (isDataRoundtrip (NestedRecord (Just (1, 2))))] + , goldenUEval + "bytestring" + [plc (Proxy @"bytestring") (isDataRoundtrip (WrappedBS Builtins.emptyByteString))] + , goldenPirReadable "deconstructData" deconstructData + , goldenPirReadable "unsafeDeconstructData" unsafeDeconstructData + , goldenPirReadable "matchAsData" matchAsData + , goldenUEval "matchAsDataE" [toUPlc $ matchAsData, toUPlc $ plc (Proxy @"test") (SecondC 3)] + , goldenPirReadable "recordAsData" recordAsData + , goldenPirReadable "dataToData" dataToData + , goldenPirReadable "equalityAsData" equalityAsData + , goldenPirReadable "fieldAccessor" fieldAccessor + ] diff --git a/plutus-tx-plugin/test/Lift/Spec.hs b/plutus-tx-plugin/test/Lift/Spec.hs index 39f97e079b1..c6d382e95fe 100644 --- a/plutus-tx-plugin/test/Lift/Spec.hs +++ b/plutus-tx-plugin/test/Lift/Spec.hs @@ -5,7 +5,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} + module Lift.Spec where import Test.Tasty.Extras @@ -23,19 +24,19 @@ Lift.makeLift ''MyMonoData Lift.makeLift ''MyMonoRecord Lift.makeLift ''MyPolyData -data NestedRecord = NestedRecord { unNested :: Maybe (Integer, Integer) } +data NestedRecord = NestedRecord {unNested :: Maybe (Integer, Integer)} Lift.makeLift ''NestedRecord -data WrappedBS = WrappedBS { unWrap :: Builtins.BuiltinByteString } +data WrappedBS = WrappedBS {unWrap :: Builtins.BuiltinByteString} Lift.makeLift ''WrappedBS -newtype NewtypeInt = NewtypeInt { unNt :: Integer } +newtype NewtypeInt = NewtypeInt {unNt :: Integer} Lift.makeLift ''NewtypeInt -newtype Newtype2 = Newtype2 { unNt2 :: NewtypeInt } +newtype Newtype2 = Newtype2 {unNt2 :: NewtypeInt} Lift.makeLift ''Newtype2 -newtype Newtype3 = Newtype3 { unNt3 :: Newtype2 } +newtype Newtype3 = Newtype3 {unNt3 :: Newtype2} Lift.makeLift ''Newtype3 -- 'Z' so it sorts late and this doesn't work by accident @@ -43,25 +44,31 @@ data Z = Z Integer Lift.makeLift ''Z type Syn = Z -data SynExample = SynExample { unSE :: Syn } +data SynExample = SynExample {unSE :: Syn} Lift.makeLift ''SynExample tests :: TestNested -tests = testNested "Lift" . pure $ testNestedGhc - [ goldenUPlc "int" (snd (Lift.liftProgramDef (1::Integer))) - , goldenUPlc "tuple" (snd (Lift.liftProgramDef (1::Integer, 2::Integer))) - , goldenUPlc "mono" (snd (Lift.liftProgramDef (Mono2 2))) - , goldenUEval "monoInterop" [ getPlcNoAnn monoCase, snd (Lift.liftProgramDef (Mono1 1 2)) ] - , goldenUPlc "poly" (snd (Lift.liftProgramDef (Poly1 (1::Integer) (2::Integer)))) - , goldenUEval "polyInterop" [ getPlcNoAnn defaultCasePoly, snd (Lift.liftProgramDef (Poly1 (1::Integer) (2::Integer))) ] - , goldenUPlc "record" (snd (Lift.liftProgramDef (MyMonoRecord 1 2))) - , goldenUEval "boolInterop" [ getPlcNoAnn andPlc, snd (Lift.liftProgramDef True), snd (Lift.liftProgramDef True) ] - , goldenUPlc "list" (snd (Lift.liftProgramDef ([1]::[Integer]))) - , goldenUEval "listInterop" [ getPlcNoAnn listMatch, snd (Lift.liftProgramDef ([1]::[Integer])) ] - , goldenUPlc "nested" (snd (Lift.liftProgramDef (NestedRecord (Just (1, 2))))) - , goldenUPlc "bytestring" (snd (Lift.liftProgramDef (WrappedBS "hello"))) - , goldenUPlc "newtypeInt" (snd (Lift.liftProgramDef (NewtypeInt 1))) - , goldenUPlc "newtypeInt2" (snd (Lift.liftProgramDef (Newtype2 $ NewtypeInt 1))) - , goldenUPlc "newtypeInt3" (snd (Lift.liftProgramDef (Newtype3 $ Newtype2 $ NewtypeInt 1))) - , goldenUPlc "syn" (snd (Lift.liftProgramDef (SynExample $ Z $ 1))) - ] +tests = + testNested "Lift" . pure $ + testNestedGhc + [ goldenUPlc "int" (snd (Lift.liftProgramDef (1 :: Integer))) + , goldenUPlc "tuple" (snd (Lift.liftProgramDef (1 :: Integer, 2 :: Integer))) + , goldenUPlc "mono" (snd (Lift.liftProgramDef (Mono2 2))) + , goldenUEval "monoInterop" [getPlcNoAnn monoCase, snd (Lift.liftProgramDef (Mono1 1 2))] + , goldenUPlc "poly" (snd (Lift.liftProgramDef (Poly1 (1 :: Integer) (2 :: Integer)))) + , goldenUEval + "polyInterop" + [getPlcNoAnn defaultCasePoly, snd (Lift.liftProgramDef (Poly1 (1 :: Integer) (2 :: Integer)))] + , goldenUPlc "record" (snd (Lift.liftProgramDef (MyMonoRecord 1 2))) + , goldenUEval + "boolInterop" + [getPlcNoAnn andPlc, snd (Lift.liftProgramDef True), snd (Lift.liftProgramDef True)] + , goldenUPlc "list" (snd (Lift.liftProgramDef ([1] :: [Integer]))) + , goldenUEval "listInterop" [getPlcNoAnn listMatch, snd (Lift.liftProgramDef ([1] :: [Integer]))] + , goldenUPlc "nested" (snd (Lift.liftProgramDef (NestedRecord (Just (1, 2))))) + , goldenUPlc "bytestring" (snd (Lift.liftProgramDef (WrappedBS "hello"))) + , goldenUPlc "newtypeInt" (snd (Lift.liftProgramDef (NewtypeInt 1))) + , goldenUPlc "newtypeInt2" (snd (Lift.liftProgramDef (Newtype2 $ NewtypeInt 1))) + , goldenUPlc "newtypeInt3" (snd (Lift.liftProgramDef (Newtype3 $ Newtype2 $ NewtypeInt 1))) + , goldenUPlc "syn" (snd (Lift.liftProgramDef (SynExample $ Z $ 1))) + ] diff --git a/plutus-tx-plugin/test/List/Properties1.hs b/plutus-tx-plugin/test/List/Properties1.hs index a2304178183..637a4f15813 100644 --- a/plutus-tx-plugin/test/List/Properties1.hs +++ b/plutus-tx-plugin/test/List/Properties1.hs @@ -1,7 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-} @@ -9,13 +11,12 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -- CSE is very unstable and produces different output, likely depending on the version of either -- @unordered-containers@ or @hashable@. {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + {-# HLINT ignore "Use elemIndex" #-} module List.Properties1 where @@ -39,10 +40,10 @@ import Hedgehog.Gen qualified as Gen import List.Semantics toSOPProgram :: CompiledCode (Data.List Integer -> [Integer]) -toSOPProgram = $$(compile [|| Data.List.toSOP ||]) +toSOPProgram = $$(compile [||Data.List.toSOP||]) fromSOPProgram :: CompiledCode ([Integer] -> Data.List Integer) -fromSOPProgram = $$(compile [|| Data.List.fromSOP ||]) +fromSOPProgram = $$(compile [||Data.List.fromSOP||]) toSOPSpec :: Property toSOPSpec = property $ do @@ -50,9 +51,9 @@ toSOPSpec = property $ do let list = semanticsToDataList listS expected = semanticsToList listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ toSOPProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + toSOPProgram + `unsafeApplyCode` liftCodeDef list ) (===) expected @@ -63,18 +64,18 @@ fromSOPSpec = property $ do let list = semanticsToList listS expected = semanticsToDataList listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ fromSOPProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + fromSOPProgram + `unsafeApplyCode` liftCodeDef list ) (===) expected appendProgram :: CompiledCode ([Integer] -> [Integer] -> [Integer]) -appendProgram = $$(compile [|| (List.++) ||]) +appendProgram = $$(compile [||(List.++)||]) dataAppendProgram :: CompiledCode (Data.List Integer -> Data.List Integer -> Data.List Integer) -dataAppendProgram = $$(compile [|| Data.List.append ||]) +dataAppendProgram = $$(compile [||Data.List.append||]) appendSpec :: Property appendSpec = property $ do @@ -86,27 +87,27 @@ appendSpec = property $ do dataList2 = semanticsToDataList listS2 expected = appendS listS1 listS2 cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ appendProgram - `unsafeApplyCode` liftCodeDef list1 - `unsafeApplyCode` liftCodeDef list2 + ( compiledCodeToTerm $ + appendProgram + `unsafeApplyCode` liftCodeDef list1 + `unsafeApplyCode` liftCodeDef list2 ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataAppendProgram - `unsafeApplyCode` liftCodeDef dataList1 - `unsafeApplyCode` liftCodeDef dataList2 + ( compiledCodeToTerm $ + dataAppendProgram + `unsafeApplyCode` liftCodeDef dataList1 + `unsafeApplyCode` liftCodeDef dataList2 ) (===) (semanticsToDataList expected) findProgram :: CompiledCode (Integer -> [Integer] -> Maybe Integer) -findProgram = $$(compile [|| \n -> List.find (\x -> x PlutusTx.> n) ||]) +findProgram = $$(compile [||\n -> List.find (\x -> x PlutusTx.> n)||]) dataFindProgram :: CompiledCode (Integer -> Data.List Integer -> Maybe Integer) -dataFindProgram = $$(compile [|| \n -> Data.List.find (\x -> x PlutusTx.> n) ||]) +dataFindProgram = $$(compile [||\n -> Data.List.find (\x -> x PlutusTx.> n)||]) findSpec :: Property findSpec = property $ do @@ -116,27 +117,27 @@ findSpec = property $ do dataList = semanticsToDataList listS expected = findS (> num) listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ findProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + findProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataFindProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataFindProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) expected findIndicesProgram :: CompiledCode (Integer -> [Integer] -> [Integer]) -findIndicesProgram = $$(compile [|| \n -> List.findIndices (\x -> x PlutusTx.> n) ||]) +findIndicesProgram = $$(compile [||\n -> List.findIndices (\x -> x PlutusTx.> n)||]) dataFindIndicesProgram :: CompiledCode (Integer -> Data.List Integer -> Data.List Integer) -dataFindIndicesProgram = $$(compile [|| \n -> Data.List.findIndices (\x -> x PlutusTx.> n) ||]) +dataFindIndicesProgram = $$(compile [||\n -> Data.List.findIndices (\x -> x PlutusTx.> n)||]) findIndicesSpec :: Property findIndicesSpec = property $ do @@ -146,27 +147,27 @@ findIndicesSpec = property $ do dataList = semanticsToDataList listS expected = findIndicesS (> num) listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ findIndicesProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + findIndicesProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataFindIndicesProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataFindIndicesProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) filterProgram :: CompiledCode (Integer -> [Integer] -> [Integer]) -filterProgram = $$(compile [|| \n -> List.filter (\x -> x PlutusTx.> n) ||]) +filterProgram = $$(compile [||\n -> List.filter (\x -> x PlutusTx.> n)||]) dataFilterProgram :: CompiledCode (Integer -> Data.List Integer -> Data.List Integer) -dataFilterProgram = $$(compile [|| \n -> Data.List.filter (\x -> x PlutusTx.> n) ||]) +dataFilterProgram = $$(compile [||\n -> Data.List.filter (\x -> x PlutusTx.> n)||]) filterSpec :: Property filterSpec = property $ do @@ -176,35 +177,37 @@ filterSpec = property $ do dataList = semanticsToDataList listS expected = filterS (> num) listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ filterProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + filterProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataFilterProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataFilterProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) mapMaybeProgram :: CompiledCode (Integer -> [Integer] -> [Integer]) mapMaybeProgram = - $$(compile - [|| - \n -> PlutusTx.mapMaybe (\x -> if x PlutusTx.> n then Just 1 else Nothing) - ||]) + $$( compile + [|| + \n -> PlutusTx.mapMaybe (\x -> if x PlutusTx.> n then Just 1 else Nothing) + ||] + ) dataMapMaybeProgram :: CompiledCode (Integer -> Data.List Integer -> Data.List Integer) dataMapMaybeProgram = - $$(compile - [|| - \n -> Data.List.mapMaybe (\x -> if x PlutusTx.> n then Just 1 else Nothing) - ||]) + $$( compile + [|| + \n -> Data.List.mapMaybe (\x -> if x PlutusTx.> n then Just 1 else Nothing) + ||] + ) mapMaybeSpec :: Property mapMaybeSpec = property $ do @@ -215,27 +218,27 @@ mapMaybeSpec = property $ do expected :: ListS Integer expected = mapMaybeS (\x -> if x > num then Just 1 else Nothing) listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ mapMaybeProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + mapMaybeProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataMapMaybeProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataMapMaybeProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) anyProgram :: CompiledCode (Integer -> [Integer] -> Bool) -anyProgram = $$(compile [|| \n -> List.any (\x -> x PlutusTx.> n) ||]) +anyProgram = $$(compile [||\n -> List.any (\x -> x PlutusTx.> n)||]) -dataAnyProgram :: CompiledCode (Integer -> Data.List Integer -> Bool) -dataAnyProgram = $$(compile [|| \n -> Data.List.any (\x -> x PlutusTx.> n) ||]) +dataAnyProgram :: CompiledCode (Integer -> Data.List Integer -> Bool) +dataAnyProgram = $$(compile [||\n -> Data.List.any (\x -> x PlutusTx.> n)||]) anySpec :: Property anySpec = property $ do @@ -245,27 +248,27 @@ anySpec = property $ do dataList = semanticsToDataList listS expected = anyS (> num) listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ anyProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + anyProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataAnyProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataAnyProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) expected allProgram :: CompiledCode (Integer -> [Integer] -> Bool) -allProgram = $$(compile [|| \n -> List.all (\x -> x PlutusTx.> n) ||]) +allProgram = $$(compile [||\n -> List.all (\x -> x PlutusTx.> n)||]) -dataAllProgram :: CompiledCode (Integer -> Data.List Integer -> Bool) -dataAllProgram = $$(compile [|| \n -> Data.List.all (\x -> x PlutusTx.> n) ||]) +dataAllProgram :: CompiledCode (Integer -> Data.List Integer -> Bool) +dataAllProgram = $$(compile [||\n -> Data.List.all (\x -> x PlutusTx.> n)||]) allSpec :: Property allSpec = property $ do @@ -275,35 +278,37 @@ allSpec = property $ do dataList = semanticsToDataList listS expected = allS (> num) listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ allProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + allProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataAllProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataAllProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) expected foldMapProgram :: CompiledCode (Integer -> [Integer] -> Maybe [Integer]) foldMapProgram = - $$(compile - [|| - \n -> F.foldMap (\x -> if x PlutusTx.> n then Just [x] else Nothing) - ||]) + $$( compile + [|| + \n -> F.foldMap (\x -> if x PlutusTx.> n then Just [x] else Nothing) + ||] + ) dataFoldMapProgram :: CompiledCode (Integer -> Data.List Integer -> Maybe [Integer]) dataFoldMapProgram = - $$(compile - [|| - \n -> Data.List.foldMap (\x -> if x PlutusTx.> n then Just [x] else Nothing) - ||]) + $$( compile + [|| + \n -> Data.List.foldMap (\x -> if x PlutusTx.> n then Just [x] else Nothing) + ||] + ) foldMapSpec :: Property foldMapSpec = property $ do @@ -313,27 +318,27 @@ foldMapSpec = property $ do dataList = semanticsToDataList listS expected = foldMapS (\x -> if x > num then Just [x] else Nothing) listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ foldMapProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + foldMapProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataFoldMapProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataFoldMapProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) expected mapProgram :: CompiledCode (Integer -> [Integer] -> [Integer]) -mapProgram = $$(compile [|| \n -> List.map (\x -> x PlutusTx.+ n) ||]) +mapProgram = $$(compile [||\n -> List.map (\x -> x PlutusTx.+ n)||]) dataMapProgram :: CompiledCode (Integer -> Data.List Integer -> Data.List Integer) -dataMapProgram = $$(compile [|| \n -> Data.List.map (\x -> x PlutusTx.+ n) ||]) +dataMapProgram = $$(compile [||\n -> Data.List.map (\x -> x PlutusTx.+ n)||]) mapSpec :: Property mapSpec = property $ do @@ -343,27 +348,27 @@ mapSpec = property $ do dataList = semanticsToDataList listS expected = mapS (+ num) listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ mapProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + mapProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataMapProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataMapProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) lengthProgram :: CompiledCode ([Integer] -> Integer) -lengthProgram = $$(compile [|| List.length ||]) +lengthProgram = $$(compile [||List.length||]) dataLengthProgram :: CompiledCode (Data.List Integer -> Integer) -dataLengthProgram = $$(compile [|| Data.List.length ||]) +dataLengthProgram = $$(compile [||Data.List.length||]) lengthSpec :: Property lengthSpec = property $ do @@ -372,25 +377,25 @@ lengthSpec = property $ do dataList = semanticsToDataList listS expected = lengthS listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ lengthProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + lengthProgram + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataLengthProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataLengthProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) expected unconsProgram :: CompiledCode ([Integer] -> Maybe (Integer, [Integer])) -unconsProgram = $$(compile [|| List.uncons ||]) +unconsProgram = $$(compile [||List.uncons||]) dataUnconsProgram :: CompiledCode (Data.List Integer -> Maybe (Integer, Data.List Integer)) -dataUnconsProgram = $$(compile [|| Data.List.uncons ||]) +dataUnconsProgram = $$(compile [||Data.List.uncons||]) unconsSpec :: Property unconsSpec = property $ do @@ -399,25 +404,25 @@ unconsSpec = property $ do dataList = semanticsToDataList listS expected = unconsS listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ unconsProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + unconsProgram + `unsafeApplyCode` liftCodeDef list ) (===) ((fmap . fmap) semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataUnconsProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataUnconsProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) ((fmap . fmap) semanticsToDataList expected) andProgram :: CompiledCode ([Bool] -> Bool) -andProgram = $$(compile [|| List.and ||]) +andProgram = $$(compile [||List.and||]) dataAndProgram :: CompiledCode (Data.List Bool -> Bool) -dataAndProgram = $$(compile [|| Data.List.and ||]) +dataAndProgram = $$(compile [||Data.List.and||]) andSpec :: Property andSpec = property $ do @@ -426,25 +431,25 @@ andSpec = property $ do dataList = semanticsToDataList listS expected = andS listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ andProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + andProgram + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataAndProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataAndProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) expected orProgram :: CompiledCode ([Bool] -> Bool) -orProgram = $$(compile [|| List.or ||]) +orProgram = $$(compile [||List.or||]) dataOrProgram :: CompiledCode (Data.List Bool -> Bool) -dataOrProgram = $$(compile [|| Data.List.or ||]) +dataOrProgram = $$(compile [||Data.List.or||]) orSpec :: Property orSpec = property $ do @@ -453,25 +458,25 @@ orSpec = property $ do dataList = semanticsToDataList listS expected = Haskell.or list cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ orProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + orProgram + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataOrProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataOrProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) expected elemProgram :: CompiledCode (Integer -> [Integer] -> Bool) -elemProgram = $$(compile [|| List.elem ||]) +elemProgram = $$(compile [||List.elem||]) dataElemProgram :: CompiledCode (Integer -> Data.List Integer -> Bool) -dataElemProgram = $$(compile [|| Data.List.elem ||]) +dataElemProgram = $$(compile [||Data.List.elem||]) elemSpec :: Property elemSpec = property $ do @@ -481,27 +486,27 @@ elemSpec = property $ do dataList = semanticsToDataList listS expected = elemS num listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ elemProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + elemProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataElemProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataElemProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) expected notElemProgram :: CompiledCode (Integer -> [Integer] -> Bool) -notElemProgram = $$(compile [|| List.notElem ||]) +notElemProgram = $$(compile [||List.notElem||]) dataNotElemProgram :: CompiledCode (Integer -> Data.List Integer -> Bool) -dataNotElemProgram = $$(compile [|| Data.List.notElem ||]) +dataNotElemProgram = $$(compile [||Data.List.notElem||]) notElemSpec :: Property notElemSpec = property $ do @@ -511,27 +516,27 @@ notElemSpec = property $ do dataList = semanticsToDataList listS expected = notElemS num listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ notElemProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + notElemProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataNotElemProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataNotElemProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) expected foldrProgram :: CompiledCode (Integer -> [Integer] -> Integer) -foldrProgram = $$(compile [|| List.foldr B.subtractInteger ||]) +foldrProgram = $$(compile [||List.foldr B.subtractInteger||]) dataFoldrProgram :: CompiledCode (Integer -> Data.List Integer -> Integer) -dataFoldrProgram = $$(compile [|| Data.List.foldr B.subtractInteger ||]) +dataFoldrProgram = $$(compile [||Data.List.foldr B.subtractInteger||]) foldrSpec :: Property foldrSpec = property $ do @@ -541,27 +546,27 @@ foldrSpec = property $ do dataList = semanticsToDataList listS expected = foldrS (-) num listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ foldrProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + foldrProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataFoldrProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataFoldrProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) expected foldlProgram :: CompiledCode (Integer -> [Integer] -> Integer) -foldlProgram = $$(compile [|| List.foldl B.subtractInteger ||]) +foldlProgram = $$(compile [||List.foldl B.subtractInteger||]) dataFoldlProgram :: CompiledCode (Integer -> Data.List Integer -> Integer) -dataFoldlProgram = $$(compile [|| Data.List.foldl B.subtractInteger ||]) +dataFoldlProgram = $$(compile [||Data.List.foldl B.subtractInteger||]) foldlSpec :: Property foldlSpec = property $ do @@ -571,27 +576,27 @@ foldlSpec = property $ do dataList = semanticsToDataList listS expected = foldlS (-) num listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ foldlProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + foldlProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataFoldlProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataFoldlProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) expected concatProgram :: CompiledCode ([[Integer]] -> [Integer]) -concatProgram = $$(compile [|| List.concat ||]) +concatProgram = $$(compile [||List.concat||]) dataConcatProgram :: CompiledCode (Data.List (Data.List Integer) -> Data.List Integer) -dataConcatProgram = $$(compile [|| Data.List.concat ||]) +dataConcatProgram = $$(compile [||Data.List.concat||]) concatSpec :: Property concatSpec = property $ do @@ -600,25 +605,25 @@ concatSpec = property $ do dataList = semanticsToDataList $ mapS semanticsToDataList listS expected = concatS listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ concatProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + concatProgram + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataConcatProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataConcatProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) concatMapProgram :: CompiledCode (Integer -> [Integer] -> [Integer]) -concatMapProgram = $$(compile [|| \n -> List.concatMap (List.replicate n) ||]) +concatMapProgram = $$(compile [||\n -> List.concatMap (List.replicate n)||]) dataConcatMapProgram :: CompiledCode (Integer -> Data.List Integer -> Data.List Integer) -dataConcatMapProgram = $$(compile [|| \n -> Data.List.concatMap (Data.List.replicate n) ||]) +dataConcatMapProgram = $$(compile [||\n -> Data.List.concatMap (Data.List.replicate n)||]) concatMapSpec :: Property concatMapSpec = property $ do @@ -628,18 +633,18 @@ concatMapSpec = property $ do dataList = semanticsToDataList listS expected = concatMapS (replicateS num) listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ concatMapProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + concatMapProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataConcatMapProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataConcatMapProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) diff --git a/plutus-tx-plugin/test/List/Properties2.hs b/plutus-tx-plugin/test/List/Properties2.hs index abbcc0af65a..c8bdace83af 100644 --- a/plutus-tx-plugin/test/List/Properties2.hs +++ b/plutus-tx-plugin/test/List/Properties2.hs @@ -1,8 +1,9 @@ - {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE OverloadedStrings #-} @@ -10,13 +11,12 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -- CSE is very unstable and produces different output, likely depending on the version of either -- @unordered-containers@ or @hashable@. {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MonoLocalBinds #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + {-# HLINT ignore "Use elemIndex" #-} module List.Properties2 where @@ -37,10 +37,10 @@ import Hedgehog.Range qualified as Range import List.Semantics listToMaybeProgram :: CompiledCode ([Integer] -> Maybe Integer) -listToMaybeProgram = $$(compile [|| List.listToMaybe ||]) +listToMaybeProgram = $$(compile [||List.listToMaybe||]) dataListToMaybeProgram :: CompiledCode (Data.List Integer -> Maybe Integer) -dataListToMaybeProgram = $$(compile [|| Data.List.listToMaybe ||]) +dataListToMaybeProgram = $$(compile [||Data.List.listToMaybe||]) listToMaybeSpec :: Property listToMaybeSpec = property $ do @@ -49,25 +49,25 @@ listToMaybeSpec = property $ do dataList = semanticsToDataList listS expected = listToMaybeS listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ listToMaybeProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + listToMaybeProgram + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataListToMaybeProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataListToMaybeProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) expected uniqueElementProgram :: CompiledCode ([Integer] -> Maybe Integer) -uniqueElementProgram = $$(compile [|| List.uniqueElement ||]) +uniqueElementProgram = $$(compile [||List.uniqueElement||]) dataUniqueElementProgram :: CompiledCode (Data.List Integer -> Maybe Integer) -dataUniqueElementProgram = $$(compile [|| Data.List.uniqueElement ||]) +dataUniqueElementProgram = $$(compile [||Data.List.uniqueElement||]) uniqueElementSpec :: Property uniqueElementSpec = property $ do @@ -76,26 +76,25 @@ uniqueElementSpec = property $ do dataList = semanticsToDataList listS expected = uniqueElementS listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ uniqueElementProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + uniqueElementProgram + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataUniqueElementProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataUniqueElementProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) expected - indexProgram :: CompiledCode ([Integer] -> Integer -> Integer) -indexProgram = $$(compile [|| \l i -> l List.!! i ||]) +indexProgram = $$(compile [||\l i -> l List.!! i||]) dataIndexProgram :: CompiledCode (Data.List Integer -> Integer -> Integer) -dataIndexProgram = $$(compile [|| \l i -> l Data.List.!! i ||]) +dataIndexProgram = $$(compile [||\l i -> l Data.List.!! i||]) indexSpec :: Property indexSpec = property $ do @@ -105,27 +104,27 @@ indexSpec = property $ do dataList = semanticsToDataList listS expected = indexS listS num cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ indexProgram - `unsafeApplyCode` liftCodeDef list - `unsafeApplyCode` liftCodeDef num + ( compiledCodeToTerm $ + indexProgram + `unsafeApplyCode` liftCodeDef list + `unsafeApplyCode` liftCodeDef num ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataIndexProgram - `unsafeApplyCode` liftCodeDef dataList - `unsafeApplyCode` liftCodeDef num + ( compiledCodeToTerm $ + dataIndexProgram + `unsafeApplyCode` liftCodeDef dataList + `unsafeApplyCode` liftCodeDef num ) (===) expected revAppendProgram :: CompiledCode ([Integer] -> [Integer] -> [Integer]) -revAppendProgram = $$(compile [|| List.revAppend ||]) +revAppendProgram = $$(compile [||List.revAppend||]) dataRevAppendProgram :: CompiledCode (Data.List Integer -> Data.List Integer -> Data.List Integer) -dataRevAppendProgram = $$(compile [|| Data.List.revAppend ||]) +dataRevAppendProgram = $$(compile [||Data.List.revAppend||]) revAppendSpec :: Property revAppendSpec = property $ do @@ -137,27 +136,27 @@ revAppendSpec = property $ do dataList2 = semanticsToDataList listS2 expected = revAppendS listS1 listS2 cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ revAppendProgram - `unsafeApplyCode` liftCodeDef list1 - `unsafeApplyCode` liftCodeDef list2 + ( compiledCodeToTerm $ + revAppendProgram + `unsafeApplyCode` liftCodeDef list1 + `unsafeApplyCode` liftCodeDef list2 ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataRevAppendProgram - `unsafeApplyCode` liftCodeDef dataList1 - `unsafeApplyCode` liftCodeDef dataList2 + ( compiledCodeToTerm $ + dataRevAppendProgram + `unsafeApplyCode` liftCodeDef dataList1 + `unsafeApplyCode` liftCodeDef dataList2 ) (===) (semanticsToDataList expected) reverseProgram :: CompiledCode ([Integer] -> [Integer]) -reverseProgram = $$(compile [|| List.reverse ||]) +reverseProgram = $$(compile [||List.reverse||]) dataReverseProgram :: CompiledCode (Data.List Integer -> Data.List Integer) -dataReverseProgram = $$(compile [|| Data.List.reverse ||]) +dataReverseProgram = $$(compile [||Data.List.reverse||]) reverseSpec :: Property reverseSpec = property $ do @@ -166,25 +165,25 @@ reverseSpec = property $ do dataList = semanticsToDataList listS expected = reverseS listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ reverseProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + reverseProgram + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataReverseProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataReverseProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) findIndexProgram :: CompiledCode (Integer -> [Integer] -> Maybe Integer) -findIndexProgram = $$(compile [|| \num -> List.findIndex (PlutusTx.== num) ||]) +findIndexProgram = $$(compile [||\num -> List.findIndex (PlutusTx.== num)||]) dataFindIndexProgram :: CompiledCode (Integer -> Data.List Integer -> Maybe Integer) -dataFindIndexProgram = $$(compile [|| \num -> Data.List.findIndex (PlutusTx.== num) ||]) +dataFindIndexProgram = $$(compile [||\num -> Data.List.findIndex (PlutusTx.== num)||]) findIndexSpec :: Property findIndexSpec = property $ do @@ -194,29 +193,29 @@ findIndexSpec = property $ do dataList = semanticsToDataList listS expected = findIndexS (== num) listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ findIndexProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + findIndexProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataFindIndexProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataFindIndexProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) expected unzipProgram :: CompiledCode ([(Integer, Integer)] -> ([Integer], [Integer])) -unzipProgram = $$(compile [|| List.unzip ||]) +unzipProgram = $$(compile [||List.unzip||]) dataUnzipProgram :: CompiledCode - (Data.List (Integer, Integer) -> (Data.List Integer, Data.List Integer)) -dataUnzipProgram = $$(compile [|| Data.List.unzip ||]) + (Data.List (Integer, Integer) -> (Data.List Integer, Data.List Integer)) +dataUnzipProgram = $$(compile [||Data.List.unzip||]) unzipSpec :: Property unzipSpec = property $ do @@ -225,25 +224,25 @@ unzipSpec = property $ do dataList = semanticsToDataList listS (expected1, expected2) = unzipS listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ unzipProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + unzipProgram + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected1, semanticsToList expected2) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataUnzipProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataUnzipProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected1, semanticsToDataList expected2) zipWithProgram :: CompiledCode ([Integer] -> [Integer] -> [Integer]) -zipWithProgram = $$(compile [|| List.zipWith (PlutusTx.-) ||]) +zipWithProgram = $$(compile [||List.zipWith (PlutusTx.-)||]) dataZipWithProgram :: CompiledCode (Data.List Integer -> Data.List Integer -> Data.List Integer) -dataZipWithProgram = $$(compile [|| Data.List.zipWith (PlutusTx.-) ||]) +dataZipWithProgram = $$(compile [||Data.List.zipWith (PlutusTx.-)||]) zipWithSpec :: Property zipWithSpec = property $ do @@ -255,27 +254,27 @@ zipWithSpec = property $ do dataList2 = semanticsToDataList listS2 expected = zipWithS (-) listS1 listS2 cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ zipWithProgram - `unsafeApplyCode` liftCodeDef list1 - `unsafeApplyCode` liftCodeDef list2 + ( compiledCodeToTerm $ + zipWithProgram + `unsafeApplyCode` liftCodeDef list1 + `unsafeApplyCode` liftCodeDef list2 ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataZipWithProgram - `unsafeApplyCode` liftCodeDef dataList1 - `unsafeApplyCode` liftCodeDef dataList2 + ( compiledCodeToTerm $ + dataZipWithProgram + `unsafeApplyCode` liftCodeDef dataList1 + `unsafeApplyCode` liftCodeDef dataList2 ) (===) (semanticsToDataList expected) headProgram :: CompiledCode ([Integer] -> Integer) -headProgram = $$(compile [|| List.head ||]) +headProgram = $$(compile [||List.head||]) dataHeadProgram :: CompiledCode (Data.List Integer -> Integer) -dataHeadProgram = $$(compile [|| Data.List.head ||]) +dataHeadProgram = $$(compile [||Data.List.head||]) headSpec :: Property headSpec = property $ do @@ -284,25 +283,25 @@ headSpec = property $ do dataList = semanticsToDataList listS expected = headS listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ headProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + headProgram + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataHeadProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataHeadProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) expected lastProgram :: CompiledCode ([Integer] -> Integer) -lastProgram = $$(compile [|| List.last ||]) +lastProgram = $$(compile [||List.last||]) dataLastProgram :: CompiledCode (Data.List Integer -> Integer) -dataLastProgram = $$(compile [|| Data.List.last ||]) +dataLastProgram = $$(compile [||Data.List.last||]) lastSpec :: Property lastSpec = property $ do @@ -311,25 +310,25 @@ lastSpec = property $ do dataList = semanticsToDataList listS expected = lastS listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ lastProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + lastProgram + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataLastProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataLastProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) expected tailProgram :: CompiledCode ([Integer] -> [Integer]) -tailProgram = $$(compile [|| List.tail ||]) +tailProgram = $$(compile [||List.tail||]) dataTailProgram :: CompiledCode (Data.List Integer -> Data.List Integer) -dataTailProgram = $$(compile [|| Data.List.tail ||]) +dataTailProgram = $$(compile [||Data.List.tail||]) tailSpec :: Property tailSpec = property $ do @@ -338,25 +337,25 @@ tailSpec = property $ do dataList = semanticsToDataList listS expected = tailS listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ tailProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + tailProgram + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataTailProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataTailProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) takeProgram :: CompiledCode (Integer -> [Integer] -> [Integer]) -takeProgram = $$(compile [|| List.take ||]) +takeProgram = $$(compile [||List.take||]) dataTakeProgram :: CompiledCode (Integer -> Data.List Integer -> Data.List Integer) -dataTakeProgram = $$(compile [|| Data.List.take ||]) +dataTakeProgram = $$(compile [||Data.List.take||]) takeSpec :: Property takeSpec = property $ do @@ -366,27 +365,27 @@ takeSpec = property $ do dataList = semanticsToDataList listS expected = takeS num listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ takeProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + takeProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataTakeProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataTakeProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) dropProgram :: CompiledCode (Integer -> [Integer] -> [Integer]) -dropProgram = $$(compile [|| List.drop ||]) +dropProgram = $$(compile [||List.drop||]) dataDropProgram :: CompiledCode (Integer -> Data.List Integer -> Data.List Integer) -dataDropProgram = $$(compile [|| Data.List.drop ||]) +dataDropProgram = $$(compile [||Data.List.drop||]) dropSpec :: Property dropSpec = property $ do @@ -396,27 +395,27 @@ dropSpec = property $ do dataList = semanticsToDataList listS expected = dropS num listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dropProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + dropProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataDropProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataDropProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) dropWhileProgram :: CompiledCode ([Integer] -> [Integer]) -dropWhileProgram = $$(compile [|| List.dropWhile PlutusTx.even ||]) +dropWhileProgram = $$(compile [||List.dropWhile PlutusTx.even||]) dataDropWhileProgram :: CompiledCode (Data.List Integer -> Data.List Integer) -dataDropWhileProgram = $$(compile [|| Data.List.dropWhile PlutusTx.even ||]) +dataDropWhileProgram = $$(compile [||Data.List.dropWhile PlutusTx.even||]) dropWhileSpec :: Property dropWhileSpec = property $ do @@ -425,27 +424,27 @@ dropWhileSpec = property $ do dataList = semanticsToDataList listS expected = dropWhileS even listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dropWhileProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + dropWhileProgram + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataDropWhileProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataDropWhileProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) splitAtProgram :: CompiledCode (Integer -> [Integer] -> ([Integer], [Integer])) -splitAtProgram = $$(compile [|| List.splitAt ||]) +splitAtProgram = $$(compile [||List.splitAt||]) dataSplitAtProgram :: CompiledCode - (Integer -> Data.List Integer -> (Data.List Integer, Data.List Integer)) -dataSplitAtProgram = $$(compile [|| Data.List.splitAt ||]) + (Integer -> Data.List Integer -> (Data.List Integer, Data.List Integer)) +dataSplitAtProgram = $$(compile [||Data.List.splitAt||]) splitAtSpec :: Property splitAtSpec = property $ do @@ -455,27 +454,27 @@ splitAtSpec = property $ do dataList = semanticsToDataList listS (expected1, expected2) = splitAtS num listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ splitAtProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + splitAtProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected1, semanticsToList expected2) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataSplitAtProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataSplitAtProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected1, semanticsToDataList expected2) elemByProgram :: CompiledCode (Integer -> [Integer] -> Bool) -elemByProgram = $$(compile [|| \n -> List.elemBy (PlutusTx.<) n ||]) +elemByProgram = $$(compile [||\n -> List.elemBy (PlutusTx.<) n||]) dataElemByProgram :: CompiledCode (Integer -> Data.List Integer -> Bool) -dataElemByProgram = $$(compile [|| \n -> Data.List.elemBy (PlutusTx.<) n ||]) +dataElemByProgram = $$(compile [||\n -> Data.List.elemBy (PlutusTx.<) n||]) elemBySpec :: Property elemBySpec = property $ do @@ -485,27 +484,27 @@ elemBySpec = property $ do dataList = semanticsToDataList listS expected = elemByS (<) num listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ elemByProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + elemByProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef list ) (===) expected cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataElemByProgram - `unsafeApplyCode` liftCodeDef num - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataElemByProgram + `unsafeApplyCode` liftCodeDef num + `unsafeApplyCode` liftCodeDef dataList ) (===) expected nubByProgram :: CompiledCode ([Integer] -> [Integer]) -nubByProgram = $$(compile [|| List.nubBy (PlutusTx.>=) ||]) +nubByProgram = $$(compile [||List.nubBy (PlutusTx.>=)||]) dataNubByProgram :: CompiledCode (Data.List Integer -> Data.List Integer) -dataNubByProgram = $$(compile [|| Data.List.nubBy (PlutusTx.>=) ||]) +dataNubByProgram = $$(compile [||Data.List.nubBy (PlutusTx.>=)||]) nubBySpec :: Property nubBySpec = property $ do @@ -514,25 +513,25 @@ nubBySpec = property $ do dataList = semanticsToDataList listS expected = nubByS (>=) listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ nubByProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + nubByProgram + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataNubByProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataNubByProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) nubProgram :: CompiledCode ([Integer] -> [Integer]) -nubProgram = $$(compile [|| List.nub ||]) +nubProgram = $$(compile [||List.nub||]) dataNubProgram :: CompiledCode (Data.List Integer -> Data.List Integer) -dataNubProgram = $$(compile [|| Data.List.nub ||]) +dataNubProgram = $$(compile [||Data.List.nub||]) nubSpec :: Property nubSpec = property $ do @@ -541,25 +540,25 @@ nubSpec = property $ do dataList = semanticsToDataList listS expected = nubS listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ nubProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + nubProgram + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataNubProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataNubProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected) partitionProgram :: CompiledCode ([Integer] -> ([Integer], [Integer])) -partitionProgram = $$(compile [|| List.partition PlutusTx.even ||]) +partitionProgram = $$(compile [||List.partition PlutusTx.even||]) dataPartitionProgram :: CompiledCode (Data.List Integer -> (Data.List Integer, Data.List Integer)) -dataPartitionProgram = $$(compile [|| Data.List.partition PlutusTx.even ||]) +dataPartitionProgram = $$(compile [||Data.List.partition PlutusTx.even||]) partitionSpec :: Property partitionSpec = property $ do @@ -568,25 +567,25 @@ partitionSpec = property $ do dataList = semanticsToDataList listS (expected1, expected2) = partitionS even listS cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ partitionProgram - `unsafeApplyCode` liftCodeDef list + ( compiledCodeToTerm $ + partitionProgram + `unsafeApplyCode` liftCodeDef list ) (===) (semanticsToList expected1, semanticsToList expected2) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataPartitionProgram - `unsafeApplyCode` liftCodeDef dataList + ( compiledCodeToTerm $ + dataPartitionProgram + `unsafeApplyCode` liftCodeDef dataList ) (===) (semanticsToDataList expected1, semanticsToDataList expected2) replicateProgram :: CompiledCode (Integer -> Integer -> [Integer]) -replicateProgram = $$(compile [|| List.replicate ||]) +replicateProgram = $$(compile [||List.replicate||]) dataReplicateProgram :: CompiledCode (Integer -> Integer -> Data.List Integer) -dataReplicateProgram = $$(compile [|| Data.List.replicate ||]) +dataReplicateProgram = $$(compile [||Data.List.replicate||]) replicateSpec :: Property replicateSpec = property $ do @@ -594,18 +593,18 @@ replicateSpec = property $ do num2 <- forAll $ Gen.integral rangeElem let expected = replicateS num1 num2 cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ replicateProgram - `unsafeApplyCode` liftCodeDef num1 - `unsafeApplyCode` liftCodeDef num2 + ( compiledCodeToTerm $ + replicateProgram + `unsafeApplyCode` liftCodeDef num1 + `unsafeApplyCode` liftCodeDef num2 ) (===) (semanticsToList expected) cekResultMatchesHaskellValue - ( compiledCodeToTerm - $ dataReplicateProgram - `unsafeApplyCode` liftCodeDef num1 - `unsafeApplyCode` liftCodeDef num2 + ( compiledCodeToTerm $ + dataReplicateProgram + `unsafeApplyCode` liftCodeDef num1 + `unsafeApplyCode` liftCodeDef num2 ) (===) (semanticsToDataList expected) diff --git a/plutus-tx-plugin/test/List/Semantics.hs b/plutus-tx-plugin/test/List/Semantics.hs index bc816d66029..abc99952504 100644 --- a/plutus-tx-plugin/test/List/Semantics.hs +++ b/plutus-tx-plugin/test/List/Semantics.hs @@ -20,8 +20,9 @@ import Hedgehog (Gen, Property, Range, forAll, property, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range --- | Semantics of lists. Used to model the expected behavior of the various --- PlutusTx list types. +{-| Semantics of lists. Used to model the expected behavior of the various +PlutusTx list types. +-} newtype ListS a = ListS {getListS :: [a]} deriving stock (Show, Eq) deriving newtype (Semigroup, Monoid) @@ -49,7 +50,7 @@ genListSList = ListS <$> Gen.list rangeLength genListS genListSPair :: Gen (ListS (Integer, Integer)) genListSPair = ListS - <$> Gen.list + <$> Gen.list rangeLength ((,) <$> Gen.integral rangeElem <*> Gen.integral rangeElem) @@ -69,8 +70,8 @@ semanticsToDataListIntPair = dataListToSemantics :: (UnsafeFromData a) => Data.List a -> ListS a dataListToSemantics (Data.toBuiltinList -> l) = ListS . go $ l - where - go = B.caseList' [] (\h t -> unsafeFromBuiltinData h : go t) + where + go = B.caseList' [] (\h t -> unsafeFromBuiltinData h : go t) areInversesSpec :: Property areInversesSpec = property $ do @@ -105,7 +106,7 @@ anyS f (ListS l) = Haskell.any f l allS :: (a -> Bool) -> ListS a -> Bool allS f (ListS l) = Haskell.all f l -foldMapS :: Monoid m => (a -> m) -> ListS a -> m +foldMapS :: (Monoid m) => (a -> m) -> ListS a -> m foldMapS f (ListS l) = foldMap f l mapS :: (a -> b) -> ListS a -> ListS b @@ -115,8 +116,8 @@ lengthS :: ListS a -> Integer lengthS = fromIntegral . Haskell.length . getListS unconsS :: ListS a -> Maybe (a, ListS a) -unconsS (ListS []) = Nothing -unconsS (ListS (h:t)) = Just (h, ListS t) +unconsS (ListS []) = Nothing +unconsS (ListS (h : t)) = Just (h, ListS t) andS :: ListS Bool -> Bool andS = Haskell.and . getListS @@ -124,10 +125,10 @@ andS = Haskell.and . getListS orS :: ListS Bool -> Bool orS = Haskell.or . getListS -elemS :: Eq a => a -> ListS a -> Bool +elemS :: (Eq a) => a -> ListS a -> Bool elemS x (ListS l) = Haskell.elem x l -notElemS :: Eq a => a -> ListS a -> Bool +notElemS :: (Eq a) => a -> ListS a -> Bool notElemS x (ListS l) = Haskell.notElem x l foldrS :: (a -> b -> b) -> b -> ListS a -> b @@ -143,8 +144,8 @@ concatMapS :: (a -> ListS b) -> ListS a -> ListS b concatMapS f (ListS l) = ListS $ concatMap (getListS . f) l listToMaybeS :: ListS a -> Maybe a -listToMaybeS (ListS []) = Nothing -listToMaybeS (ListS (h:_)) = Just h +listToMaybeS (ListS []) = Nothing +listToMaybeS (ListS (h : _)) = Just h uniqueElementS :: ListS a -> Maybe a uniqueElementS (ListS [x]) = Just x @@ -158,9 +159,9 @@ indexS (ListS l) i = l Haskell.!! fromIntegral i revAppendS :: ListS a -> ListS a -> ListS a revAppendS (ListS l) (ListS l') = ListS $ rev l l' - where - rev [] a = a - rev (x:xs) a = rev xs (x:a) + where + rev [] a = a + rev (x : xs) a = rev xs (x : a) reverseS :: ListS a -> ListS a reverseS (ListS l) = ListS $ Haskell.reverse l @@ -202,17 +203,17 @@ splitAtS n (ListS l) = let (l1, l2) = Haskell.splitAt (fromIntegral n) l in (ListS l1, ListS l2) -elemByS :: forall a . (a -> a -> Bool) -> a -> ListS a -> Bool +elemByS :: forall a. (a -> a -> Bool) -> a -> ListS a -> Bool elemByS eq y (ListS l) = go l - where - go :: [a] -> Bool - go [] = False - go (x:xs) = x `eq` y || go xs + where + go :: [a] -> Bool + go [] = False + go (x : xs) = x `eq` y || go xs nubByS :: (a -> a -> Bool) -> ListS a -> ListS a nubByS f (ListS l) = ListS $ Haskell.nubBy f l -nubS :: Eq a => ListS a -> ListS a +nubS :: (Eq a) => ListS a -> ListS a nubS (ListS l) = ListS $ Haskell.nub l replicateS :: Integer -> a -> ListS a @@ -226,5 +227,5 @@ partitionS f (ListS l) = sortBy :: (a -> a -> Ordering) -> ListS a -> ListS a sortBy f (ListS l) = ListS $ Haskell.sortBy f l -sort :: Ord a => ListS a -> ListS a +sort :: (Ord a) => ListS a -> ListS a sort (ListS l) = ListS $ Haskell.sort l diff --git a/plutus-tx-plugin/test/List/Spec.hs b/plutus-tx-plugin/test/List/Spec.hs index fca31cf142f..af37653d196 100644 --- a/plutus-tx-plugin/test/List/Spec.hs +++ b/plutus-tx-plugin/test/List/Spec.hs @@ -9,48 +9,49 @@ import List.Semantics propertyTests :: TestTree propertyTests = - localOption (HedgehogTestLimit (Just 30)) - $ testGroup "List property tests" - [ testProperty "areInverses" areInversesSpec - , testProperty "toSOP" toSOPSpec - , testProperty "fromSOP" fromSOPSpec - , testProperty "append" appendSpec - , testProperty "find" findSpec - , testProperty "findIndices" findIndicesSpec - , testProperty "filter" filterSpec - , testProperty "mapMaybe" mapMaybeSpec - , testProperty "any" anySpec - , testProperty "all" allSpec - , testProperty "foldMap" foldMapSpec - , testProperty "map" mapSpec - , testProperty "length" lengthSpec - , testProperty "uncons" unconsSpec - , testProperty "and" andSpec - , testProperty "or" orSpec - , testProperty "elem" elemSpec - , testProperty "notElem" notElemSpec - , testProperty "foldr" foldrSpec - , testProperty "foldl" foldlSpec - , testProperty "concat" concatSpec - , testProperty "concatMap" concatMapSpec - , testProperty "listToMaybe" listToMaybeSpec - , testProperty "uniqueElement" uniqueElementSpec - , testProperty "index" indexSpec - , testProperty "revAppend" revAppendSpec - , testProperty "reverse" reverseSpec - , testProperty "findIndex" findIndexSpec - , testProperty "unzip" unzipSpec - , testProperty "zipWith" zipWithSpec - , testProperty "head" headSpec - , testProperty "last" lastSpec - , testProperty "tail" tailSpec - , testProperty "take" takeSpec - , testProperty "drop" dropSpec - , testProperty "dropWhile" dropWhileSpec - , testProperty "splitAt" splitAtSpec - , testProperty "elemBy" elemBySpec - , testProperty "nubBy" nubBySpec - , testProperty "nub" nubSpec - , testProperty "partition" partitionSpec - , testProperty "replicate" replicateSpec - ] + localOption (HedgehogTestLimit (Just 30)) $ + testGroup + "List property tests" + [ testProperty "areInverses" areInversesSpec + , testProperty "toSOP" toSOPSpec + , testProperty "fromSOP" fromSOPSpec + , testProperty "append" appendSpec + , testProperty "find" findSpec + , testProperty "findIndices" findIndicesSpec + , testProperty "filter" filterSpec + , testProperty "mapMaybe" mapMaybeSpec + , testProperty "any" anySpec + , testProperty "all" allSpec + , testProperty "foldMap" foldMapSpec + , testProperty "map" mapSpec + , testProperty "length" lengthSpec + , testProperty "uncons" unconsSpec + , testProperty "and" andSpec + , testProperty "or" orSpec + , testProperty "elem" elemSpec + , testProperty "notElem" notElemSpec + , testProperty "foldr" foldrSpec + , testProperty "foldl" foldlSpec + , testProperty "concat" concatSpec + , testProperty "concatMap" concatMapSpec + , testProperty "listToMaybe" listToMaybeSpec + , testProperty "uniqueElement" uniqueElementSpec + , testProperty "index" indexSpec + , testProperty "revAppend" revAppendSpec + , testProperty "reverse" reverseSpec + , testProperty "findIndex" findIndexSpec + , testProperty "unzip" unzipSpec + , testProperty "zipWith" zipWithSpec + , testProperty "head" headSpec + , testProperty "last" lastSpec + , testProperty "tail" tailSpec + , testProperty "take" takeSpec + , testProperty "drop" dropSpec + , testProperty "dropWhile" dropWhileSpec + , testProperty "splitAt" splitAtSpec + , testProperty "elemBy" elemBySpec + , testProperty "nubBy" nubBySpec + , testProperty "nub" nubSpec + , testProperty "partition" partitionSpec + , testProperty "replicate" replicateSpec + ] diff --git a/plutus-tx-plugin/test/Optimization/Spec.hs b/plutus-tx-plugin/test/Optimization/Spec.hs index d579ca7f591..fb2e4d43c28 100644 --- a/plutus-tx-plugin/test/Optimization/Spec.hs +++ b/plutus-tx-plugin/test/Optimization/Spec.hs @@ -9,8 +9,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} module Optimization.Spec where @@ -26,39 +26,50 @@ import PlutusTx.Plugin (plc) import PlutusTx.Test import PlutusTx.TH (compile) -AsData.asData [d| - data MaybeD a = JustD a a | NothingD - |] +AsData.asData + [d| + data MaybeD a = JustD a a | NothingD + |] -- These are tests that run with the simplifier on, and some run all the way to UPLC. -- This can be interesting to make sure that important optimizations fire, including -- ones that run on UPLC. tests :: TestNested -tests = testNested "Optimization" . pure $ testNestedGhc - [ goldenUPlc "maybeFun" maybeFun - , goldenPirReadable "matchAsData" matchAsData - , goldenPirReadable "unsafeDeconstructData" unsafeDeconstructData - ] +tests = + testNested "Optimization" . pure $ + testNestedGhc + [ goldenUPlc "maybeFun" maybeFun + , goldenPirReadable "matchAsData" matchAsData + , goldenPirReadable "unsafeDeconstructData" unsafeDeconstructData + ] -- The point of this test is to check that matchers get eliminated unconditionally -- even if they're used more than once. maybeFun :: CompiledCode (Maybe Integer -> Maybe Integer -> Maybe Integer) -maybeFun = $$(compile - [|| \(x :: Maybe Integer) (y :: Maybe Integer) -> - case x of +maybeFun = + $$( compile + [|| + \(x :: Maybe Integer) (y :: Maybe Integer) -> + case x of Just x' -> case y of - Just y' -> Just (x' `Builtins.addInteger` y') - Nothing -> Nothing + Just y' -> Just (x' `Builtins.addInteger` y') + Nothing -> Nothing Nothing -> Nothing - ||]) + ||] + ) -- Features a nested field which is also defined with AsData matchAsData :: CompiledCode (MaybeD Integer -> Integer) -matchAsData = plc (Proxy @"matchAsData") ( - \case - JustD a _ -> a - NothingD -> 1) +matchAsData = + plc + (Proxy @"matchAsData") + ( \case + JustD a _ -> a + NothingD -> 1 + ) unsafeDeconstructData :: CompiledCode (Builtins.BuiltinData -> Maybe (Integer, Integer)) -unsafeDeconstructData = plc (Proxy @"deconstructData") - (\(d :: Builtins.BuiltinData) -> IsData.unsafeFromBuiltinData d) +unsafeDeconstructData = + plc + (Proxy @"deconstructData") + (\(d :: Builtins.BuiltinData) -> IsData.unsafeFromBuiltinData d) diff --git a/plutus-tx-plugin/test/Plugin/Basic/Spec.hs b/plutus-tx-plugin/test/Plugin/Basic/Spec.hs index 229a111dd7a..cfb79a3d530 100644 --- a/plutus-tx-plugin/test/Plugin/Basic/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Basic/Spec.hs @@ -29,24 +29,25 @@ import Test.Tasty.Extras (TestNested, testNested, testNestedGhc) basic :: TestNested basic = - testNested "Basic" . pure $ testNestedGhc - [ goldenPirReadable "monoId" monoId - , goldenPirReadable "monoK" monoK - , goldenPirReadable "letFun" letFun - , goldenPirReadable "nonstrictLet" nonstrictLet - , goldenPirReadable "strictLet" strictLet - , goldenPirReadable "strictMultiLet" strictMultiLet - , goldenPirReadable "strictLetRec" strictLetRec - , -- must keep the scrutinee as it evaluates to error - goldenPirReadable "ifOpt" ifOpt - , -- should fail - goldenUEval "ifOptEval" [ifOpt] - , goldenPirReadable "monadicDo" monadicDo - , goldenPirReadable "patternMatchDo" patternMatchDo - , goldenUPlc "patternMatchFailure" patternMatchFailure - , goldenPirReadable "defaultCaseDuplication" defaultCaseDuplication - , goldenPirReadable "defaultCaseDuplicationNested" defaultCaseDuplicationNested - ] + testNested "Basic" . pure $ + testNestedGhc + [ goldenPirReadable "monoId" monoId + , goldenPirReadable "monoK" monoK + , goldenPirReadable "letFun" letFun + , goldenPirReadable "nonstrictLet" nonstrictLet + , goldenPirReadable "strictLet" strictLet + , goldenPirReadable "strictMultiLet" strictMultiLet + , goldenPirReadable "strictLetRec" strictLetRec + , -- must keep the scrutinee as it evaluates to error + goldenPirReadable "ifOpt" ifOpt + , -- should fail + goldenUEval "ifOptEval" [ifOpt] + , goldenPirReadable "monadicDo" monadicDo + , goldenPirReadable "patternMatchDo" patternMatchDo + , goldenUPlc "patternMatchFailure" patternMatchFailure + , goldenPirReadable "defaultCaseDuplication" defaultCaseDuplication + , goldenPirReadable "defaultCaseDuplicationNested" defaultCaseDuplicationNested + ] monoId :: CompiledCode (Integer -> Integer) monoId = plc (Proxy @"monoId") \(x :: Integer) -> x diff --git a/plutus-tx-plugin/test/Plugin/Coverage/9.6/coverageCode.pir.golden b/plutus-tx-plugin/test/Plugin/Coverage/9.6/coverageCode.pir.golden index 59011199d3c..23046806db1 100644 --- a/plutus-tx-plugin/test/Plugin/Coverage/9.6/coverageCode.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Coverage/9.6/coverageCode.pir.golden @@ -10,11 +10,11 @@ let = \(ds : unit) -> trace {all dead a. Maybe a} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 40, _covLocEndLine = 40, _covLocStartCol = 14, _covLocEndCol = 15})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 39, _covLocEndLine = 39, _covLocStartCol = 14, _covLocEndCol = 15})" (/\dead -> trace {all dead a. Maybe a} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 42, _covLocEndLine = 42, _covLocStartCol = 26, _covLocEndCol = 33})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 41, _covLocEndLine = 41, _covLocStartCol = 26, _covLocEndCol = 33})" (/\dead -> Nothing) {all dead. dead}) {all dead. dead} @@ -67,44 +67,44 @@ let !x : integer = x in traceBool - "CoverBool (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 46, _covLocEndLine = 46, _covLocStartCol = 1, _covLocEndCol = 32}) True" - "CoverBool (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 46, _covLocEndLine = 46, _covLocStartCol = 1, _covLocEndCol = 32}) False" + "CoverBool (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 45, _covLocEndLine = 45, _covLocStartCol = 1, _covLocEndCol = 32}) True" + "CoverBool (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 45, _covLocEndLine = 45, _covLocStartCol = 1, _covLocEndCol = 32}) False" (trace {all dead. Bool} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 46, _covLocEndLine = 46, _covLocStartCol = 1, _covLocEndCol = 32})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 45, _covLocEndLine = 45, _covLocStartCol = 1, _covLocEndCol = 32})" (/\dead -> traceBool - "CoverBool (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 46, _covLocEndLine = 46, _covLocStartCol = 14, _covLocEndCol = 32}) True" - "CoverBool (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 46, _covLocEndLine = 46, _covLocStartCol = 14, _covLocEndCol = 32}) False" + "CoverBool (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 45, _covLocEndLine = 45, _covLocStartCol = 14, _covLocEndCol = 32}) True" + "CoverBool (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 45, _covLocEndLine = 45, _covLocStartCol = 14, _covLocEndCol = 32}) False" (trace {all dead. Bool} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 46, _covLocEndLine = 46, _covLocStartCol = 14, _covLocEndCol = 32})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 45, _covLocEndLine = 45, _covLocStartCol = 14, _covLocEndCol = 32})" (/\dead -> `&&` (traceBool - "CoverBool (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 46, _covLocEndLine = 46, _covLocStartCol = 14, _covLocEndCol = 24}) True" - "CoverBool (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 46, _covLocEndLine = 46, _covLocStartCol = 14, _covLocEndCol = 24}) False" + "CoverBool (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 45, _covLocEndLine = 45, _covLocStartCol = 14, _covLocEndCol = 24}) True" + "CoverBool (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 45, _covLocEndLine = 45, _covLocStartCol = 14, _covLocEndCol = 24}) False" (trace {all dead. Bool} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 46, _covLocEndLine = 46, _covLocStartCol = 14, _covLocEndCol = 24})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 45, _covLocEndLine = 45, _covLocStartCol = 14, _covLocEndCol = 24})" (/\dead -> `==` {integer} `$fEqInteger` (trace {all dead. integer} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 46, _covLocEndLine = 46, _covLocStartCol = 15, _covLocEndCol = 16})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 45, _covLocEndLine = 45, _covLocStartCol = 15, _covLocEndCol = 16})" (/\dead -> x) {all dead. dead}) (trace {all dead. integer} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 46, _covLocEndLine = 46, _covLocStartCol = 22, _covLocEndCol = 23})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 45, _covLocEndLine = 45, _covLocStartCol = 22, _covLocEndCol = 23})" (/\dead -> 5) {all dead. dead})) {all dead. dead})) (trace {all dead. Bool} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 46, _covLocEndLine = 46, _covLocStartCol = 28, _covLocEndCol = 32})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 45, _covLocEndLine = 45, _covLocStartCol = 28, _covLocEndCol = 32})" (/\dead -> True) {all dead. dead})) {all dead. dead})) @@ -116,15 +116,15 @@ in in trace {all dead. Maybe Bool} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 37, _covLocEndLine = 37, _covLocStartCol = 54, _covLocEndCol = 57})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 36, _covLocEndLine = 36, _covLocStartCol = 54, _covLocEndCol = 57})" (/\dead -> trace {all dead. Maybe Bool} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 40, _covLocEndLine = 42, _covLocStartCol = 1, _covLocEndCol = 33})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 39, _covLocEndLine = 41, _covLocStartCol = 1, _covLocEndCol = 33})" (/\dead -> trace {all dead. Maybe Bool} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 40, _covLocEndLine = 42, _covLocStartCol = 9, _covLocEndCol = 33})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 39, _covLocEndLine = 41, _covLocStartCol = 9, _covLocEndCol = 33})" (/\dead -> Maybe_match {integer} @@ -134,26 +134,26 @@ in /\dead -> trace {all dead. Maybe Bool} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 41, _covLocEndLine = 41, _covLocStartCol = 12, _covLocEndCol = 22})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 40, _covLocEndLine = 40, _covLocStartCol = 12, _covLocEndCol = 22})" (/\dead -> Bool_match (otherFun (trace {all dead. integer} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 41, _covLocEndLine = 41, _covLocStartCol = 21, _covLocEndCol = 22})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 40, _covLocEndLine = 40, _covLocStartCol = 21, _covLocEndCol = 22})" (/\dead -> y) {all dead. dead})) {all dead. Maybe Bool} (/\dead -> trace {all dead. Maybe Bool} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 41, _covLocEndLine = 41, _covLocStartCol = 26, _covLocEndCol = 36})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 40, _covLocEndLine = 40, _covLocStartCol = 26, _covLocEndCol = 36})" (/\dead -> Just {Bool} (trace {all dead. Bool} - "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 41, _covLocEndLine = 41, _covLocStartCol = 31, _covLocEndCol = 36})" + "CoverLocation (CovLoc {_covLocFile = \"test/Plugin/Coverage/Spec.hs\", _covLocStartLine = 40, _covLocEndLine = 40, _covLocStartCol = 31, _covLocEndCol = 36})" (/\dead -> False) {all dead. dead})) {all dead. dead}) diff --git a/plutus-tx-plugin/test/Plugin/Coverage/Spec.hs b/plutus-tx-plugin/test/Plugin/Coverage/Spec.hs index 0b96c4db6fe..d853d44b142 100644 --- a/plutus-tx-plugin/test/Plugin/Coverage/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Coverage/Spec.hs @@ -3,15 +3,14 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin -fplugin-opt PlutusTx.Plugin:coverage-all #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} module Plugin.Coverage.Spec (coverage) where import Control.Lens - import Data.Map qualified as Map import Data.Proxy import Data.Set (Set) @@ -46,34 +45,46 @@ otherFun :: Integer -> Bool otherFun x = (x P.== 5) && True boolQualifiedDisappears :: CompiledCode (() -> Bool) -boolQualifiedDisappears = plc (Proxy @"boolQualifiedDisappears") (\ () -> Haskell.True) +boolQualifiedDisappears = plc (Proxy @"boolQualifiedDisappears") (\() -> Haskell.True) coverage :: TestNested -coverage = testNested "Coverage" . pure $ testNestedGhc - [ embed $ testGroup "Application heads and line coverage" - [ mkTests "noBool" noBool Set.empty [31] - , mkTests "boolTrueFalse" boolTrueFalse (Set.singleton "&&") [34] - , mkTests "boolOtherFunction" boolOtherFunction (Set.fromList ["&&", "=="]) [37, 40, 41, 42] - , mkTests "boolQualifiedDisappears" boolQualifiedDisappears Set.empty [49] - ] - , goldenPirReadable "coverageCode" boolOtherFunction ] +coverage = + testNested "Coverage" . pure $ + testNestedGhc + [ embed $ + testGroup + "Application heads and line coverage" + [ mkTests "noBool" noBool Set.empty [30] + , mkTests "boolTrueFalse" boolTrueFalse (Set.singleton "&&") [33] + , mkTests "boolOtherFunction" boolOtherFunction (Set.fromList ["&&", "=="]) [36, 39, 40, 45] + , mkTests "boolQualifiedDisappears" boolQualifiedDisappears Set.empty [48] + ] + , goldenPirReadable "coverageCode" boolOtherFunction + ] mkTests :: String -> CompiledCode t -> Set String -> [Int] -> TestTree -mkTests nm cc heads ls = testGroup nm [ applicationHeadsCorrect cc heads , linesInCoverageIndex cc ls ] +mkTests nm cc heads ls = testGroup nm [applicationHeadsCorrect cc heads, linesInCoverageIndex cc ls] applicationHeadsCorrect :: CompiledCode t -> Set String -> TestTree applicationHeadsCorrect cc heads = testCase "correct application heads" (assertEqual "" heads headSymbols) - where - headSymbols :: Set String - headSymbols = - -- TODO: This should really use a prism instead of going to and from lists I guess - Set.fromList $ [ s - | covMeta <- cc ^. to getCovIdx . coverageMetadata . to Map.elems - , ApplicationHeadSymbol s <- Set.toList $ covMeta ^. metadataSet ] + where + headSymbols :: Set String + headSymbols = + -- TODO: This should really use a prism instead of going to and from lists I guess + Set.fromList $ + [ s + | covMeta <- cc ^. to getCovIdx . coverageMetadata . to Map.elems + , ApplicationHeadSymbol s <- Set.toList $ covMeta ^. metadataSet + ] linesInCoverageIndex :: CompiledCode t -> [Int] -> TestTree -linesInCoverageIndex cc ls = testCase "correct line coverage" (assertBool ("Lines " ++ show ls ++ " are not covered by " ++ show covLineSpans) covered) - where - covered = all (\l -> any (\(s, e) -> s <= l && l <= e) covLineSpans) ls - covLineSpans = [ (covLoc ^. covLocStartLine, covLoc ^. covLocEndLine) - | CoverLocation covLoc <- cc ^. to getCovIdx . coverageMetadata . to Map.keys ] +linesInCoverageIndex cc ls = + testCase + "correct line coverage" + (assertBool ("Lines " ++ show ls ++ " are not covered by " ++ show covLineSpans) covered) + where + covered = all (\l -> any (\(s, e) -> s <= l && l <= e) covLineSpans) ls + covLineSpans = + [ (covLoc ^. covLocStartLine, covLoc ^. covLocEndLine) + | CoverLocation covLoc <- cc ^. to getCovIdx . coverageMetadata . to Map.keys + ] diff --git a/plutus-tx-plugin/test/Plugin/Data/Spec.hs b/plutus-tx-plugin/test/Plugin/Data/Spec.hs index 4a1f178ff27..8fe7090d757 100644 --- a/plutus-tx-plugin/test/Plugin/Data/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Data/Spec.hs @@ -6,16 +6,15 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} - +{-# OPTIONS_GHC -Wno-incomplete-patterns #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} module Plugin.Data.Spec where @@ -31,36 +30,39 @@ import PlutusTx.Test import Data.Proxy datat :: TestNested -datat = testNested "Data" . pure . testNestedGhc $ - [ monoData - , polyData - , newtypes - , recursiveTypes - , typeFamilies - ] +datat = + testNested "Data" . pure . testNestedGhc $ + [ monoData + , polyData + , newtypes + , recursiveTypes + , typeFamilies + ] monoData :: TestNested -monoData = testNested "monomorphic" [ - goldenPirReadable "enum" basicEnum - , goldenPirReadable "monoDataType" monoDataType - , goldenPirReadable "monoConstructor" monoConstructor - , goldenPirReadable "monoConstructed" monoConstructed - , goldenPirReadable "monoCase" monoCase - , goldenPirReadable "monoCaseStrict" monoCaseStrict - , goldenUEval "monoConstDest" [ toUPlc monoCase, toUPlc monoConstructed ] - , goldenPirReadable "defaultCase" defaultCase - , goldenPirReadable "irrefutableMatch" irrefutableMatch - , goldenPirReadable "atPattern" atPattern - , goldenUEval "monoConstDestDefault" [ toUPlc monoCase, toUPlc monoConstructed ] - , goldenPirReadable "monoRecord" monoRecord - , goldenPirReadable "recordNewtype" recordNewtype - , goldenPirReadable "recordWithStrictField" recordWithStrictField - , goldenPirReadable "unusedWrapper" unusedWrapper - , goldenPirReadable "nonValueCase" nonValueCase - , goldenPirReadable "stakingCredential" stakingCredential - , goldenPirReadable "strictDataMatch" strictDataMatch - , goldenPirReadable "synonym" synonym - ] +monoData = + testNested + "monomorphic" + [ goldenPirReadable "enum" basicEnum + , goldenPirReadable "monoDataType" monoDataType + , goldenPirReadable "monoConstructor" monoConstructor + , goldenPirReadable "monoConstructed" monoConstructed + , goldenPirReadable "monoCase" monoCase + , goldenPirReadable "monoCaseStrict" monoCaseStrict + , goldenUEval "monoConstDest" [toUPlc monoCase, toUPlc monoConstructed] + , goldenPirReadable "defaultCase" defaultCase + , goldenPirReadable "irrefutableMatch" irrefutableMatch + , goldenPirReadable "atPattern" atPattern + , goldenUEval "monoConstDestDefault" [toUPlc monoCase, toUPlc monoConstructed] + , goldenPirReadable "monoRecord" monoRecord + , goldenPirReadable "recordNewtype" recordNewtype + , goldenPirReadable "recordWithStrictField" recordWithStrictField + , goldenPirReadable "unusedWrapper" unusedWrapper + , goldenPirReadable "nonValueCase" nonValueCase + , goldenPirReadable "stakingCredential" stakingCredential + , goldenPirReadable "strictDataMatch" strictDataMatch + , goldenPirReadable "synonym" synonym + ] data MyEnum = Enum1 | Enum2 @@ -68,18 +70,18 @@ basicEnum :: CompiledCode MyEnum basicEnum = plc (Proxy @"basicEnum") Enum1 data MyMonoData = Mono1 Integer Integer | Mono2 Integer | Mono3 Integer - deriving stock (Show, Eq) + deriving stock (Show, Eq) instance P.Eq MyMonoData where - {-# INLINABLE (==) #-} - (Mono1 i1 j1) == (Mono1 i2 j2) = i1 P.== i2 && j1 P.== j2 - (Mono2 i1) == (Mono2 i2) = i1 P.== i2 - (Mono3 i1) == (Mono3 i2) = i1 P.== i2 - _ == _ = False + {-# INLINEABLE (==) #-} + (Mono1 i1 j1) == (Mono1 i2 j2) = i1 P.== i2 && j1 P.== j2 + (Mono2 i1) == (Mono2 i2) = i1 P.== i2 + (Mono3 i1) == (Mono3 i2) = i1 P.== i2 + _ == _ = False -- pattern match to avoid type getting simplified away monoDataType :: CompiledCode (MyMonoData -> Integer) -monoDataType = plc (Proxy @"monoDataType") (\(x :: MyMonoData) -> case x of { Mono2 i -> i; _ -> 1; }) +monoDataType = plc (Proxy @"monoDataType") (\(x :: MyMonoData) -> case x of Mono2 i -> i; _ -> 1) {- This is one of the test cases that reveals a bug in GHC 9: it fails to perform some @@ -108,45 +110,57 @@ monoConstructed :: CompiledCode MyMonoData monoConstructed = plc (Proxy @"monoConstructed") (Mono2 1) monoCase :: CompiledCode (MyMonoData -> Integer) -monoCase = plc (Proxy @"monoCase") (\(x :: MyMonoData) -> case x of { Mono1 _ b -> b; Mono2 a -> a; Mono3 a -> a }) +monoCase = + plc + (Proxy @"monoCase") + (\(x :: MyMonoData) -> case x of Mono1 _ b -> b; Mono2 a -> a; Mono3 a -> a) -- Bang patterns on pattern-matches do nothing: it's already strict monoCaseStrict :: CompiledCode (MyMonoData -> Integer) -monoCaseStrict = plc (Proxy @"monoCase") (\(x :: MyMonoData) -> case x of { Mono1 _ !b -> b; Mono2 a -> a; Mono3 !a -> a }) +monoCaseStrict = + plc + (Proxy @"monoCase") + (\(x :: MyMonoData) -> case x of Mono1 _ !b -> b; Mono2 a -> a; Mono3 !a -> a) defaultCase :: CompiledCode (MyMonoData -> Integer) -defaultCase = plc (Proxy @"defaultCase") (\(x :: MyMonoData) -> case x of { Mono3 a -> a ; _ -> 2; }) +defaultCase = plc (Proxy @"defaultCase") (\(x :: MyMonoData) -> case x of Mono3 a -> a; _ -> 2) irrefutableMatch :: CompiledCode (MyMonoData -> Integer) -irrefutableMatch = plc (Proxy @"irrefutableMatch") (\(x :: MyMonoData) -> case x of { Mono2 a -> a }) +irrefutableMatch = plc (Proxy @"irrefutableMatch") (\(x :: MyMonoData) -> case x of Mono2 a -> a) atPattern :: CompiledCode ((Integer, Integer) -> Integer) -atPattern = plc (Proxy @"atPattern") (\t@(_::Integer, y::Integer) -> let fst (a, _) = a in Builtins.addInteger y (fst t)) +atPattern = + plc + (Proxy @"atPattern") + (\t@(_ :: Integer, y :: Integer) -> let fst (a, _) = a in Builtins.addInteger y (fst t)) -data MyMonoRecord = MyMonoRecord { mrA :: Integer , mrB :: Integer} - deriving stock (Show, Eq) +data MyMonoRecord = MyMonoRecord {mrA :: Integer, mrB :: Integer} + deriving stock (Show, Eq) instance P.Eq MyMonoRecord where - {-# INLINABLE (==) #-} - (MyMonoRecord i1 j1) == (MyMonoRecord i2 j2) = i1 P.== i2 && j1 P.== j2 + {-# INLINEABLE (==) #-} + (MyMonoRecord i1 j1) == (MyMonoRecord i2 j2) = i1 P.== i2 && j1 P.== j2 -- pattern match to avoid type getting simplified away monoRecord :: CompiledCode (MyMonoRecord -> Integer) -monoRecord = plc (Proxy @"monoRecord") (\(x :: MyMonoRecord) -> case x of { MyMonoRecord i _ -> i; }) +monoRecord = plc (Proxy @"monoRecord") (\(x :: MyMonoRecord) -> case x of MyMonoRecord i _ -> i) -data RecordNewtype = RecordNewtype { newtypeField :: MyNewtype } +data RecordNewtype = RecordNewtype {newtypeField :: MyNewtype} -- pattern match to avoid type getting simplified away recordNewtype :: CompiledCode (RecordNewtype -> Integer) -recordNewtype = plc (Proxy @"recordNewtype") (\(x :: RecordNewtype) -> case x of { RecordNewtype (MyNewtype i) -> i; }) +recordNewtype = + plc + (Proxy @"recordNewtype") + (\(x :: RecordNewtype) -> case x of RecordNewtype (MyNewtype i) -> i) -data RecordWithStrictField = RecordWithStrictField { strictField1 :: !MyMonoRecord, strictField2 :: !RecordNewtype } +data RecordWithStrictField = RecordWithStrictField {strictField1 :: !MyMonoRecord, strictField2 :: !RecordNewtype} -- checks that the type of 'strictField2' is replaced with 'Integer', see Note [On data constructor workers and wrappers] recordWithStrictField :: CompiledCode (RecordWithStrictField -> RecordNewtype) recordWithStrictField = plc (Proxy @"recordWithStrictField") (\(x :: RecordWithStrictField) -> strictField2 x) -data T = MkT !(Integer,Integer) +data T = MkT !(Integer, Integer) mkT :: (Integer, Integer) -> T mkT = MkT @@ -157,7 +171,10 @@ unusedWrapper = plc (Proxy @"unusedWrapper") ((\x (y, z) -> x (z, y)) mkT (1, 2) -- must be compiled with a lazy case nonValueCase :: CompiledCode (MyEnum -> Integer) -nonValueCase = plc (Proxy @"nonValueCase") (\(x :: MyEnum) -> case x of { Enum1 -> 1::Integer ; Enum2 -> Builtins.error (); }) +nonValueCase = + plc + (Proxy @"nonValueCase") + (\(x :: MyEnum) -> case x of Enum1 -> 1 :: Integer; Enum2 -> Builtins.error ()) data Credential = PubKeyCredential @@ -178,58 +195,68 @@ strictDataMatch = plc (Proxy @"strictDataMatch") (StrictTy 1 2) type Synonym = Integer synonym :: CompiledCode Integer -synonym = plc (Proxy @"synonym") (1::Synonym) +synonym = plc (Proxy @"synonym") (1 :: Synonym) polyData :: TestNested -polyData = testNested "polymorphic" [ - goldenPirReadable "polyDataType" polyDataType - , goldenPirReadable "polyConstructed" polyConstructed - , goldenPirReadable "defaultCasePoly" defaultCasePoly - ] +polyData = + testNested + "polymorphic" + [ goldenPirReadable "polyDataType" polyDataType + , goldenPirReadable "polyConstructed" polyConstructed + , goldenPirReadable "defaultCasePoly" defaultCasePoly + ] data MyPolyData a b = Poly1 a b | Poly2 a instance (P.Eq a, P.Eq b) => P.Eq (MyPolyData a b) where - {-# INLINABLE (==) #-} - (Poly1 a1 b1) == (Poly1 a2 b2) = a1 P.== a2 && b1 P.== b2 - (Poly2 a1) == (Poly2 a2) = a1 P.== a2 - _ == _ = False + {-# INLINEABLE (==) #-} + (Poly1 a1 b1) == (Poly1 a2 b2) = a1 P.== a2 && b1 P.== b2 + (Poly2 a1) == (Poly2 a2) = a1 P.== a2 + _ == _ = False -- pattern match to avoid type getting simplified away polyDataType :: CompiledCode (MyPolyData Integer Integer -> Integer) -polyDataType = plc (Proxy @"polyDataType") (\(x:: MyPolyData Integer Integer) -> case x of { Poly2 i -> i; _ -> 1; }) +polyDataType = + plc + (Proxy @"polyDataType") + (\(x :: MyPolyData Integer Integer) -> case x of Poly2 i -> i; _ -> 1) polyConstructed :: CompiledCode (MyPolyData Integer Integer) -polyConstructed = plc (Proxy @"polyConstructed") (Poly1 (1::Integer) (2::Integer)) +polyConstructed = plc (Proxy @"polyConstructed") (Poly1 (1 :: Integer) (2 :: Integer)) defaultCasePoly :: CompiledCode (MyPolyData Integer Integer -> Integer) -defaultCasePoly = plc (Proxy @"defaultCasePoly") (\(x :: MyPolyData Integer Integer) -> case x of { Poly1 a _ -> a ; _ -> 2; }) +defaultCasePoly = + plc + (Proxy @"defaultCasePoly") + (\(x :: MyPolyData Integer Integer) -> case x of Poly1 a _ -> a; _ -> 2) newtypes :: TestNested -newtypes = testNested "newtypes" [ - goldenPirReadable "basicNewtype" basicNewtype - , goldenPirReadable "newtypeMatch" newtypeMatch - , goldenPirReadable "newtypeCreate" newtypeCreate - , goldenPirReadable "newtypeId" newtypeId - , goldenPirReadable "newtypeCreate2" newtypeCreate2 - , goldenPirReadable "nestedNewtypeMatch" nestedNewtypeMatch - , goldenUEval "newtypeCreatDest" [ toUPlc $ newtypeMatch, toUPlc $ newtypeCreate2 ] - , goldenPirReadable "paramNewtype" paramNewtype - ] +newtypes = + testNested + "newtypes" + [ goldenPirReadable "basicNewtype" basicNewtype + , goldenPirReadable "newtypeMatch" newtypeMatch + , goldenPirReadable "newtypeCreate" newtypeCreate + , goldenPirReadable "newtypeId" newtypeId + , goldenPirReadable "newtypeCreate2" newtypeCreate2 + , goldenPirReadable "nestedNewtypeMatch" nestedNewtypeMatch + , goldenUEval "newtypeCreatDest" [toUPlc $ newtypeMatch, toUPlc $ newtypeCreate2] + , goldenPirReadable "paramNewtype" paramNewtype + ] newtype MyNewtype = MyNewtype Integer - deriving stock (Show, Eq) + deriving stock (Show, Eq) newtype MyNewtype2 = MyNewtype2 MyNewtype basicNewtype :: CompiledCode (MyNewtype -> MyNewtype) -basicNewtype = plc (Proxy @"basicNewtype") (\(x::MyNewtype) -> x) +basicNewtype = plc (Proxy @"basicNewtype") (\(x :: MyNewtype) -> x) newtypeMatch :: CompiledCode (MyNewtype -> Integer) newtypeMatch = plc (Proxy @"newtypeMatch") (\(MyNewtype x) -> x) newtypeCreate :: CompiledCode (Integer -> MyNewtype) -newtypeCreate = plc (Proxy @"newtypeCreate") (\(x::Integer) -> MyNewtype x) +newtypeCreate = plc (Proxy @"newtypeCreate") (\(x :: Integer) -> MyNewtype x) newtypeId :: CompiledCode (MyNewtype -> MyNewtype) newtypeId = plc (Proxy @"newtypeId") (\(MyNewtype x) -> MyNewtype x) @@ -244,42 +271,47 @@ newtype ParamNewtype a = ParamNewtype (Maybe a) -- pattern match to avoid type getting simplified away paramNewtype :: CompiledCode (ParamNewtype Integer -> Integer) -paramNewtype = plc (Proxy @"paramNewtype") (\(x ::ParamNewtype Integer) -> case x of { ParamNewtype (Just i) -> i; _ -> 1 }) +paramNewtype = + plc + (Proxy @"paramNewtype") + (\(x :: ParamNewtype Integer) -> case x of ParamNewtype (Just i) -> i; _ -> 1) recursiveTypes :: TestNested -recursiveTypes = testNested "recursive" [ - goldenPirReadable "listConstruct" listConstruct +recursiveTypes = + testNested + "recursive" + [ goldenPirReadable "listConstruct" listConstruct , goldenPirReadable "listConstruct2" listConstruct2 , goldenPirReadable "listConstruct3" listConstruct3 , goldenPirReadable "listMatch" listMatch - , goldenUEval "listConstDest" [ toUPlc listMatch, toUPlc listConstruct ] - , goldenUEval "listConstDest2" [ toUPlc listMatch, toUPlc listConstruct2 ] + , goldenUEval "listConstDest" [toUPlc listMatch, toUPlc listConstruct] + , goldenUEval "listConstDest2" [toUPlc listMatch, toUPlc listConstruct2] , goldenPirReadable "ptreeConstruct" ptreeConstruct , goldenPirReadable "ptreeMatch" ptreeMatch - , goldenUEval "ptreeConstDest" [ toUPlc ptreeMatch, toUPlc ptreeConstruct ] - , goldenUEval "polyRecEval" [ toUPlc polyRec, toUPlc ptreeConstruct ] - , goldenUEval "ptreeFirstEval" [ toUPlc ptreeFirst, toUPlc ptreeConstruct ] - , goldenUEval "sameEmptyRoseEval" [ toUPlc sameEmptyRose, toUPlc emptyRoseConstruct ] + , goldenUEval "ptreeConstDest" [toUPlc ptreeMatch, toUPlc ptreeConstruct] + , goldenUEval "polyRecEval" [toUPlc polyRec, toUPlc ptreeConstruct] + , goldenUEval "ptreeFirstEval" [toUPlc ptreeFirst, toUPlc ptreeConstruct] + , goldenUEval "sameEmptyRoseEval" [toUPlc sameEmptyRose, toUPlc emptyRoseConstruct] , goldenUPlc "sameEmptyRose" sameEmptyRose , goldenTPlcReadable "interListConstruct" interListConstruct - , goldenUEval "processInterListEval" [ toUPlc processInterList, toUPlc interListConstruct ] - ] + , goldenUEval "processInterListEval" [toUPlc processInterList, toUPlc interListConstruct] + ] listConstruct :: CompiledCode [Integer] -listConstruct = plc (Proxy @"listConstruct") ([]::[Integer]) +listConstruct = plc (Proxy @"listConstruct") ([] :: [Integer]) -- This will generate code using 'build' if we're on greater than -O0. That's not optimal for -- us, since we don't have any rewrite rules to fire, but it's fine and we can handle it. listConstruct2 :: CompiledCode [Integer] -listConstruct2 = plc (Proxy @"listConstruct2") ([1]::[Integer]) +listConstruct2 = plc (Proxy @"listConstruct2") ([1] :: [Integer]) -- It is very difficult to get GHC to make a non-polymorphic redex if you use -- list literal syntax with integers. But this works. listConstruct3 :: CompiledCode [Integer] -listConstruct3 = plc (Proxy @"listConstruct3") ((1::Integer):(2::Integer):(3::Integer):[]) +listConstruct3 = plc (Proxy @"listConstruct3") ((1 :: Integer) : (2 :: Integer) : (3 :: Integer) : []) listMatch :: CompiledCode ([Integer] -> Integer) -listMatch = plc (Proxy @"listMatch") (\(l::[Integer]) -> case l of { (x:_) -> x ; [] -> 0; }) +listMatch = plc (Proxy @"listMatch") (\(l :: [Integer]) -> case l of (x : _) -> x; [] -> 0) {- Note [Non-regular data types in tests] A non-regular data type, a.k.a. a nested data type is, quoting "Nested Datatypes" by Richard Bird @@ -290,33 +322,42 @@ of them. -} -- See Note [Non-regular data types in tests]. + -- | A type of perfectly balanced binary trees. data B a = One a | Two (B (a, a)) ptreeConstruct :: CompiledCode (B Integer) -ptreeConstruct = plc (Proxy @"ptreeConstruct") (Two (Two (One ((1,2),(3,4)))) :: B Integer) +ptreeConstruct = plc (Proxy @"ptreeConstruct") (Two (Two (One ((1, 2), (3, 4)))) :: B Integer) -- TODO: replace this with 'first' when we have working recursive functions ptreeMatch :: CompiledCode (B Integer -> Integer) -ptreeMatch = plc (Proxy @"ptreeMatch") (\(t::B Integer) -> case t of { One a -> a; Two _ -> 2; }) +ptreeMatch = plc (Proxy @"ptreeMatch") (\(t :: B Integer) -> case t of One a -> a; Two _ -> 2) polyRec :: CompiledCode (B Integer -> Integer) -polyRec = plc (Proxy @"polyRec") ( - let +polyRec = + plc + (Proxy @"polyRec") + ( let depth :: B a -> Integer depth tree = case tree of - One _ -> 1 - Two inner -> Builtins.addInteger 1 (depth inner) - in \(t::B Integer) -> depth t) + One _ -> 1 + Two inner -> Builtins.addInteger 1 (depth inner) + in + \(t :: B Integer) -> depth t + ) ptreeFirst :: CompiledCode (B Integer -> Integer) -ptreeFirst = plc (Proxy @"ptreeFirst") ( - let go :: (a -> Integer) -> B a -> Integer - go k (One x) = k x - go k (Two b) = go (\(x, _) -> k x) b - in go (\x -> x)) +ptreeFirst = + plc + (Proxy @"ptreeFirst") + ( let go :: (a -> Integer) -> B a -> Integer + go k (One x) = k x + go k (Two b) = go (\(x, _) -> k x) b + in go (\x -> x) + ) -- See Note [Non-regular data types in tests]. + -- | A type of rose trees with empty leaves. data EmptyRose = EmptyRose [EmptyRose] @@ -324,53 +365,64 @@ emptyRoseConstruct :: CompiledCode EmptyRose emptyRoseConstruct = plc (Proxy @"emptyRoseConstruct") (EmptyRose [EmptyRose [], EmptyRose []]) sameEmptyRose :: CompiledCode (EmptyRose -> EmptyRose) -sameEmptyRose = plc (Proxy @"sameEmptyRose") ( - -- The type signatures are needed due to a bug (see 'emptyRoseNewId') - let (.|) :: ([EmptyRose] -> [EmptyRose]) -> (EmptyRose -> [EmptyRose]) -> EmptyRose -> [EmptyRose] - (.|) = \g f x -> g (f x) - (|.) :: ([EmptyRose] -> EmptyRose) -> (EmptyRose -> [EmptyRose]) -> EmptyRose -> EmptyRose - (|.) = \g f x -> g (f x) - map :: (EmptyRose -> EmptyRose) -> [EmptyRose] -> [EmptyRose] - map _ [] = [] - map f (x:xs) = f x : map f xs - unEmptyRose (EmptyRose x) = x - go = EmptyRose |. (map go .| unEmptyRose) - in go) +sameEmptyRose = + plc + (Proxy @"sameEmptyRose") + ( -- The type signatures are needed due to a bug (see 'emptyRoseNewId') + let (.|) :: ([EmptyRose] -> [EmptyRose]) -> (EmptyRose -> [EmptyRose]) -> EmptyRose -> [EmptyRose] + (.|) = \g f x -> g (f x) + (|.) :: ([EmptyRose] -> EmptyRose) -> (EmptyRose -> [EmptyRose]) -> EmptyRose -> EmptyRose + (|.) = \g f x -> g (f x) + map :: (EmptyRose -> EmptyRose) -> [EmptyRose] -> [EmptyRose] + map _ [] = [] + map f (x : xs) = f x : map f xs + unEmptyRose (EmptyRose x) = x + go = EmptyRose |. (map go .| unEmptyRose) + in go + ) -- See Note [Non-regular data types in tests]. --- | A type of lists containing two values at each node, with the types of those values getting --- swapped each time we move from one node to the next one. + +{-| A type of lists containing two values at each node, with the types of those values getting +swapped each time we move from one node to the next one. +-} data InterList a b - = InterNil - | InterCons a b (InterList b a) -- Note that the parameters get swapped. + = InterNil + | InterCons a b (InterList b a) -- Note that the parameters get swapped. interListConstruct :: CompiledCode (InterList Integer Bool) interListConstruct = - plc - (Proxy @"interListConstruct") - (InterCons 0 False (InterCons False (-1) (InterCons 42 True InterNil))) + plc + (Proxy @"interListConstruct") + (InterCons 0 False (InterCons False (-1) (InterCons 42 True InterNil))) processInterList :: CompiledCode (InterList Integer Bool -> Integer) -processInterList = plc (Proxy @"foldrInterList") ( - let foldrInterList :: forall a b r. (a -> b -> r -> r) -> r -> InterList a b -> r - foldrInterList f0 z = go f0 where - go :: forall a b. (a -> b -> r -> r) -> InterList a b -> r - go _ InterNil = z - go f (InterCons x y xs) = f x y (go (flip f) xs) - in foldrInterList (\x b r -> if b then x else r) 0) +processInterList = + plc + (Proxy @"foldrInterList") + ( let foldrInterList :: forall a b r. (a -> b -> r -> r) -> r -> InterList a b -> r + foldrInterList f0 z = go f0 + where + go :: forall a b. (a -> b -> r -> r) -> InterList a b -> r + go _ InterNil = z + go f (InterCons x y xs) = f x y (go (flip f) xs) + in foldrInterList (\x b r -> if b then x else r) 0 + ) typeFamilies :: TestNested -typeFamilies = testNested "families" [ - goldenPirReadable "basicClosed" basicClosed +typeFamilies = + testNested + "families" + [ goldenPirReadable "basicClosed" basicClosed , goldenPirReadable "basicOpen" basicOpen , goldenPirReadable "associated" associated , goldenPirReadable "associatedParam" associatedParam , goldenPirReadable "basicData" basicData , goldenUPlc "irreducible" irreducible - ] + ] type family BasicClosed a where - BasicClosed Bool = Integer + BasicClosed Bool = Integer basicClosed :: CompiledCode (BasicClosed Bool -> BasicClosed Bool) basicClosed = plc (Proxy @"basicClosed") (\(x :: BasicClosed Bool) -> x) @@ -382,21 +434,21 @@ basicOpen :: CompiledCode (BasicOpen Bool -> BasicOpen Bool) basicOpen = plc (Proxy @"basicOpen") (\(x :: BasicOpen Bool) -> x) class Associated a where - type AType a + type AType a instance Associated Bool where - type instance AType Bool = Integer + type AType Bool = Integer data Param a = Param a instance Associated (Param a) where - type instance AType (Param a) = a + type AType (Param a) = a associated :: CompiledCode (AType Bool -> AType Bool) associated = plc (Proxy @"associated") (\(x :: AType Bool) -> x) -- Despite the type family being applied to a parameterized type we can still reduce it -paramId :: forall a . Param a -> AType (Param a) -> AType (Param a) +paramId :: forall a. Param a -> AType (Param a) -> AType (Param a) paramId _ x = x {-# OPAQUE paramId #-} @@ -404,8 +456,13 @@ associatedParam :: CompiledCode Integer associatedParam = plc (Proxy @"associatedParam") (paramId (Param 1) 1) -- Here we cannot reduce the type family +{- FOURMOLU_DISABLE -} +-- Because of fourmolu/ourmolu bug (https://github.com/fourmolu/fourmolu/issues/475) +-- we need to wrap OPTIONS_GHC pragma with FOURMOLU disable and enable. Without this, +-- every comment preceding OPTIONS_GHC pragma will be pushed to the very top of the file. {-# OPTIONS_GHC -Wno-incomplete-patterns #-} -tfId :: forall a . a -> BasicClosed a -> BasicClosed a +{- FOURMOLU_ENABLE -} +tfId :: forall a. a -> BasicClosed a -> BasicClosed a tfId _ x = x {-# OPAQUE tfId #-} diff --git a/plutus-tx-plugin/test/Plugin/Debug/9.6/fib.pir.golden b/plutus-tx-plugin/test/Plugin/Debug/9.6/fib.pir.golden index 45afefbea79..4f89764b98f 100644 --- a/plutus-tx-plugin/test/Plugin/Debug/9.6/fib.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Debug/9.6/fib.pir.golden @@ -296,151 +296,151 @@ n (con { no-src-span } integer) (let - { test/Plugin/Debug/Spec.hs:46:15-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58 } (nonrec) (termbind - { test/Plugin/Debug/Spec.hs:46:15-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58 } (strict) (vardecl - { test/Plugin/Debug/Spec.hs:46:15-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58 } n - (con { test/Plugin/Debug/Spec.hs:46:15-55:72 } integer) + (con { test/Plugin/Debug/Spec.hs:47:11-56:58 } integer) ) - { test/Plugin/Debug/Spec.hs:46:15-55:72 } n + { test/Plugin/Debug/Spec.hs:47:11-56:58 } n ) { - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } { - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } Bool_match [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } equalsInteger - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:47:43-47:43 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:48:39-48:39 } n ] (con - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:47:45-47:45 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:48:41-48:41 } integer 0 ) ] ] (all - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } dead - ({ test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + ({ test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } type) (con - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } integer ) ) } (abs - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } dead - ({ test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + ({ test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } type) (con - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:48:26-48:26 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:49:20-49:20 } integer 0 ) ) ] (abs - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } dead - ({ test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + ({ test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } type) { - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } { - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } Bool_match [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } equalsInteger - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:50:51-50:51 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:51:43-51:43 } n ] (con - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:50:53-50:53 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:51:45-51:45 } integer 1 ) ] ] (all - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } dead - ({ test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + ({ test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } type) (con - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } integer ) ) } (abs - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } dead - ({ test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + ({ test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } type) (con - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:51:34-51:34 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:52:24-52:24 } integer 1 ) ) ] (abs - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } dead - ({ test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + ({ test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } type) [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58 } [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72 } - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58 } addInteger [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:54:37-54:72 } - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:54:37-54:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:55:23-55:58 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:55:23-55:58 } fib [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:54:37-54:72, test/Plugin/Debug/Spec.hs:54:42-54:71 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:55:23-55:58, test/Plugin/Debug/Spec.hs:55:28-55:57 } [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:54:37-54:72, test/Plugin/Debug/Spec.hs:54:42-54:71 } - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:54:37-54:72, test/Plugin/Debug/Spec.hs:54:42-54:71 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:55:23-55:58, test/Plugin/Debug/Spec.hs:55:28-55:57 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:55:23-55:58, test/Plugin/Debug/Spec.hs:55:28-55:57 } subtractInteger - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:54:37-54:72, test/Plugin/Debug/Spec.hs:54:42-54:71, test/Plugin/Debug/Spec.hs:54:68-54:68 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:55:23-55:58, test/Plugin/Debug/Spec.hs:55:28-55:57, test/Plugin/Debug/Spec.hs:55:54-55:54 } n ] (con - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:54:37-54:72, test/Plugin/Debug/Spec.hs:54:42-54:71, test/Plugin/Debug/Spec.hs:54:70-54:70 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:55:23-55:58, test/Plugin/Debug/Spec.hs:55:28-55:57, test/Plugin/Debug/Spec.hs:55:56-55:56 } integer 1 ) @@ -448,20 +448,20 @@ ] ] [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:55:37-55:72 } - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:55:37-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:56:23-56:58 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:56:23-56:58 } fib [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:55:37-55:72, test/Plugin/Debug/Spec.hs:55:42-55:71 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:56:23-56:58, test/Plugin/Debug/Spec.hs:56:28-56:57 } [ - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:55:37-55:72, test/Plugin/Debug/Spec.hs:55:42-55:71 } - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:55:37-55:72, test/Plugin/Debug/Spec.hs:55:42-55:71 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:56:23-56:58, test/Plugin/Debug/Spec.hs:56:28-56:57 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:56:23-56:58, test/Plugin/Debug/Spec.hs:56:28-56:57 } subtractInteger - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:55:37-55:72, test/Plugin/Debug/Spec.hs:55:42-55:71, test/Plugin/Debug/Spec.hs:55:68-55:68 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:56:23-56:58, test/Plugin/Debug/Spec.hs:56:28-56:57, test/Plugin/Debug/Spec.hs:56:54-56:54 } n ] (con - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72, test/Plugin/Debug/Spec.hs:53:33-55:72, test/Plugin/Debug/Spec.hs:55:37-55:72, test/Plugin/Debug/Spec.hs:55:42-55:71, test/Plugin/Debug/Spec.hs:55:70-55:70 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58, test/Plugin/Debug/Spec.hs:54:21-56:58, test/Plugin/Debug/Spec.hs:56:23-56:58, test/Plugin/Debug/Spec.hs:56:28-56:57, test/Plugin/Debug/Spec.hs:56:56-56:56 } integer 2 ) @@ -471,29 +471,29 @@ ) ] (all - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } dead - ({ test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + ({ test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } type) - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72, test/Plugin/Debug/Spec.hs:50:25-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58, test/Plugin/Debug/Spec.hs:51:17-56:58 } dead ) } ) ] (all - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } dead - ({ test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + ({ test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } type) - { test/Plugin/Debug/Spec.hs:46:15-55:72, test/Plugin/Debug/Spec.hs:47:17-55:72 } + { test/Plugin/Debug/Spec.hs:47:11-56:58, test/Plugin/Debug/Spec.hs:48:13-56:58 } dead ) } ) ) ) - { test/Plugin/Debug/Spec.hs:45:9-57:9 } fib + { test/Plugin/Debug/Spec.hs:46:5-58:5 } fib ) ) ) \ No newline at end of file diff --git a/plutus-tx-plugin/test/Plugin/Debug/9.6/letFun.pir.golden b/plutus-tx-plugin/test/Plugin/Debug/9.6/letFun.pir.golden index 4c61eb0073f..9c0ea15b4f1 100644 --- a/plutus-tx-plugin/test/Plugin/Debug/9.6/letFun.pir.golden +++ b/plutus-tx-plugin/test/Plugin/Debug/9.6/letFun.pir.golden @@ -137,45 +137,45 @@ ds (con { no-src-span } integer) (let - { test/Plugin/Debug/Spec.hs:38:9-38:87 } + { test/Plugin/Debug/Spec.hs:39:5-39:83 } (nonrec) (termbind - { test/Plugin/Debug/Spec.hs:38:9-38:87 } + { test/Plugin/Debug/Spec.hs:39:5-39:83 } (strict) (vardecl - { test/Plugin/Debug/Spec.hs:38:9-38:87 } + { test/Plugin/Debug/Spec.hs:39:5-39:83 } ds - (con { test/Plugin/Debug/Spec.hs:38:9-38:87 } integer) + (con { test/Plugin/Debug/Spec.hs:39:5-39:83 } integer) ) - { test/Plugin/Debug/Spec.hs:38:9-38:87 } ds + { test/Plugin/Debug/Spec.hs:39:5-39:83 } ds ) (lam { no-src-span } ds (con { no-src-span } integer) (let - { test/Plugin/Debug/Spec.hs:38:9-38:87 } + { test/Plugin/Debug/Spec.hs:39:5-39:83 } (nonrec) (termbind - { test/Plugin/Debug/Spec.hs:38:9-38:87 } + { test/Plugin/Debug/Spec.hs:39:5-39:83 } (strict) (vardecl - { test/Plugin/Debug/Spec.hs:38:9-38:87 } + { test/Plugin/Debug/Spec.hs:39:5-39:83 } ds - (con { test/Plugin/Debug/Spec.hs:38:9-38:87 } integer) + (con { test/Plugin/Debug/Spec.hs:39:5-39:83 } integer) ) - { test/Plugin/Debug/Spec.hs:38:9-38:87 } ds + { test/Plugin/Debug/Spec.hs:39:5-39:83 } ds ) [ - { test/Plugin/Debug/Spec.hs:38:9-38:87, test/Plugin/Debug/Spec.hs:38:44-38:86, test/Plugin/Debug/Spec.hs:38:54-38:79 } + { test/Plugin/Debug/Spec.hs:39:5-39:83, test/Plugin/Debug/Spec.hs:39:40-39:82, test/Plugin/Debug/Spec.hs:39:50-39:75 } [ - { test/Plugin/Debug/Spec.hs:38:9-38:87, test/Plugin/Debug/Spec.hs:38:44-38:86, test/Plugin/Debug/Spec.hs:38:54-38:79 } - { test/Plugin/Debug/Spec.hs:38:9-38:87, test/Plugin/Debug/Spec.hs:38:44-38:86, test/Plugin/Debug/Spec.hs:38:54-38:79 } + { test/Plugin/Debug/Spec.hs:39:5-39:83, test/Plugin/Debug/Spec.hs:39:40-39:82, test/Plugin/Debug/Spec.hs:39:50-39:75 } + { test/Plugin/Debug/Spec.hs:39:5-39:83, test/Plugin/Debug/Spec.hs:39:40-39:82, test/Plugin/Debug/Spec.hs:39:50-39:75 } equalsInteger - { test/Plugin/Debug/Spec.hs:38:9-38:87, test/Plugin/Debug/Spec.hs:38:44-38:86, test/Plugin/Debug/Spec.hs:38:54-38:79, test/Plugin/Debug/Spec.hs:38:77-38:77 } + { test/Plugin/Debug/Spec.hs:39:5-39:83, test/Plugin/Debug/Spec.hs:39:40-39:82, test/Plugin/Debug/Spec.hs:39:50-39:75, test/Plugin/Debug/Spec.hs:39:73-39:73 } ds ] - { test/Plugin/Debug/Spec.hs:38:9-38:87, test/Plugin/Debug/Spec.hs:38:44-38:86, test/Plugin/Debug/Spec.hs:38:54-38:79, test/Plugin/Debug/Spec.hs:38:79-38:79 } + { test/Plugin/Debug/Spec.hs:39:5-39:83, test/Plugin/Debug/Spec.hs:39:40-39:82, test/Plugin/Debug/Spec.hs:39:50-39:75, test/Plugin/Debug/Spec.hs:39:75-39:75 } ds ] ) diff --git a/plutus-tx-plugin/test/Plugin/Debug/Spec.hs b/plutus-tx-plugin/test/Plugin/Debug/Spec.hs index e389a31eb86..854a5d46034 100644 --- a/plutus-tx-plugin/test/Plugin/Debug/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Debug/Spec.hs @@ -6,9 +6,9 @@ {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} module Plugin.Debug.Spec where @@ -24,34 +24,35 @@ import Data.Proxy debug :: TestNested debug = - testNested "Debug" . pure $ testNestedGhc - [ goldenPirBy config "letFun" letFun - , goldenPirBy config "fib" fib - ] - where - config = PrettyConfigClassic prettyConfigNameSimple True + testNested "Debug" . pure $ + testNestedGhc + [ goldenPirBy config "letFun" letFun + , goldenPirBy config "fib" fib + ] + where + config = PrettyConfigClassic prettyConfigNameSimple True letFun :: CompiledCode (Integer -> Integer -> Bool) letFun = - plc - (Proxy @"letFun") - (\(x :: Integer) (y :: Integer) -> let f z = Builtins.equalsInteger x z in f y) + plc + (Proxy @"letFun") + (\(x :: Integer) (y :: Integer) -> let f z = Builtins.equalsInteger x z in f y) fib :: CompiledCode (Integer -> Integer) -- not using case to avoid literal cases fib = - plc - (Proxy @"fib") - ( let fib :: Integer -> Integer - fib n = - if Builtins.equalsInteger n 0 - then 0 - else - if Builtins.equalsInteger n 1 - then 1 - else - Builtins.addInteger - (fib (Builtins.subtractInteger n 1)) - (fib (Builtins.subtractInteger n 2)) - in fib - ) + plc + (Proxy @"fib") + ( let fib :: Integer -> Integer + fib n = + if Builtins.equalsInteger n 0 + then 0 + else + if Builtins.equalsInteger n 1 + then 1 + else + Builtins.addInteger + (fib (Builtins.subtractInteger n 1)) + (fib (Builtins.subtractInteger n 2)) + in fib + ) diff --git a/plutus-tx-plugin/test/Plugin/Errors/Spec.hs b/plutus-tx-plugin/test/Plugin/Errors/Spec.hs index 526bc5bd92c..77d1a809537 100644 --- a/plutus-tx-plugin/test/Plugin/Errors/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Errors/Spec.hs @@ -5,13 +5,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} module Plugin.Errors.Spec where @@ -34,37 +34,39 @@ import GHC.Num.Integer {- HLINT ignore -} errors :: TestNested -errors = testNested "Errors" . pure $ testNestedGhc - [ goldenUPlc "machInt" machInt - -- FIXME: This fails differently in nix, possibly due to slightly different optimization settings - -- , goldenPlc "negativeInt" negativeInt - , goldenUPlc "caseInt" caseInt - , goldenUPlc "stringLiteral" stringLiteral - , goldenUPlc "recursiveNewtype" recursiveNewtype - , goldenUPlc "mutualRecursionUnfoldingsLocal" mutualRecursionUnfoldingsLocal - , goldenUPlc "literalCaseInt" literalCaseInt - , goldenUPlc "literalCaseBs" literalCaseBs - , goldenUPlc "literalAppendBs" literalAppendBs - , goldenUPlc "literalCaseOther" literalCaseOther - , goldenUPlc "rangeEnumFromTo" rangeEnumFromTo - , goldenUPlc "rangeEnumFromThenTo" rangeEnumFromThenTo - , goldenUPlc "rangeEnumFrom" rangeEnumFrom - , goldenUPlc "rangeEnumFromThen" rangeEnumFromThen - , goldenUPlc "toBuiltinUsed" toBuiltinUsed - , goldenUPlc "fromBuiltinUsed" fromBuiltinUsed - ] +errors = + testNested "Errors" . pure $ + testNestedGhc + [ goldenUPlc "machInt" machInt + , -- FIXME: This fails differently in nix, possibly due to slightly different optimization settings + -- , goldenPlc "negativeInt" negativeInt + goldenUPlc "caseInt" caseInt + , goldenUPlc "stringLiteral" stringLiteral + , goldenUPlc "recursiveNewtype" recursiveNewtype + , goldenUPlc "mutualRecursionUnfoldingsLocal" mutualRecursionUnfoldingsLocal + , goldenUPlc "literalCaseInt" literalCaseInt + , goldenUPlc "literalCaseBs" literalCaseBs + , goldenUPlc "literalAppendBs" literalAppendBs + , goldenUPlc "literalCaseOther" literalCaseOther + , goldenUPlc "rangeEnumFromTo" rangeEnumFromTo + , goldenUPlc "rangeEnumFromThenTo" rangeEnumFromThenTo + , goldenUPlc "rangeEnumFrom" rangeEnumFrom + , goldenUPlc "rangeEnumFromThen" rangeEnumFromThen + , goldenUPlc "toBuiltinUsed" toBuiltinUsed + , goldenUPlc "fromBuiltinUsed" fromBuiltinUsed + ] machInt :: CompiledCode Int -machInt = plc (Proxy @"machInt") (1::Int) +machInt = plc (Proxy @"machInt") (1 :: Int) negativeInt :: CompiledCode Integer negativeInt = plc (Proxy @"negativeInt") (-1 :: Integer) caseInt :: CompiledCode (Integer -> Bool) -caseInt = plc (Proxy @"caseInt") (\(i::Integer) -> case i of { IS _ -> True; _ -> False; } ) +caseInt = plc (Proxy @"caseInt") (\(i :: Integer) -> case i of IS _ -> True; _ -> False) stringLiteral :: CompiledCode String -stringLiteral = plc (Proxy @"stringLiteral") ("hello"::String) +stringLiteral = plc (Proxy @"stringLiteral") ("hello" :: String) newtype RecursiveNewtype = RecursiveNewtype [RecursiveNewtype] @@ -73,21 +75,21 @@ recursiveNewtype = plc (Proxy @"recursiveNewtype") (RecursiveNewtype []) evenDirectLocal :: Integer -> Bool evenDirectLocal n = if Builtins.equalsInteger n 0 then True else oddDirectLocal (Builtins.subtractInteger n 1) -{-# INLINABLE evenDirectLocal #-} +{-# INLINEABLE evenDirectLocal #-} oddDirectLocal :: Integer -> Bool oddDirectLocal n = if Builtins.equalsInteger n 0 then False else evenDirectLocal (Builtins.subtractInteger n 1) -{-# INLINABLE oddDirectLocal #-} +{-# INLINEABLE oddDirectLocal #-} -- FIXME: these seem to only get unfoldings when they're in a separate module, even with the simplifier pass mutualRecursionUnfoldingsLocal :: CompiledCode Bool mutualRecursionUnfoldingsLocal = plc (Proxy @"mutualRecursionUnfoldingsLocal") (evenDirectLocal 4) literalCaseInt :: CompiledCode (Integer -> Integer) -literalCaseInt = plc (Proxy @"literalCaseInt") (\case { 1 -> 2; x -> x}) +literalCaseInt = plc (Proxy @"literalCaseInt") (\case 1 -> 2; x -> x) literalCaseBs :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString) -literalCaseBs = plc (Proxy @"literalCaseBs") (\x -> case x of { "abc" -> ""; x -> x}) +literalCaseBs = plc (Proxy @"literalCaseBs") (\x -> case x of "abc" -> ""; x -> x) literalAppendBs :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString) literalAppendBs = plc (Proxy @"literalAppendBs") (\x -> Builtins.appendByteString "hello" x) @@ -95,27 +97,27 @@ literalAppendBs = plc (Proxy @"literalAppendBs") (\x -> Builtins.appendByteStrin data AType = AType instance IsString AType where - fromString _ = AType + fromString _ = AType instance Eq AType where - AType == AType = True + AType == AType = True literalCaseOther :: CompiledCode (AType -> AType) -literalCaseOther = plc (Proxy @"literalCaseOther") (\x -> case x of { "abc" -> ""; x -> x}) +literalCaseOther = plc (Proxy @"literalCaseOther") (\x -> case x of "abc" -> ""; x -> x) -- Tests for literal ranges (and the corresponding methods in GHC.Enum). These -- should all fail with informative error messages. rangeEnumFromTo :: CompiledCode [Integer] -rangeEnumFromTo = plc (Proxy @"rangeEnumFromTo") [1..50] +rangeEnumFromTo = plc (Proxy @"rangeEnumFromTo") [1 .. 50] rangeEnumFromThenTo :: CompiledCode [Integer] -rangeEnumFromThenTo = plc (Proxy @"rangeEnumFromThenTo") [1,7..50] +rangeEnumFromThenTo = plc (Proxy @"rangeEnumFromThenTo") [1, 7 .. 50] rangeEnumFrom :: CompiledCode [Integer] -rangeEnumFrom = plc (Proxy @"rangeEnumFrom") [1..] +rangeEnumFrom = plc (Proxy @"rangeEnumFrom") [1 ..] rangeEnumFromThen :: CompiledCode [Integer] -rangeEnumFromThen = plc (Proxy @"rangeEnumFromThen") [1,5..] +rangeEnumFromThen = plc (Proxy @"rangeEnumFromThen") [1, 5 ..] toBuiltinUsed :: CompiledCode (Integer -> Integer) toBuiltinUsed = plc (Proxy @"toBuiltinUsed") Builtins.toBuiltin diff --git a/plutus-tx-plugin/test/Plugin/Functions/Spec.hs b/plutus-tx-plugin/test/Plugin/Functions/Spec.hs index 568c4f12519..30e797401c0 100644 --- a/plutus-tx-plugin/test/Plugin/Functions/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Functions/Spec.hs @@ -6,13 +6,13 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UnboxedTuples #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} module Plugin.Functions.Spec where @@ -30,61 +30,76 @@ import PlutusTx.Test import Data.Proxy functions :: TestNested -functions = testNested "Functions" . pure $ testNestedGhc - [ recursiveFunctions - , unfoldings - ] +functions = + testNested "Functions" . pure $ + testNestedGhc + [ recursiveFunctions + , unfoldings + ] recursiveFunctions :: TestNested -recursiveFunctions = testNested "recursive" [ - goldenPirReadable "fib" fib - , goldenUEval "fib4" [ toUPlc fib, toUPlc $ plc (Proxy @"4") (4::Integer) ] +recursiveFunctions = + testNested + "recursive" + [ goldenPirReadable "fib" fib + , goldenUEval "fib4" [toUPlc fib, toUPlc $ plc (Proxy @"4") (4 :: Integer)] , goldenPirReadable "sum" sumDirect - , goldenUEval "sumList" [ toUPlc sumDirect, toUPlc listConstruct3 ] + , goldenUEval "sumList" [toUPlc sumDirect, toUPlc listConstruct3] , goldenPirReadable "even" evenMutual - , goldenUEval "even3" [ toUPlc evenMutual, toUPlc $ plc (Proxy @"3") (3::Integer) ] - , goldenUEval "even4" [ toUPlc evenMutual, toUPlc $ plc (Proxy @"4") (4::Integer) ] + , goldenUEval "even3" [toUPlc evenMutual, toUPlc $ plc (Proxy @"3") (3 :: Integer)] + , goldenUEval "even4" [toUPlc evenMutual, toUPlc $ plc (Proxy @"4") (4 :: Integer)] , goldenPirReadable "strictLength" strictLength , goldenPirReadable "lazyLength" lazyLength - ] + ] fib :: CompiledCode (Integer -> Integer) -- not using case to avoid literal cases -fib = plc (Proxy @"fib") ( - let fib :: Integer -> Integer - fib n = if Builtins.equalsInteger n 0 - then 0 - else if Builtins.equalsInteger n 1 - then 1 - else Builtins.addInteger (fib(Builtins.subtractInteger n 1)) (fib(Builtins.subtractInteger n 2)) - in fib) +fib = + plc + (Proxy @"fib") + ( let fib :: Integer -> Integer + fib n = + if Builtins.equalsInteger n 0 + then 0 + else + if Builtins.equalsInteger n 1 + then 1 + else Builtins.addInteger (fib (Builtins.subtractInteger n 1)) (fib (Builtins.subtractInteger n 2)) + in fib + ) sumDirect :: CompiledCode ([Integer] -> Integer) -sumDirect = plc (Proxy @"sumDirect") ( - let sum :: [Integer] -> Integer - sum [] = 0 - sum (x:xs) = Builtins.addInteger x (sum xs) - in sum) +sumDirect = + plc + (Proxy @"sumDirect") + ( let sum :: [Integer] -> Integer + sum [] = 0 + sum (x : xs) = Builtins.addInteger x (sum xs) + in sum + ) evenMutual :: CompiledCode (Integer -> Bool) -evenMutual = plc (Proxy @"evenMutual") ( - let even :: Integer -> Bool - even n = if Builtins.equalsInteger n 0 then True else odd (Builtins.subtractInteger n 1) - odd :: Integer -> Bool - odd n = if Builtins.equalsInteger n 0 then False else even (Builtins.subtractInteger n 1) - in even) +evenMutual = + plc + (Proxy @"evenMutual") + ( let even :: Integer -> Bool + even n = if Builtins.equalsInteger n 0 then True else odd (Builtins.subtractInteger n 1) + odd :: Integer -> Bool + odd n = if Builtins.equalsInteger n 0 then False else even (Builtins.subtractInteger n 1) + in even + ) lengthStrict :: [a] -> Integer lengthStrict l = go 0 l - where - go !acc [] = acc - go !acc (_: tl) = go (acc `Builtins.addInteger` 1) tl + where + go !acc [] = acc + go !acc (_ : tl) = go (acc `Builtins.addInteger` 1) tl lengthLazy :: [a] -> Integer lengthLazy l = go 0 l - where - go acc [] = acc - go acc (_: tl) = go (acc `Builtins.addInteger` 1) tl + where + go acc [] = acc + go acc (_ : tl) = go (acc `Builtins.addInteger` 1) tl strictLength :: CompiledCode ([Integer] -> Integer) strictLength = plc (Proxy @"strictLength") (lengthStrict @Integer) @@ -93,18 +108,20 @@ lazyLength :: CompiledCode ([Integer] -> Integer) lazyLength = plc (Proxy @"lazyLength") (lengthLazy @Integer) unfoldings :: TestNested -unfoldings = testNested "unfoldings" [ - goldenPirReadable "nandDirect" nandPlcDirect +unfoldings = + testNested + "unfoldings" + [ goldenPirReadable "nandDirect" nandPlcDirect , goldenPirReadable "andDirect" andPlcDirect , goldenPirReadable "andExternal" andPlcExternal , goldenPirReadable "allDirect" allPlcDirect , goldenPirReadable "mutualRecursionUnfoldings" mutualRecursionUnfoldings , goldenPirReadable "recordSelector" recordSelector , goldenPirReadable "recordSelectorExternal" recordSelectorExternal - -- We used to have problems with polymorphic let bindings where the generalization was - -- on the outside of the let, which hit the value restriction. Now we hit the simplifier - -- it seems to sometimes float these in, but we should keep an eye on these. - , goldenPirReadable "polyMap" polyMap + , -- We used to have problems with polymorphic let bindings where the generalization was + -- on the outside of the let, which hit the value restriction. Now we hit the simplifier + -- it seems to sometimes float these in, but we should keep an eye on these. + goldenPirReadable "polyMap" polyMap , goldenPirReadable "applicationFunction" applicationFunction , goldenPirReadable "unboxedTuples2" unboxedTuples2 , goldenPirReadable "unboxedTuples3" unboxedTuples3 @@ -112,13 +129,13 @@ unfoldings = testNested "unfoldings" [ , goldenPirReadable "unboxedTuples5" unboxedTuples5 , goldenPirReadable "unboxedTuples2Tuples" unboxedTuples2Tuples , goldenPirReadable "unboxedTuples3Tuples" unboxedTuples3Tuples - ] + ] andDirect :: Bool -> Bool -> Bool -andDirect = \(a :: Bool) -> \(b::Bool) -> nandDirect (nandDirect a b) (nandDirect a b) +andDirect = \(a :: Bool) -> \(b :: Bool) -> nandDirect (nandDirect a b) (nandDirect a b) nandDirect :: Bool -> Bool -> Bool -nandDirect = \(a :: Bool) -> \(b::Bool) -> if a then False else if b then False else True +nandDirect = \(a :: Bool) -> \(b :: Bool) -> if a then False else if b then False else True nandPlcDirect :: CompiledCode Bool nandPlcDirect = plc (Proxy @"nandPlcDirect") (nandDirect True False) @@ -132,11 +149,11 @@ andPlcExternal = plc (Proxy @"andPlcExternal") (andExternal True False) -- self-recursion allDirect :: (a -> Bool) -> [a] -> Bool allDirect p l = case l of - [] -> True - h:t -> andDirect (p h) (allDirect p t) + [] -> True + h : t -> andDirect (p h) (allDirect p t) allPlcDirect :: CompiledCode Bool -allPlcDirect = plc (Proxy @"andPlcDirect") (allDirect (\(x::Integer) -> Builtins.lessThanInteger x 5) [7, 6]) +allPlcDirect = plc (Proxy @"andPlcDirect") (allDirect (\(x :: Integer) -> Builtins.lessThanInteger x 5) [7, 6]) mutualRecursionUnfoldings :: CompiledCode Bool mutualRecursionUnfoldings = plc (Proxy @"mutualRecursionUnfoldings") (evenDirect 4) @@ -149,8 +166,8 @@ recordSelectorExternal = plc (Proxy @"recordSelectorExternal") (\(x :: MyExterna mapDirect :: (a -> b) -> [a] -> [b] mapDirect f l = case l of - [] -> [] - x:xs -> f x : mapDirect f xs + [] -> [] + x : xs -> f x : mapDirect f xs polyMap :: CompiledCode ([Integer]) polyMap = plc (Proxy @"polyMap") (mapDirect (Builtins.addInteger 1) [0, 1]) @@ -185,14 +202,33 @@ unboxedTuples4 = plc (Proxy @"unboxedTuples4") (\x -> let a = unboxedTuple4 (# x unboxedTuples5 :: CompiledCode (Integer -> Integer) unboxedTuples5 = plc (Proxy @"unboxedTuples5") (\x -> let a = unboxedTuple5 (# x, x, x, x, x #) in a) -unboxedTuples2Tuple :: (# (# Integer, Integer, Integer, Integer, Integer #), (# Integer, Integer, Integer, Integer, Integer #) #) -> Integer +unboxedTuples2Tuple + :: (# + (# Integer, Integer, Integer, Integer, Integer #) + , (# Integer, Integer, Integer, Integer, Integer #) + #) + -> Integer unboxedTuples2Tuple (# i, j #) = unboxedTuple5 i `Builtins.addInteger` unboxedTuple5 j unboxedTuples2Tuples :: CompiledCode (Integer -> Integer) -unboxedTuples2Tuples = plc (Proxy @"unboxedTuples2Tuples") (\x -> let a = unboxedTuples2Tuple (# (# x, x, x, x, x #), (# x, x, x, x, x #) #) in a) - -unboxedTuples3Tuple :: (# (# Integer, Integer, Integer, Integer, Integer #), (# Integer, Integer, Integer, Integer, Integer #), (# Integer, Integer, Integer, Integer, Integer #) #) -> Integer +unboxedTuples2Tuples = + plc + (Proxy @"unboxedTuples2Tuples") + (\x -> let a = unboxedTuples2Tuple (# (# x, x, x, x, x #), (# x, x, x, x, x #) #) in a) + +unboxedTuples3Tuple + :: (# + (# Integer, Integer, Integer, Integer, Integer #) + , (# Integer, Integer, Integer, Integer, Integer #) + , (# Integer, Integer, Integer, Integer, Integer #) + #) + -> Integer unboxedTuples3Tuple (# i, j, k #) = unboxedTuple5 i `Builtins.addInteger` unboxedTuple5 j `Builtins.addInteger` unboxedTuple5 k unboxedTuples3Tuples :: CompiledCode (Integer -> Integer) -unboxedTuples3Tuples = plc (Proxy @"unboxedTuples3Tuples") (\x -> let a = unboxedTuples3Tuple (# (# x, x, x, x, x #), (# x, x, x, x, x #), (# x, x, x, x, x #) #) in a) +unboxedTuples3Tuples = + plc + (Proxy @"unboxedTuples3Tuples") + ( \x -> + let a = unboxedTuples3Tuple (# (# x, x, x, x, x #), (# x, x, x, x, x #), (# x, x, x, x, x #) #) in a + ) diff --git a/plutus-tx-plugin/test/Plugin/Laziness/Spec.hs b/plutus-tx-plugin/test/Plugin/Laziness/Spec.hs index 769ed653a6e..9d08d67afaa 100644 --- a/plutus-tx-plugin/test/Plugin/Laziness/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Laziness/Spec.hs @@ -3,13 +3,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} module Plugin.Laziness.Spec where @@ -26,11 +25,15 @@ import PlutusTx.Test import Data.Proxy laziness :: TestNested -laziness = testNested "Laziness" . pure $ testNestedGhc - [ goldenPirReadable "joinError" joinErrorPir - , goldenUEval "joinErrorEval" [ toUPlc joinErrorPir, toUPlc $ plc (Proxy @"T") True, toUPlc $ plc (Proxy @"F") False] - , goldenPirReadable "lazyDepUnit" lazyDepUnit - ] +laziness = + testNested "Laziness" . pure $ + testNestedGhc + [ goldenPirReadable "joinError" joinErrorPir + , goldenUEval + "joinErrorEval" + [toUPlc joinErrorPir, toUPlc $ plc (Proxy @"T") True, toUPlc $ plc (Proxy @"F") False] + , goldenPirReadable "lazyDepUnit" lazyDepUnit + ] joinErrorPir :: CompiledCode (Bool -> Bool -> ()) joinErrorPir = plc (Proxy @"joinError") joinError diff --git a/plutus-tx-plugin/test/Plugin/Lib.hs b/plutus-tx-plugin/test/Plugin/Lib.hs index 18de64854c2..1db33e6c959 100644 --- a/plutus-tx-plugin/test/Plugin/Lib.hs +++ b/plutus-tx-plugin/test/Plugin/Lib.hs @@ -6,6 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + module Plugin.Lib where import PlutusTx.Prelude @@ -16,15 +17,15 @@ import PlutusTx.Builtins qualified as Builtins andExternal :: Bool -> Bool -> Bool andExternal a b = if a then b else False -data MyExternalRecord = MyExternalRecord { myExternal :: Integer } +data MyExternalRecord = MyExternalRecord {myExternal :: Integer} evenDirect :: Integer -> Bool evenDirect n = if Builtins.equalsInteger n 0 then True else oddDirect (Builtins.subtractInteger n 1) -{-# INLINABLE evenDirect #-} +{-# INLINEABLE evenDirect #-} oddDirect :: Integer -> Bool oddDirect n = if Builtins.equalsInteger n 0 then False else evenDirect (Builtins.subtractInteger n 1) -{-# INLINABLE oddDirect #-} +{-# INLINEABLE oddDirect #-} -- GHC will lift out the error call to the top level, which is unsafe unless we bind it lazily. -- This is in Lib so we get the fully optimized unfolding with awkward top-level binds and everything. diff --git a/plutus-tx-plugin/test/Plugin/NoTrace/Lib.hs b/plutus-tx-plugin/test/Plugin/NoTrace/Lib.hs index a9243b1fdc6..00540d46721 100644 --- a/plutus-tx-plugin/test/Plugin/NoTrace/Lib.hs +++ b/plutus-tx-plugin/test/Plugin/NoTrace/Lib.hs @@ -40,10 +40,14 @@ evaluatesToError = not . evaluatesWithoutError evaluatesWithoutError :: CompiledCode a -> Bool evaluatesWithoutError code = - runCekDeBruijn defaultCekParametersForTesting counting noEmitter - (getPlc code ^. UPLC.progTerm) & \case - (Left _exception, _counter, _logs) -> False - (Right _result, _counter, _logs) -> True + runCekDeBruijn + defaultCekParametersForTesting + counting + noEmitter + (getPlc code ^. UPLC.progTerm) + & \case + (Left _exception, _counter, _logs) -> False + (Right _result, _counter, _logs) -> True ---------------------------------------------------------------------------------------------------- -- Functions that contain traces ------------------------------------------------------------------- diff --git a/plutus-tx-plugin/test/Plugin/NoTrace/Spec.hs b/plutus-tx-plugin/test/Plugin/NoTrace/Spec.hs index a062b1a5980..911736f647a 100644 --- a/plutus-tx-plugin/test/Plugin/NoTrace/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/NoTrace/Spec.hs @@ -19,8 +19,10 @@ import Test.Tasty.HUnit (assertBool, testCase, (@=?)) noTrace :: TestNested noTrace = embed do - testGroup "remove-trace" - [ testGroup "Trace calls are preserved (no-remove-trace)" + testGroup + "remove-trace" + [ testGroup + "Trace calls are preserved (no-remove-trace)" [ testCase "trace-argument" $ 1 @=? countTraces WithTraces.traceArgument , testCase "trace-show" $ @@ -38,7 +40,8 @@ noTrace = embed do , testCase "trace-impure with effect" $ -- See Note [Impure trace messages] assertBool "Effect is missing" (Lib.evaluatesToError WithTraces.traceImpure) ] - , testGroup "Trace calls are preserved (preserve-logging)" + , testGroup + "Trace calls are preserved (preserve-logging)" [ testCase "trace-argument" $ 1 @=? countTraces WithPreservedLogging.traceArgument , testCase "trace-show" $ diff --git a/plutus-tx-plugin/test/Plugin/Optimization/Spec.hs b/plutus-tx-plugin/test/Plugin/Optimization/Spec.hs index 0e936ca77e6..37b13ef7949 100644 --- a/plutus-tx-plugin/test/Plugin/Optimization/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Optimization/Spec.hs @@ -2,8 +2,8 @@ {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} module Plugin.Optimization.Spec where @@ -18,10 +18,12 @@ import PlutusTx.Test () import Data.Proxy optimization :: TestNested -optimization = testNested "Optimization" Prelude.. Prelude.pure Prelude.$ testNestedGhc - [ goldenUPlc "alwaysSucceeds" alwaysSucceeds - , goldenUPlc "alwaysFails" alwaysFails - ] +optimization = + testNested "Optimization" Prelude.. Prelude.pure Prelude.$ + testNestedGhc + [ goldenUPlc "alwaysSucceeds" alwaysSucceeds + , goldenUPlc "alwaysFails" alwaysFails + ] alwaysSucceeds :: CompiledCode (BuiltinData -> BuiltinData -> BuiltinData -> ()) alwaysSucceeds = plc (Proxy @"alwaysSucceeds") (\_ _ _ -> ()) diff --git a/plutus-tx-plugin/test/Plugin/Patterns/Spec.hs b/plutus-tx-plugin/test/Plugin/Patterns/Spec.hs index 3966434c74b..c77d3946322 100644 --- a/plutus-tx-plugin/test/Plugin/Patterns/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Patterns/Spec.hs @@ -4,16 +4,15 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} - -{-# OPTIONS_GHC -Wno-missing-signatures #-} -{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} module Plugin.Patterns.Spec where @@ -34,28 +33,35 @@ pattern EInt' i = EInt i pattern ETwoBoth a b = ETwo a b pattern ETwo2 b <- ETwo _ b -pattern ERec {hello, world} <- ETwo hello world - where ERec hello world = ETwo hello world +pattern ERec{hello, world} <- ETwo hello world + where + ERec hello world = ETwo hello world psym1 :: CompiledCode (Example BuiltinString -> Integer) -psym1 = plc (Proxy @"psym1") ( - \(e :: Example BuiltinString) -> - case e of - EInt' i -> i - ETwo2 _ -> 1 - _ -> 0 - ) +psym1 = + plc + (Proxy @"psym1") + ( \(e :: Example BuiltinString) -> + case e of + EInt' i -> i + ETwo2 _ -> 1 + _ -> 0 + ) psymRec :: CompiledCode BuiltinString -psymRec = plc (Proxy @"psymRec") ( - let r = ERec { hello = "wot", world = "yo" } - in case r of - ERec{world} -> world - _ -> "no" - ) +psymRec = + plc + (Proxy @"psymRec") + ( let r = ERec{hello = "wot", world = "yo"} + in case r of + ERec{world} -> world + _ -> "no" + ) patterns :: TestNested -patterns = testNested "Patterns" Prelude.. Prelude.pure Prelude.$ testNestedGhc - [ goldenPirReadable "psym1" psym1 - , goldenPirReadable "psymRec" psymRec - ] +patterns = + testNested "Patterns" Prelude.. Prelude.pure Prelude.$ + testNestedGhc + [ goldenPirReadable "psym1" psym1 + , goldenPirReadable "psymRec" psymRec + ] diff --git a/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs b/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs index 841e341675b..e6b38a63a4d 100644 --- a/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Primitives/Spec.hs @@ -4,11 +4,11 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=3 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} module Plugin.Primitives.Spec where @@ -25,66 +25,105 @@ import PlutusTx.Test import Data.Proxy primitives :: TestNested -primitives = testNested "Primitives" . pure $ testNestedGhc - [ goldenPirReadable "string" string - , goldenPirReadable "int" int - , goldenPirReadable "int2" int2 - , goldenPirReadable "bool" bool - , goldenPirReadable "and" andPlc - , goldenUEval "andApply" [ toUPlc andPlc, toUPlc $ plc (Proxy @"T") True, toUPlc $ plc (Proxy @"F") False ] - , goldenPirReadable "tuple" tuple - , goldenPirReadable "tupleMatch" tupleMatch - , goldenUEval "tupleConstDest" [ toUPlc tupleMatch, toUPlc tuple ] - , goldenPirReadable "intCompare" intCompare - , goldenPirReadable "intEq" intEq - , goldenUEval "intEqApply" [ toUPlc intEq, toUPlc int, toUPlc int ] - , goldenPirReadable "void" void - , goldenPirReadable "intPlus" intPlus - , goldenPirReadable "intDiv" intDiv - , goldenUEval "intPlusApply" [ toUPlc intPlus, toUPlc int, toUPlc int2 ] - , goldenPirReadable "error" errorPlc - , goldenPirReadable "ifThenElse" ifThenElse - , goldenUEval "ifThenElseApply" [ toUPlc ifThenElse, toUPlc int, toUPlc int2 ] - , goldenPirReadable "emptyByteString" emptyByteString - , goldenUEval "emptyByteStringApply" [ getPlcNoAnn emptyByteString, snd (liftProgramDef Builtins.emptyByteString) ] - , goldenPirReadable "bytestring" bytestring - , goldenUEval "bytestringApply" [ getPlcNoAnn bytestring, snd (liftProgramDef ("hello" ::Builtins.BuiltinByteString)) ] - , goldenUEval "sha2_256" [ getPlcNoAnn sha2, snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString))] - , goldenUEval "equalsByteString" [ getPlcNoAnn bsEquals, snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString)), snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString))] - , goldenUEval "ltByteString" [ getPlcNoAnn bsLt, snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString)), snd (liftProgramDef ("world" :: Builtins.BuiltinByteString))] - , goldenUEval "decodeUtf8" [ getPlcNoAnn bsDecode, snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString))] - , goldenUEval "lengthOfByteString" [ getPlcNoAnn bsLength, snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString))] - , goldenUEval "indexByteString" [ getPlcNoAnn bsIndex, snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString)), snd (liftProgramDef (0 :: Integer))] - , goldenUEval "consByteString" [ getPlcNoAnn bsCons, snd (liftProgramDef (104 :: Integer)), snd (liftProgramDef ("ello" :: Builtins.BuiltinByteString))] - , goldenPirReadable "verify" verify - , goldenPirReadable "trace" trace - , goldenPirReadable "traceComplex" traceComplex - , goldenPirReadable "stringLiteral" stringLiteral - , goldenUEval "equalsString" [ getPlcNoAnn stringEquals, snd (liftProgramDef ("hello" :: Builtins.BuiltinString)), snd (liftProgramDef ("hello" :: Builtins.BuiltinString))] - , goldenPirReadable "encodeUtf8" stringEncode - , goldenPirReadable "serialiseData" dataEncode - , goldenUEval "serialiseDataApply" [ toUPlc dataEncode, toUPlc constructData1 ] - , goldenUEval "constructData1" [ constructData1 ] - -- It's interesting to look at one of these to make sure all the specialisation is working out nicely and for - -- debugging when it isn't - , goldenPirReadable "deconstructorData1" deconstructData1 - -- Check that matchData works (and isn't too strict) - , goldenUEval "matchData1" [ toUPlc matchData1, toUPlc constructData1 ] - , goldenUEval "deconstructData1" [ toUPlc deconstructData1, toUPlc constructData1 ] - , goldenPirReadable "deconstructorData2" deconstructData2 - , goldenUEval "deconstructData2" [ toUPlc deconstructData2, toUPlc constructData2 ] - , goldenUEval "deconstructData3" [ toUPlc deconstructData3, toUPlc constructData3 ] - , goldenUEval "writeBits-integerToByteString" [ writeBitsIntegerToByteString ] - ] +primitives = + testNested "Primitives" . pure $ + testNestedGhc + [ goldenPirReadable "string" string + , goldenPirReadable "int" int + , goldenPirReadable "int2" int2 + , goldenPirReadable "bool" bool + , goldenPirReadable "and" andPlc + , goldenUEval + "andApply" + [toUPlc andPlc, toUPlc $ plc (Proxy @"T") True, toUPlc $ plc (Proxy @"F") False] + , goldenPirReadable "tuple" tuple + , goldenPirReadable "tupleMatch" tupleMatch + , goldenUEval "tupleConstDest" [toUPlc tupleMatch, toUPlc tuple] + , goldenPirReadable "intCompare" intCompare + , goldenPirReadable "intEq" intEq + , goldenUEval "intEqApply" [toUPlc intEq, toUPlc int, toUPlc int] + , goldenPirReadable "void" void + , goldenPirReadable "intPlus" intPlus + , goldenPirReadable "intDiv" intDiv + , goldenUEval "intPlusApply" [toUPlc intPlus, toUPlc int, toUPlc int2] + , goldenPirReadable "error" errorPlc + , goldenPirReadable "ifThenElse" ifThenElse + , goldenUEval "ifThenElseApply" [toUPlc ifThenElse, toUPlc int, toUPlc int2] + , goldenPirReadable "emptyByteString" emptyByteString + , goldenUEval + "emptyByteStringApply" + [getPlcNoAnn emptyByteString, snd (liftProgramDef Builtins.emptyByteString)] + , goldenPirReadable "bytestring" bytestring + , goldenUEval + "bytestringApply" + [getPlcNoAnn bytestring, snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString))] + , goldenUEval + "sha2_256" + [getPlcNoAnn sha2, snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString))] + , goldenUEval + "equalsByteString" + [ getPlcNoAnn bsEquals + , snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString)) + , snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString)) + ] + , goldenUEval + "ltByteString" + [ getPlcNoAnn bsLt + , snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString)) + , snd (liftProgramDef ("world" :: Builtins.BuiltinByteString)) + ] + , goldenUEval + "decodeUtf8" + [getPlcNoAnn bsDecode, snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString))] + , goldenUEval + "lengthOfByteString" + [getPlcNoAnn bsLength, snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString))] + , goldenUEval + "indexByteString" + [ getPlcNoAnn bsIndex + , snd (liftProgramDef ("hello" :: Builtins.BuiltinByteString)) + , snd (liftProgramDef (0 :: Integer)) + ] + , goldenUEval + "consByteString" + [ getPlcNoAnn bsCons + , snd (liftProgramDef (104 :: Integer)) + , snd (liftProgramDef ("ello" :: Builtins.BuiltinByteString)) + ] + , goldenPirReadable "verify" verify + , goldenPirReadable "trace" trace + , goldenPirReadable "traceComplex" traceComplex + , goldenPirReadable "stringLiteral" stringLiteral + , goldenUEval + "equalsString" + [ getPlcNoAnn stringEquals + , snd (liftProgramDef ("hello" :: Builtins.BuiltinString)) + , snd (liftProgramDef ("hello" :: Builtins.BuiltinString)) + ] + , goldenPirReadable "encodeUtf8" stringEncode + , goldenPirReadable "serialiseData" dataEncode + , goldenUEval "serialiseDataApply" [toUPlc dataEncode, toUPlc constructData1] + , goldenUEval "constructData1" [constructData1] + , -- It's interesting to look at one of these to make sure all the specialisation is working out nicely and for + -- debugging when it isn't + goldenPirReadable "deconstructorData1" deconstructData1 + , -- Check that matchData works (and isn't too strict) + goldenUEval "matchData1" [toUPlc matchData1, toUPlc constructData1] + , goldenUEval "deconstructData1" [toUPlc deconstructData1, toUPlc constructData1] + , goldenPirReadable "deconstructorData2" deconstructData2 + , goldenUEval "deconstructData2" [toUPlc deconstructData2, toUPlc constructData2] + , goldenUEval "deconstructData3" [toUPlc deconstructData3, toUPlc constructData3] + , goldenUEval "writeBits-integerToByteString" [writeBitsIntegerToByteString] + ] string :: CompiledCode Builtins.BuiltinString string = plc (Proxy @"text") "text" int :: CompiledCode Integer -int = plc (Proxy @"int") (1::Integer) +int = plc (Proxy @"int") (1 :: Integer) int2 :: CompiledCode Integer -int2 = plc (Proxy @"int2") (2::Integer) +int2 = plc (Proxy @"int2") (2 :: Integer) emptyBS :: CompiledCode Builtins.BuiltinByteString emptyBS = plc (Proxy @"emptyBS") Builtins.emptyByteString @@ -93,65 +132,95 @@ bool :: CompiledCode Bool bool = plc (Proxy @"bool") True andPlc :: CompiledCode (Bool -> Bool -> Bool) -andPlc = plc (Proxy @"andPlc") (\(x::Bool) (y::Bool) -> if x then (if y then True else False) else False) +andPlc = + plc (Proxy @"andPlc") (\(x :: Bool) (y :: Bool) -> if x then (if y then True else False) else False) tuple :: CompiledCode (Integer, Integer) -tuple = plc (Proxy @"tuple") (1::Integer, 2::Integer) +tuple = plc (Proxy @"tuple") (1 :: Integer, 2 :: Integer) tupleMatch :: CompiledCode ((Integer, Integer) -> Integer) -tupleMatch = plc (Proxy @"tupleMatch") (\(x:: (Integer, Integer)) -> let (a, _) = x in a) +tupleMatch = plc (Proxy @"tupleMatch") (\(x :: (Integer, Integer)) -> let (a, _) = x in a) intCompare :: CompiledCode (Integer -> Integer -> Bool) -intCompare = plc (Proxy @"intCompare") (\(x::Integer) (y::Integer) -> Builtins.lessThanInteger x y) +intCompare = plc (Proxy @"intCompare") (\(x :: Integer) (y :: Integer) -> Builtins.lessThanInteger x y) intEq :: CompiledCode (Integer -> Integer -> Bool) -intEq = plc (Proxy @"intEq") (\(x::Integer) (y::Integer) -> Builtins.equalsInteger x y) +intEq = plc (Proxy @"intEq") (\(x :: Integer) (y :: Integer) -> Builtins.equalsInteger x y) -- Has a Void in it void :: CompiledCode (Integer -> Integer -> Bool) -void = plc (Proxy @"void") (\(x::Integer) (y::Integer) -> let a x' y' = case (x', y') of { (True, True) -> True; _ -> False; } in Builtins.equalsInteger x y `a` Builtins.equalsInteger y x) +void = + plc + (Proxy @"void") + ( \(x :: Integer) (y :: Integer) -> + let a x' y' = case (x', y') of (True, True) -> True; _ -> False + in Builtins.equalsInteger x y `a` Builtins.equalsInteger y x + ) intPlus :: CompiledCode (Integer -> Integer -> Integer) -intPlus = plc (Proxy @"intPlus") (\(x::Integer) (y::Integer) -> Builtins.addInteger x y) +intPlus = plc (Proxy @"intPlus") (\(x :: Integer) (y :: Integer) -> Builtins.addInteger x y) intDiv :: CompiledCode (Integer -> Integer -> Integer) -intDiv = plc (Proxy @"intDiv") (\(x::Integer) (y::Integer) -> Builtins.divideInteger x y) +intDiv = plc (Proxy @"intDiv") (\(x :: Integer) (y :: Integer) -> Builtins.divideInteger x y) errorPlc :: CompiledCode (() -> Integer) errorPlc = plc (Proxy @"errorPlc") (Builtins.error @Integer) ifThenElse :: CompiledCode (Integer -> Integer -> Integer) -ifThenElse = plc (Proxy @"ifThenElse") (\(x::Integer) (y::Integer) -> if Builtins.equalsInteger x y then x else y) +ifThenElse = + plc + (Proxy @"ifThenElse") + (\(x :: Integer) (y :: Integer) -> if Builtins.equalsInteger x y then x else y) emptyByteString :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString) emptyByteString = plc (Proxy @"emptyByteString") (\(x :: Builtins.BuiltinByteString) -> x) bytestring :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString) -bytestring = plc (Proxy @"bytestring") (\(x::Builtins.BuiltinByteString) -> x) +bytestring = plc (Proxy @"bytestring") (\(x :: Builtins.BuiltinByteString) -> x) sha2 :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString) sha2 = plc (Proxy @"sha2") (\(x :: Builtins.BuiltinByteString) -> Builtins.sha2_256 x) bsEquals :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Bool) -bsEquals = plc (Proxy @"bs32Equals") (\(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) -> Builtins.equalsByteString x y) +bsEquals = + plc + (Proxy @"bs32Equals") + ( \(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) -> Builtins.equalsByteString x y + ) bsLength :: CompiledCode (Builtins.BuiltinByteString -> Integer) bsLength = plc (Proxy @"bs32Length") (\(x :: Builtins.BuiltinByteString) -> Builtins.lengthOfByteString x) bsIndex :: CompiledCode (Builtins.BuiltinByteString -> Integer -> Integer) -bsIndex = plc (Proxy @"bs32Index") (\(x :: Builtins.BuiltinByteString) (n :: Integer) -> Builtins.indexByteString x n) +bsIndex = + plc + (Proxy @"bs32Index") + (\(x :: Builtins.BuiltinByteString) (n :: Integer) -> Builtins.indexByteString x n) bsCons :: CompiledCode (Integer -> Builtins.BuiltinByteString -> Builtins.BuiltinByteString) -bsCons = plc (Proxy @"bs32Cons") (\(n :: Integer) (x :: Builtins.BuiltinByteString) -> Builtins.consByteString n x) +bsCons = + plc + (Proxy @"bs32Cons") + (\(n :: Integer) (x :: Builtins.BuiltinByteString) -> Builtins.consByteString n x) bsLt :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Bool) -bsLt = plc (Proxy @"bsLt") (\(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) -> Builtins.lessThanByteString x y) +bsLt = + plc + (Proxy @"bsLt") + ( \(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) -> Builtins.lessThanByteString x y + ) bsDecode :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinString) bsDecode = plc (Proxy @"bsDecode") (\(x :: Builtins.BuiltinByteString) -> Builtins.decodeUtf8 x) -verify :: CompiledCode (Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Bool) -verify = plc (Proxy @"verify") (\(x::Builtins.BuiltinByteString) (y::Builtins.BuiltinByteString) (z::Builtins.BuiltinByteString) -> Builtins.verifyEd25519Signature x y z) +verify + :: CompiledCode + (Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Builtins.BuiltinByteString -> Bool) +verify = + plc + (Proxy @"verify") + ( \(x :: Builtins.BuiltinByteString) (y :: Builtins.BuiltinByteString) (z :: Builtins.BuiltinByteString) -> Builtins.verifyEd25519Signature x y z + ) trace :: CompiledCode (Builtins.BuiltinString -> ()) trace = plc (Proxy @"trace") (\(x :: Builtins.BuiltinString) -> Builtins.trace x ()) @@ -160,10 +229,13 @@ traceComplex :: CompiledCode (Bool -> ()) traceComplex = plc (Proxy @"traceComplex") (\(b :: Bool) -> if b then P.trace "yes" () else P.traceError "no") stringLiteral :: CompiledCode (Builtins.BuiltinString) -stringLiteral = plc (Proxy @"stringLiteral") ("abc"::Builtins.BuiltinString) +stringLiteral = plc (Proxy @"stringLiteral") ("abc" :: Builtins.BuiltinString) stringEquals :: CompiledCode (Builtins.BuiltinString -> Builtins.BuiltinString -> Bool) -stringEquals = plc (Proxy @"string32Equals") (\(x :: Builtins.BuiltinString) (y :: Builtins.BuiltinString) -> Builtins.equalsString x y) +stringEquals = + plc + (Proxy @"string32Equals") + (\(x :: Builtins.BuiltinString) (y :: Builtins.BuiltinString) -> Builtins.equalsString x y) stringEncode :: CompiledCode (Builtins.BuiltinByteString) stringEncode = plc (Proxy @"stringEncode") (Builtins.encodeUtf8 "abc") @@ -181,7 +253,11 @@ constructData2 :: CompiledCode (Builtins.BuiltinData) constructData2 = plc (Proxy @"constructData2") (Builtins.mkConstr 1 [Builtins.mkI 2, Builtins.mkI 3]) deconstructData2 :: CompiledCode (Builtins.BuiltinData -> (Integer, [Integer])) -deconstructData2 = plc (Proxy @"deconstructData2") (\(d :: Builtins.BuiltinData) -> (P.fmap . P.fmap) Builtins.unsafeDataAsI (Builtins.unsafeDataAsConstr d)) +deconstructData2 = + plc + (Proxy @"deconstructData2") + ( \(d :: Builtins.BuiltinData) -> (P.fmap . P.fmap) Builtins.unsafeDataAsI (Builtins.unsafeDataAsConstr d) + ) constructData3 :: CompiledCode (Builtins.BuiltinData) constructData3 = plc (Proxy @"constructData2") (Builtins.mkList [Builtins.mkI 2, Builtins.mkI 3]) @@ -190,8 +266,14 @@ deconstructData3 :: CompiledCode (Builtins.BuiltinData -> [Builtins.BuiltinData] deconstructData3 = plc (Proxy @"deconstructData2") (\(d :: Builtins.BuiltinData) -> (Builtins.unsafeDataAsList d)) matchData1 :: CompiledCode (Builtins.BuiltinData -> Maybe Integer) -matchData1 = plc (Proxy @"matchData1") (\(d :: Builtins.BuiltinData) -> (Builtins.matchData d (\_ _ -> Nothing) (const Nothing) (const Nothing) (Just) (const Nothing))) +matchData1 = + plc + (Proxy @"matchData1") + ( \(d :: Builtins.BuiltinData) -> (Builtins.matchData d (\_ _ -> Nothing) (const Nothing) (const Nothing) (Just) (const Nothing)) + ) writeBitsIntegerToByteString :: CompiledCode (P.BuiltinByteString) -writeBitsIntegerToByteString = plc (Proxy @"writeBitsIntegerToByteString") +writeBitsIntegerToByteString = + plc + (Proxy @"writeBitsIntegerToByteString") (P.writeBits (P.writeBits (P.integerToByteString Builtins.BigEndian 6 15) [0, 5] True) [2] False) diff --git a/plutus-tx-plugin/test/Plugin/Spec.hs b/plutus-tx-plugin/test/Plugin/Spec.hs index c74fb896681..fd8b05d2fdd 100644 --- a/plutus-tx-plugin/test/Plugin/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Spec.hs @@ -18,19 +18,21 @@ import Plugin.Strict.Spec import Plugin.Typeclasses.Spec tests :: TestNested -tests = testNested "Plugin" [ - basic - , primitives - , datat - , debug - , functions - , laziness - , noTrace - , optimization - , errors - , typeclasses - , strict - , profiling - , coverage - , patterns - ] +tests = + testNested + "Plugin" + [ basic + , primitives + , datat + , debug + , functions + , laziness + , noTrace + , optimization + , errors + , typeclasses + , strict + , profiling + , coverage + , patterns + ] diff --git a/plutus-tx-plugin/test/Plugin/Strict/Spec.hs b/plutus-tx-plugin/test/Plugin/Strict/Spec.hs index 93dd3b60248..01364a49688 100644 --- a/plutus-tx-plugin/test/Plugin/Strict/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Strict/Spec.hs @@ -4,10 +4,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} -- To ensure the traces don't get optimized away in the tests {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:conservative-optimisation #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} module Plugin.Strict.Spec (strict) where @@ -23,23 +23,25 @@ import PlutusTx.Test import Data.Proxy strict :: TestNested -strict = testNested "Strict" . pure $ testNestedGhc - [ goldenPirReadable "strictAdd" strictAdd - , goldenPirReadable "strictAppend" strictAppend - , goldenPirReadable "strictAppend2" strictAppend2 - , goldenPirReadable "strictAppendString" strictAppendString - , goldenPirReadable "strictITE" strictITE - , goldenPirReadable "strictPair" strictPair - , goldenPirReadable "strictList" strictList - , goldenPirReadable "strictData" strictData - , goldenPirReadable "issue4645" issue4645 - -- TODO: the Cek log of this test case is currently unexpected and doesn't match - -- what the user would expect. Originally, both GHC and ourselves are culprits - -- in this instance (see - -- https://github.com/IntersectMBO/plutus/pull/5371#discussion_r1285087508), - -- however we have now fixed the bug on our side so it's just GHC being annoying. - , goldenEvalCekLog "issue4645" issue4645 - ] +strict = + testNested "Strict" . pure $ + testNestedGhc + [ goldenPirReadable "strictAdd" strictAdd + , goldenPirReadable "strictAppend" strictAppend + , goldenPirReadable "strictAppend2" strictAppend2 + , goldenPirReadable "strictAppendString" strictAppendString + , goldenPirReadable "strictITE" strictITE + , goldenPirReadable "strictPair" strictPair + , goldenPirReadable "strictList" strictList + , goldenPirReadable "strictData" strictData + , goldenPirReadable "issue4645" issue4645 + , -- TODO: the Cek log of this test case is currently unexpected and doesn't match + -- what the user would expect. Originally, both GHC and ourselves are culprits + -- in this instance (see + -- https://github.com/IntersectMBO/plutus/pull/5371#discussion_r1285087508), + -- however we have now fixed the bug on our side so it's just GHC being annoying. + goldenEvalCekLog "issue4645" issue4645 + ] strictAdd :: CompiledCode (Integer -> Integer -> Integer) strictAdd = plc (Proxy @"strictLet") strictAddExample @@ -98,12 +100,13 @@ issue4645 = plc (Proxy @"issue4645") issue4645Example -- Reproducer for plutus#4645 issue4645Example :: Bool issue4645Example = - let - !x = P.trace "x" 0 :: Integer - !y = P.trace "y" (1, 2) :: (Integer,Integer) - !z = P.trace "z" y - (!zz, _) = P.trace "zz" z - !t = P.trace "t" zz - - !valid = x P.== t - in valid + let + !x = P.trace "x" 0 :: Integer + !y = P.trace "y" (1, 2) :: (Integer, Integer) + !z = P.trace "z" y + (!zz, _) = P.trace "zz" z + !t = P.trace "t" zz + + !valid = x P.== t + in + valid diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/Lib.hs b/plutus-tx-plugin/test/Plugin/Typeclasses/Lib.hs index 798e90ffadd..35aa6e89cdd 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/Lib.hs +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/Lib.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + module Plugin.Typeclasses.Lib where import PlutusTx.Builtins qualified as Builtins @@ -9,15 +10,15 @@ data Alien = AlienJim | AlienJane -- Needs to be in another file because of #978 class DefaultMethods a where - method1 :: a -> Integer - {-# INLINABLE method2 #-} - method2 :: a -> Integer - method2 a = method1 a `Builtins.addInteger` 1 + method1 :: a -> Integer + {-# INLINEABLE method2 #-} + method2 :: a -> Integer + method2 a = method1 a `Builtins.addInteger` 1 instance DefaultMethods Integer where - {-# INLINABLE method1 #-} - method1 a = a + {-# INLINEABLE method1 #-} + method1 a = a instance DefaultMethods Person where - {-# INLINABLE method1 #-} - method1 _ = 1 + {-# INLINEABLE method1 #-} + method1 _ = 1 diff --git a/plutus-tx-plugin/test/Plugin/Typeclasses/Spec.hs b/plutus-tx-plugin/test/Plugin/Typeclasses/Spec.hs index 78c3915f999..24b3e541b91 100644 --- a/plutus-tx-plugin/test/Plugin/Typeclasses/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Typeclasses/Spec.hs @@ -2,14 +2,13 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-typecheck #-} module Plugin.Typeclasses.Spec where @@ -27,75 +26,84 @@ import PlutusTx.Prelude qualified as P import PlutusTx.Test import PlutusTx.Traversable qualified as T - import Data.Proxy typeclasses :: TestNested -typeclasses = testNested "Typeclasses" . pure $ testNestedGhc - [ goldenPirReadable "sizedBasic" sizedBasic - , goldenPirReadable "sizedPair" sizedPair - , goldenPirReadable "multiFunction" multiFunction - , goldenPirReadable "defaultMethods" defaultMethods - , goldenPirReadable "partialApplication" partialApplication - , goldenPirReadable "sequenceTest" sequenceTest - , goldenPirReadable "compareTest" compareTest - , goldenPirReadable "concatTest" concatTest - , goldenPirReadable "sumTest" sumTest - , goldenPirReadable "fmapDefaultTest" fmapDefaultTest - ] +typeclasses = + testNested "Typeclasses" . pure $ + testNestedGhc + [ goldenPirReadable "sizedBasic" sizedBasic + , goldenPirReadable "sizedPair" sizedPair + , goldenPirReadable "multiFunction" multiFunction + , goldenPirReadable "defaultMethods" defaultMethods + , goldenPirReadable "partialApplication" partialApplication + , goldenPirReadable "sequenceTest" sequenceTest + , goldenPirReadable "compareTest" compareTest + , goldenPirReadable "concatTest" concatTest + , goldenPirReadable "sumTest" sumTest + , goldenPirReadable "fmapDefaultTest" fmapDefaultTest + ] class Sized a where - size :: a -> Integer + size :: a -> Integer instance Sized Integer where - size x = x + size x = x instance (Sized a, Sized b) => Sized (a, b) where - {-# INLINABLE size #-} - size (a, b) = size a `Builtins.addInteger` size b + {-# INLINEABLE size #-} + size (a, b) = size a `Builtins.addInteger` size b sizedBasic :: CompiledCode (Integer -> Integer) -sizedBasic = plc (Proxy @"sizedBasic") (\(a::Integer) -> size a) +sizedBasic = plc (Proxy @"sizedBasic") (\(a :: Integer) -> size a) sizedPair :: CompiledCode (Integer -> Integer -> Integer) -sizedPair = plc (Proxy @"sizedPair") (\(a::Integer) (b::Integer) -> size (a, b)) +sizedPair = plc (Proxy @"sizedPair") (\(a :: Integer) (b :: Integer) -> size (a, b)) -- This has multiple methods, so will have to be passed as a dictionary class PersonLike a where - age :: a -> Integer - likesAnimal :: a -> Animal -> Bool + age :: a -> Integer + likesAnimal :: a -> Animal -> Bool instance PersonLike Person where - {-# INLINABLE age #-} - age Jim = 30 - age Jane = 35 - {-# INLINABLE likesAnimal #-} - likesAnimal Jane Cat = True - likesAnimal _ _ = False + {-# INLINEABLE age #-} + age Jim = 30 + age Jane = 35 + {-# INLINEABLE likesAnimal #-} + likesAnimal Jane Cat = True + likesAnimal _ _ = False instance PersonLike Alien where - {-# INLINABLE age #-} - age AlienJim = 300 - age AlienJane = 350 - {-# INLINABLE likesAnimal #-} - likesAnimal AlienJane Dog = True - likesAnimal _ _ = False + {-# INLINEABLE age #-} + age AlienJim = 300 + age AlienJane = 350 + {-# INLINEABLE likesAnimal #-} + likesAnimal AlienJane Dog = True + likesAnimal _ _ = False multiFunction :: CompiledCode (Person -> Bool) -multiFunction = plc (Proxy @"multiFunction") ( - let +multiFunction = + plc + (Proxy @"multiFunction") + ( let {-# OPAQUE predicate #-} predicate :: (PersonLike p) => p -> Bool predicate p = likesAnimal p Cat P.&& (age p `Builtins.lessThanInteger` 30) - in \(p::Person) -> predicate p) + in + \(p :: Person) -> predicate p + ) defaultMethods :: CompiledCode (Integer -> Integer) -defaultMethods = plc (Proxy @"defaultMethods") ( - let +defaultMethods = + plc + (Proxy @"defaultMethods") + ( let {-# OPAQUE f #-} f :: (DefaultMethods a) => a -> Integer f a = method2 a - in \(a::Integer) -> f a) + in + \(a :: Integer) -> f a + ) partialApplication :: CompiledCode (Integer -> Integer -> Ordering) partialApplication = plc (Proxy @"partialApplication") (P.compare @Integer) @@ -103,14 +111,14 @@ partialApplication = plc (Proxy @"partialApplication") (P.compare @Integer) sequenceTest :: CompiledCode (Maybe [Integer]) sequenceTest = plc (Proxy @"sequenceTests") (T.sequence [Just (1 :: Integer), Just (2 :: Integer)]) -opCompare :: P.Ord a => a -> a -> Ordering +opCompare :: (P.Ord a) => a -> a -> Ordering opCompare a b = case P.compare a b of - LT -> GT - EQ -> EQ - GT -> LT + LT -> GT + EQ -> EQ + GT -> LT compareTest :: CompiledCode Ordering -compareTest = plc (Proxy @"compareTest") (opCompare (1::Integer) (2::Integer)) +compareTest = plc (Proxy @"compareTest") (opCompare (1 :: Integer) (2 :: Integer)) concatTest :: CompiledCode [Integer] concatTest = plc (Proxy @"concatTest") (List.concat [[(1 :: Integer), 2], [3, 4]]) diff --git a/plutus-tx-plugin/test/ShortCircuit/WithGHCOptimisations.hs b/plutus-tx-plugin/test/ShortCircuit/WithGHCOptimisations.hs index ceecb9f74b7..3b5ebe33686 100644 --- a/plutus-tx-plugin/test/ShortCircuit/WithGHCOptimisations.hs +++ b/plutus-tx-plugin/test/ShortCircuit/WithGHCOptimisations.hs @@ -1,10 +1,10 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -O1 #-} -module ShortCircuit.WithGHCOptimisations - ( shortCircuitAnd - , shortCircuitOr - ) where +module ShortCircuit.WithGHCOptimisations ( + shortCircuitAnd, + shortCircuitOr, +) where import PlutusTx.Prelude (error, (&&), (||)) import Prelude (Bool) diff --git a/plutus-tx-plugin/test/ShortCircuit/WithoutGHCOptimisations.hs b/plutus-tx-plugin/test/ShortCircuit/WithoutGHCOptimisations.hs index ac6108e6f4a..a894f9c8793 100644 --- a/plutus-tx-plugin/test/ShortCircuit/WithoutGHCOptimisations.hs +++ b/plutus-tx-plugin/test/ShortCircuit/WithoutGHCOptimisations.hs @@ -4,10 +4,10 @@ {-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} {-# OPTIONS_GHC -fno-omit-interface-pragmas #-} -module ShortCircuit.WithoutGHCOptimisations - ( shortCircuitAnd - , shortCircuitOr - ) where +module ShortCircuit.WithoutGHCOptimisations ( + shortCircuitAnd, + shortCircuitOr, +) where import PlutusTx.Prelude (error, (&&), (||)) import Prelude (Bool) diff --git a/plutus-tx-plugin/test/StdLib/Spec.hs b/plutus-tx-plugin/test/StdLib/Spec.hs index 86d655681c4..735cae00100 100644 --- a/plutus-tx-plugin/test/StdLib/Spec.hs +++ b/plutus-tx-plugin/test/StdLib/Spec.hs @@ -4,11 +4,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=0 #-} module StdLib.Spec where @@ -45,22 +45,25 @@ roundPlc = plc (Proxy @"roundPlc") Ratio.round tests :: TestNested tests = - testNested "StdLib" . pure $ testNestedGhc - [ embed testRatioInterop - , testRatioProperty "round" Ratio.round round - , testRatioProperty "truncate" Ratio.truncate truncate - , testRatioProperty "abs" (fmap Ratio.toGHC Ratio.abs) abs - , embed $ testPropertyNamed "ord" "testOrd" testOrd - , embed $ testPropertyNamed "divMod" "testDivMod" testDivMod - , embed $ testPropertyNamed "quotRem" "testQuotRem" testQuotRem - , embed $ testPropertyNamed "Eq @Data" "eqData" eqData - , goldenPirReadable "errorTrace" errorTrace - ] + testNested "StdLib" . pure $ + testNestedGhc + [ embed testRatioInterop + , testRatioProperty "round" Ratio.round round + , testRatioProperty "truncate" Ratio.truncate truncate + , testRatioProperty "abs" (fmap Ratio.toGHC Ratio.abs) abs + , embed $ testPropertyNamed "ord" "testOrd" testOrd + , embed $ testPropertyNamed "divMod" "testDivMod" testDivMod + , embed $ testPropertyNamed "quotRem" "testQuotRem" testQuotRem + , embed $ testPropertyNamed "Eq @Data" "eqData" eqData + , goldenPirReadable "errorTrace" errorTrace + ] -- We really should use something like "Control.Exception.Enclosed" here and in other similar -- places. --- | Evaluate (deeply, to get through tuples) a value, throwing away any exception and just --- representing it as 'Nothing'. + +{-| Evaluate (deeply, to get through tuples) a value, throwing away any exception and just +representing it as 'Nothing'. +-} tryHard :: (MonadIO m, NFData a) => a -> m (Maybe a) -- We have @Strict@ enabled, hence without the tilda this function evaluates @a@ before evaluating -- the body, i.e. outside of the call to 'try', defeating the whole purpose. @@ -73,8 +76,8 @@ testRatioInterop = testCase "ratioInterop" do Left e -> assertFailure (show e) Right r -> r @?= Core.mkConstant () (4 :: Integer) -testRatioProperty :: - (Show a, Eq a) => TestName -> (Ratio.Rational -> a) -> (Rational -> a) -> TestNested +testRatioProperty + :: (Show a, Eq a) => TestName -> (Ratio.Rational -> a) -> (Rational -> a) -> TestNested testRatioProperty nm plutusFunc ghcFunc = embed $ testPropertyNamed nm (fromString nm) $ Hedgehog.property $ do rat <- Hedgehog.forAll $ Gen.realFrac_ (Range.linearFrac (-10000) 100000) @@ -86,61 +89,61 @@ testRatioProperty nm plutusFunc ghcFunc = testDivMod :: Property testDivMod = Hedgehog.property $ do - -- Generating zeroes often enough to trigger any potential bugs related to handling of zeroes. - let gen = Gen.frequency [(1, pure 0), (10, Gen.integral (Range.linear (-10000) 100000))] - (n1, n2) <- Hedgehog.forAll $ (,) <$> gen <*> gen - ghcResult <- tryHard $ divMod n1 n2 - plutusResult <- tryHard $ PlutusTx.divMod n1 n2 - Hedgehog.annotateShow ghcResult - Hedgehog.annotateShow plutusResult - Hedgehog.assert (ghcResult == plutusResult) + -- Generating zeroes often enough to trigger any potential bugs related to handling of zeroes. + let gen = Gen.frequency [(1, pure 0), (10, Gen.integral (Range.linear (-10000) 100000))] + (n1, n2) <- Hedgehog.forAll $ (,) <$> gen <*> gen + ghcResult <- tryHard $ divMod n1 n2 + plutusResult <- tryHard $ PlutusTx.divMod n1 n2 + Hedgehog.annotateShow ghcResult + Hedgehog.annotateShow plutusResult + Hedgehog.assert (ghcResult == plutusResult) testQuotRem :: Property testQuotRem = Hedgehog.property $ do - -- Generating zeroes often enough to trigger any potential bugs related to handling of zeroes. - let gen = Gen.frequency [(1, pure 0), (10, Gen.integral (Range.linear (-10000) 100000))] - (n1, n2) <- Hedgehog.forAll $ (,) <$> gen <*> gen - ghcResult <- tryHard $ quotRem n1 n2 - plutusResult <- tryHard $ PlutusTx.quotRem n1 n2 - Hedgehog.annotateShow ghcResult - Hedgehog.annotateShow plutusResult - Hedgehog.assert (ghcResult == plutusResult) + -- Generating zeroes often enough to trigger any potential bugs related to handling of zeroes. + let gen = Gen.frequency [(1, pure 0), (10, Gen.integral (Range.linear (-10000) 100000))] + (n1, n2) <- Hedgehog.forAll $ (,) <$> gen <*> gen + ghcResult <- tryHard $ quotRem n1 n2 + plutusResult <- tryHard $ PlutusTx.quotRem n1 n2 + Hedgehog.annotateShow ghcResult + Hedgehog.annotateShow plutusResult + Hedgehog.assert (ghcResult == plutusResult) testOrd :: Property testOrd = Hedgehog.property $ do - let gen = Gen.integral (Range.linear (-10000) 100000) - -- Ratio must have non-zero denominator or else an ArithException will be thrown. - gen' = Gen.filter (/= 0) gen - n1 <- Hedgehog.forAll $ (%) <$> gen <*> gen' - n2 <- Hedgehog.forAll $ (%) <$> gen <*> gen' - ghcResult <- tryHard $ n1 <= n2 - plutusResult <- tryHard $ (PlutusTx.<=) (Ratio.fromGHC n1) (Ratio.fromGHC n2) - Hedgehog.annotateShow ghcResult - Hedgehog.annotateShow plutusResult - Hedgehog.assert (ghcResult == plutusResult) + let gen = Gen.integral (Range.linear (-10000) 100000) + -- Ratio must have non-zero denominator or else an ArithException will be thrown. + gen' = Gen.filter (/= 0) gen + n1 <- Hedgehog.forAll $ (%) <$> gen <*> gen' + n2 <- Hedgehog.forAll $ (%) <$> gen <*> gen' + ghcResult <- tryHard $ n1 <= n2 + plutusResult <- tryHard $ (PlutusTx.<=) (Ratio.fromGHC n1) (Ratio.fromGHC n2) + Hedgehog.annotateShow ghcResult + Hedgehog.annotateShow plutusResult + Hedgehog.assert (ghcResult == plutusResult) eqData :: Property eqData = Hedgehog.property $ do - theData <- BuiltinData <$> Hedgehog.forAll genData - let ghcResult = theData == theData - plutusResult = theData PlutusTx.== theData - Hedgehog.annotateShow theData - Hedgehog.assert (ghcResult && plutusResult) + theData <- BuiltinData <$> Hedgehog.forAll genData + let ghcResult = theData == theData + plutusResult = theData PlutusTx.== theData + Hedgehog.annotateShow theData + Hedgehog.assert (ghcResult && plutusResult) -genData :: MonadGen m => m PLC.Data +genData :: (MonadGen m) => m PLC.Data genData = - let genInteger = Gen.integral (Range.linear (-10000) 100000) - genBytes = Gen.bytes (Range.linear 0 1000) - genList = Gen.list (Range.linear 0 10) - in Gen.recursive - Gen.choice - [ PLC.I <$> genInteger - , PLC.B <$> genBytes - ] - [ PLC.Constr <$> genInteger <*> genList genData - , PLC.Map <$> genList ((,) <$> genData <*> genData) - , PLC.List <$> genList genData - ] + let genInteger = Gen.integral (Range.linear (-10000) 100000) + genBytes = Gen.bytes (Range.linear 0 1000) + genList = Gen.list (Range.linear 0 10) + in Gen.recursive + Gen.choice + [ PLC.I <$> genInteger + , PLC.B <$> genBytes + ] + [ PLC.Constr <$> genInteger <*> genList genData + , PLC.Map <$> genList ((,) <$> genData <*> genData) + , PLC.List <$> genList genData + ] errorTrace :: CompiledCode Integer errorTrace = plc (Proxy @"errorTrace") (PlutusTx.traceError "") diff --git a/plutus-tx-plugin/test/Strictness/Spec.hs b/plutus-tx-plugin/test/Strictness/Spec.hs index bcc1e0439cb..c375318b3cc 100644 --- a/plutus-tx-plugin/test/Strictness/Spec.hs +++ b/plutus-tx-plugin/test/Strictness/Spec.hs @@ -15,43 +15,39 @@ import PlutusTx.TH (compile) tests :: TestNested tests = - testNested "Strictness" . pure $ testNestedGhc - [ goldenEvalCekCatchBudget "lambda-default" $ lambdaDefault `unsafeApplyCode` bot - , goldenPirReadable "lambda-default" lambdaDefault - , goldenUPlcReadable "lambda-default" lambdaDefault - - -- FIXME: This should not crash, but it currently does. - , goldenEvalCekCatchBudget "lambda-nonstrict" $ lambdaNonStrict `unsafeApplyCode` bot - , goldenPirReadable "lambda-nonstrict" lambdaNonStrict - , goldenUPlcReadable "lambda-nonstrict" lambdaNonStrict - - , goldenEvalCekCatchBudget "lambda-strict" $ lambdaStrict `unsafeApplyCode` bot - , goldenPirReadable "lambda-strict" lambdaStrict - , goldenUPlcReadable "lambda-strict" lambdaStrict - - -- FIXME: This should crash (because the `Strict` extension is on), but it currently doesn't. - , goldenEvalCekCatchBudget "let-default" $ letDefault `unsafeApplyCode` one - , goldenPirReadable "let-default" letDefault - , goldenUPlcReadable "let-default" letDefault - - , goldenEvalCekCatchBudget "let-nonstrict" $ letNonStrict `unsafeApplyCode` one - , goldenPirReadable "let-nonstrict" letNonStrict - , goldenUPlcReadable "let-nonstrict" letNonStrict - - -- FIXME: This should crash, but it currently doesn't. - , goldenEvalCekCatchBudget "let-strict" $ letStrict `unsafeApplyCode` one - , goldenPirReadable "let-strict" letStrict - , goldenUPlcReadable "let-strict" letStrict - ] + testNested "Strictness" . pure $ + testNestedGhc + [ goldenEvalCekCatchBudget "lambda-default" $ lambdaDefault `unsafeApplyCode` bot + , goldenPirReadable "lambda-default" lambdaDefault + , goldenUPlcReadable "lambda-default" lambdaDefault + , -- FIXME: This should not crash, but it currently does. + goldenEvalCekCatchBudget "lambda-nonstrict" $ lambdaNonStrict `unsafeApplyCode` bot + , goldenPirReadable "lambda-nonstrict" lambdaNonStrict + , goldenUPlcReadable "lambda-nonstrict" lambdaNonStrict + , goldenEvalCekCatchBudget "lambda-strict" $ lambdaStrict `unsafeApplyCode` bot + , goldenPirReadable "lambda-strict" lambdaStrict + , goldenUPlcReadable "lambda-strict" lambdaStrict + , -- FIXME: This should crash (because the `Strict` extension is on), but it currently doesn't. + goldenEvalCekCatchBudget "let-default" $ letDefault `unsafeApplyCode` one + , goldenPirReadable "let-default" letDefault + , goldenUPlcReadable "let-default" letDefault + , goldenEvalCekCatchBudget "let-nonstrict" $ letNonStrict `unsafeApplyCode` one + , goldenPirReadable "let-nonstrict" letNonStrict + , goldenUPlcReadable "let-nonstrict" letNonStrict + , -- FIXME: This should crash, but it currently doesn't. + goldenEvalCekCatchBudget "let-strict" $ letStrict `unsafeApplyCode` one + , goldenPirReadable "let-strict" letStrict + , goldenUPlcReadable "let-strict" letStrict + ] lambdaDefault :: CompiledCode (Integer -> Integer -> Integer) -lambdaDefault = $$(compile [|| \n m -> n PlutusTx.+ m ||]) +lambdaDefault = $$(compile [||\n m -> n PlutusTx.+ m||]) lambdaNonStrict :: CompiledCode (Integer -> Integer -> Integer) -lambdaNonStrict = $$(compile [|| \(~n) m -> n PlutusTx.+ m ||]) +lambdaNonStrict = $$(compile [||\(~n) m -> n PlutusTx.+ m||]) lambdaStrict :: CompiledCode (Integer -> Integer -> Integer) -lambdaStrict = $$(compile [|| \(!n) m -> n PlutusTx.+ m ||]) +lambdaStrict = $$(compile [||\(!n) m -> n PlutusTx.+ m||]) letDefault :: CompiledCode (Integer -> Integer) letDefault = @@ -84,7 +80,7 @@ letStrict = ) bot :: CompiledCode Integer -bot = $$(compile [|| PlutusTx.error () ||]) +bot = $$(compile [||PlutusTx.error ()||]) one :: CompiledCode Integer one = Tx.liftCodeDef 1 diff --git a/plutus-tx-plugin/test/TH/Spec.hs b/plutus-tx-plugin/test/TH/Spec.hs index 57eb395dc0b..6c81ecd5fda 100644 --- a/plutus-tx-plugin/test/TH/Spec.hs +++ b/plutus-tx-plugin/test/TH/Spec.hs @@ -3,13 +3,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} - +{-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=3 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:defer-errors #-} +{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-} -{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-} -{-# OPTIONS_GHC -Wno-orphans #-} module TH.Spec (tests) where @@ -36,46 +35,51 @@ someData :: (BuiltinData, BuiltinData, BuiltinData) someData = (toBuiltinData (One 1), toBuiltinData Two, toBuiltinData (Three ())) tests :: TestNested -tests = testNested "TH" . pure $ testNestedGhc - [ goldenPir "simple" simple - , goldenPir "power" powerPlc - , goldenPir "and" andPlc - , goldenEvalCek "all" allPlc - , goldenEvalCek "convertString" convertString - , goldenEvalCekLog "traceDirect" traceDirect - , goldenEvalCekLog "tracePrelude" tracePrelude - , goldenEvalCekLog "traceRepeatedly" traceRepeatedly - -- want to see the raw structure, so using Show - , nestedGoldenVsDoc "someData" "" (pretty $ Haskell.show someData) - ] +tests = + testNested "TH" + . pure + $ testNestedGhc + [ goldenPir "simple" simple + , goldenPir "power" powerPlc + , goldenPir "and" andPlc + , goldenEvalCek "all" allPlc + , goldenEvalCek "convertString" convertString + , goldenEvalCekLog "traceDirect" traceDirect + , goldenEvalCekLog "tracePrelude" tracePrelude + , goldenEvalCekLog "traceRepeatedly" traceRepeatedly + , -- want to see the raw structure, so using Show + nestedGoldenVsDoc "someData" "" (pretty $ Haskell.show someData) + ] simple :: CompiledCode (Bool -> Integer) -simple = $$(compile [|| \(x::Bool) -> if x then (1::Integer) else (2::Integer) ||]) +simple = $$(compile [||\(x :: Bool) -> if x then (1 :: Integer) else (2 :: Integer)||]) -- similar to the power example for Feldspar - should be completely unrolled at compile time powerPlc :: CompiledCode (Integer -> Integer) -powerPlc = $$(compile [|| $$(power (4::Integer)) ||]) +powerPlc = $$(compile [||$$(power (4 :: Integer))||]) andPlc :: CompiledCode Bool -andPlc = $$(compile [|| $$(andTH) True False ||]) +andPlc = $$(compile [||$$(andTH) True False||]) allPlc :: CompiledCode Bool -allPlc = $$(compile [|| List.all (\(x::Integer) -> x > 5) [7, 6] ||]) +allPlc = $$(compile [||List.all (\(x :: Integer) -> x > 5) [7, 6]||]) convertString :: CompiledCode Builtins.BuiltinString -convertString = $$(compile [|| "test" ||]) +convertString = $$(compile [||"test"||]) traceDirect :: CompiledCode () -traceDirect = $$(compile [|| Builtins.trace "test" () ||]) +traceDirect = $$(compile [||Builtins.trace "test" ()||]) tracePrelude :: CompiledCode Integer -tracePrelude = $$(compile [|| trace "test" (1::Integer) ||]) +tracePrelude = $$(compile [||trace "test" (1 :: Integer)||]) traceRepeatedly :: CompiledCode Integer -traceRepeatedly = $$(compile - [|| - let i1 = trace "Making my first int" (1::Integer) - i2 = trace "Making my second int" (2::Integer) - i3 = trace ("Adding them up: " <> show (i1 + i2)) (i1 + i2) - in i3 - ||]) +traceRepeatedly = + $$( compile + [|| + let i1 = trace "Making my first int" (1 :: Integer) + i2 = trace "Making my second int" (2 :: Integer) + i3 = trace ("Adding them up: " <> show (i1 + i2)) (i1 + i2) + in i3 + ||] + ) diff --git a/plutus-tx-plugin/test/TH/TestTH.hs b/plutus-tx-plugin/test/TH/TestTH.hs index a729fcdb166..86120c22ece 100644 --- a/plutus-tx-plugin/test/TH/TestTH.hs +++ b/plutus-tx-plugin/test/TH/TestTH.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} + module TH.TestTH where import Language.Haskell.TH @@ -13,12 +14,17 @@ import PlutusTx.Prelude power :: Integer -> Code Q (Integer -> Integer) power n = - if n <= 0 then - [|| \ _ -> (1::Integer) ||] - else if even n then - [|| \(x::Integer) -> let y = $$(power (n `divideInteger` (2::Integer))) x in y `multiplyInteger` y ||] + if n <= 0 + then + [||\_ -> (1 :: Integer)||] else - [|| \(x::Integer) -> x `multiplyInteger` ($$(power (n `subtractInteger` (1::Integer))) x) ||] + if even n + then + [|| + \(x :: Integer) -> let y = $$(power (n `divideInteger` (2 :: Integer))) x in y `multiplyInteger` y + ||] + else + [||\(x :: Integer) -> x `multiplyInteger` ($$(power (n `subtractInteger` (1 :: Integer))) x)||] andTH :: Code Q (Bool -> Bool -> Bool) -andTH = [||\(a :: Bool) -> \(b::Bool) -> if a then if b then True else False else False||] +andTH = [||\(a :: Bool) -> \(b :: Bool) -> if a then if b then True else False else False||] diff --git a/plutus-tx-plugin/test/size/Main.hs b/plutus-tx-plugin/test/size/Main.hs index 19ff5982f0d..7f1e1d4ea06 100644 --- a/plutus-tx-plugin/test/size/Main.hs +++ b/plutus-tx-plugin/test/size/Main.hs @@ -15,156 +15,171 @@ import Test.Tasty (defaultMain, testGroup) import Test.Tasty.Extras (runTestNested, testNested) main :: IO () -main = defaultMain $ testGroup "Size regression tests" - [ runTestNested ["test", "size", "Golden"] - [ testNested "Rational" - [ testNested "Eq" - [ goldenSize "equal" ratEq - , goldenSize "not-equal" ratNeq - ] - , testNested "Ord" - [ goldenSize "compare" ratCompare - , goldenSize "less-than-equal" ratLe - , goldenSize "greater-than-equal" ratGe - , goldenSize "less-than" ratLt - , goldenSize "greater-than" ratGt - , goldenSize "max" ratMax - , goldenSize "min" ratMin - ] - , testNested "Additive" - [ goldenSize "plus" ratPlus - , goldenSize "zero" ratZero - , goldenSize "minus" ratMinus - , goldenSize "negate-specialized" ratNegate - ] - , testNested "Multiplicative" - [ goldenSize "times" ratTimes - , goldenSize "one" ratOne - , goldenSize "scale" ratScale - ] - , testNested "Serialization" - [ goldenSize "toBuiltinData" ratToBuiltin - , goldenSize "fromBuiltinData" ratFromBuiltin - , goldenSize "unsafeFromBuiltinData" ratUnsafeFromBuiltin - ] - , testNested "Construction" - [ goldenSize "unsafeRatio" ratMkUnsafe - , goldenSize "ratio" ratMkSafe - , goldenSize "fromInteger" ratFromInteger - ] - , testNested "Other" - [ goldenSize "numerator" ratNumerator - , goldenSize "denominator" ratDenominator - , goldenSize "round" ratRound - , goldenSize "truncate" ratTruncate - , goldenSize "properFraction" ratProperFraction - , goldenSize "recip" ratRecip - , goldenSize "abs-specialized" ratAbs +main = + defaultMain $ + testGroup + "Size regression tests" + [ runTestNested + ["test", "size", "Golden"] + [ testNested + "Rational" + [ testNested + "Eq" + [ goldenSize "equal" ratEq + , goldenSize "not-equal" ratNeq + ] + , testNested + "Ord" + [ goldenSize "compare" ratCompare + , goldenSize "less-than-equal" ratLe + , goldenSize "greater-than-equal" ratGe + , goldenSize "less-than" ratLt + , goldenSize "greater-than" ratGt + , goldenSize "max" ratMax + , goldenSize "min" ratMin + ] + , testNested + "Additive" + [ goldenSize "plus" ratPlus + , goldenSize "zero" ratZero + , goldenSize "minus" ratMinus + , goldenSize "negate-specialized" ratNegate + ] + , testNested + "Multiplicative" + [ goldenSize "times" ratTimes + , goldenSize "one" ratOne + , goldenSize "scale" ratScale + ] + , testNested + "Serialization" + [ goldenSize "toBuiltinData" ratToBuiltin + , goldenSize "fromBuiltinData" ratFromBuiltin + , goldenSize "unsafeFromBuiltinData" ratUnsafeFromBuiltin + ] + , testNested + "Construction" + [ goldenSize "unsafeRatio" ratMkUnsafe + , goldenSize "ratio" ratMkSafe + , goldenSize "fromInteger" ratFromInteger + ] + , testNested + "Other" + [ goldenSize "numerator" ratNumerator + , goldenSize "denominator" ratDenominator + , goldenSize "round" ratRound + , goldenSize "truncate" ratTruncate + , goldenSize "properFraction" ratProperFraction + , goldenSize "recip" ratRecip + , goldenSize "abs-specialized" ratAbs + ] ] ] + , testGroup + "Comparison" + [ fitsUnder "negate" ("specialized", ratNegate) ("general", genNegate) + , fitsUnder "abs" ("specialized", ratAbs) ("general", genAbs) + , fitsUnder + "scale" + ("type class method", ratScale) + ("equivalent in other primitives", genScale) + ] ] - , testGroup "Comparison" - [ fitsUnder "negate" ("specialized", ratNegate) ("general", genNegate) - , fitsUnder "abs" ("specialized", ratAbs) ("general", genAbs) - , fitsUnder "scale" ("type class method", ratScale) - ("equivalent in other primitives", genScale) - ] - ] -- Compiled definitions ratEq :: CompiledCode (Plutus.Rational -> Plutus.Rational -> Plutus.Bool) -ratEq = $$(compile [|| (Plutus.==) ||]) +ratEq = $$(compile [||(Plutus.==)||]) ratNeq :: CompiledCode (Plutus.Rational -> Plutus.Rational -> Plutus.Bool) -ratNeq = $$(compile [|| (Plutus./=) ||]) +ratNeq = $$(compile [||(Plutus./=)||]) ratCompare :: CompiledCode (Plutus.Rational -> Plutus.Rational -> Plutus.Ordering) -ratCompare = $$(compile [|| Plutus.compare ||]) +ratCompare = $$(compile [||Plutus.compare||]) ratLe :: CompiledCode (Plutus.Rational -> Plutus.Rational -> Plutus.Bool) -ratLe = $$(compile [|| (Plutus.<=) ||]) +ratLe = $$(compile [||(Plutus.<=)||]) ratLt :: CompiledCode (Plutus.Rational -> Plutus.Rational -> Plutus.Bool) -ratLt = $$(compile [|| (Plutus.<) ||]) +ratLt = $$(compile [||(Plutus.<)||]) ratGe :: CompiledCode (Plutus.Rational -> Plutus.Rational -> Plutus.Bool) -ratGe = $$(compile [|| (Plutus.>=) ||]) +ratGe = $$(compile [||(Plutus.>=)||]) ratGt :: CompiledCode (Plutus.Rational -> Plutus.Rational -> Plutus.Bool) -ratGt = $$(compile [|| (Plutus.>) ||]) +ratGt = $$(compile [||(Plutus.>)||]) ratMax :: CompiledCode (Plutus.Rational -> Plutus.Rational -> Plutus.Rational) -ratMax = $$(compile [|| Plutus.max ||]) +ratMax = $$(compile [||Plutus.max||]) ratMin :: CompiledCode (Plutus.Rational -> Plutus.Rational -> Plutus.Rational) -ratMin = $$(compile [|| Plutus.min ||]) +ratMin = $$(compile [||Plutus.min||]) ratPlus :: CompiledCode (Plutus.Rational -> Plutus.Rational -> Plutus.Rational) -ratPlus = $$(compile [|| (Plutus.+) ||]) +ratPlus = $$(compile [||(Plutus.+)||]) ratZero :: CompiledCode Plutus.Rational -ratZero = $$(compile [|| Plutus.zero ||]) +ratZero = $$(compile [||Plutus.zero||]) ratMinus :: CompiledCode (Plutus.Rational -> Plutus.Rational -> Plutus.Rational) -ratMinus = $$(compile [|| (Plutus.-) ||]) +ratMinus = $$(compile [||(Plutus.-)||]) ratNegate :: CompiledCode (Plutus.Rational -> Plutus.Rational) -ratNegate = $$(compile [|| PlutusRatio.negate ||]) +ratNegate = $$(compile [||PlutusRatio.negate||]) ratTimes :: CompiledCode (Plutus.Rational -> Plutus.Rational -> Plutus.Rational) -ratTimes = $$(compile [|| (Plutus.*) ||]) +ratTimes = $$(compile [||(Plutus.*)||]) ratOne :: CompiledCode Plutus.Rational -ratOne = $$(compile [|| Plutus.one ||]) +ratOne = $$(compile [||Plutus.one||]) ratScale :: CompiledCode (Plutus.Integer -> Plutus.Rational -> Plutus.Rational) -ratScale = $$(compile [|| Plutus.scale ||]) +ratScale = $$(compile [||Plutus.scale||]) ratToBuiltin :: CompiledCode (Plutus.Rational -> Plutus.BuiltinData) -ratToBuiltin = $$(compile [|| toBuiltinData ||]) +ratToBuiltin = $$(compile [||toBuiltinData||]) ratFromBuiltin :: CompiledCode (Plutus.BuiltinData -> Plutus.Maybe Plutus.Rational) -ratFromBuiltin = $$(compile [|| fromBuiltinData ||]) +ratFromBuiltin = $$(compile [||fromBuiltinData||]) ratUnsafeFromBuiltin :: CompiledCode (Plutus.BuiltinData -> Plutus.Rational) -ratUnsafeFromBuiltin = $$(compile [|| unsafeFromBuiltinData ||]) +ratUnsafeFromBuiltin = $$(compile [||unsafeFromBuiltinData||]) ratMkUnsafe :: CompiledCode (Plutus.Integer -> Plutus.Integer -> Plutus.Rational) -ratMkUnsafe = $$(compile [|| PlutusRatio.unsafeRatio ||]) +ratMkUnsafe = $$(compile [||PlutusRatio.unsafeRatio||]) ratMkSafe :: CompiledCode (Plutus.Integer -> Plutus.Integer -> Plutus.Maybe Plutus.Rational) -ratMkSafe = $$(compile [|| PlutusRatio.ratio ||]) +ratMkSafe = $$(compile [||PlutusRatio.ratio||]) ratNumerator :: CompiledCode (Plutus.Rational -> Plutus.Integer) -ratNumerator = $$(compile [|| PlutusRatio.numerator ||]) +ratNumerator = $$(compile [||PlutusRatio.numerator||]) ratDenominator :: CompiledCode (Plutus.Rational -> Plutus.Integer) -ratDenominator = $$(compile [|| PlutusRatio.denominator ||]) +ratDenominator = $$(compile [||PlutusRatio.denominator||]) ratRound :: CompiledCode (Plutus.Rational -> Plutus.Integer) -ratRound = $$(compile [|| PlutusRatio.round ||]) +ratRound = $$(compile [||PlutusRatio.round||]) ratTruncate :: CompiledCode (Plutus.Rational -> Plutus.Integer) -ratTruncate = $$(compile [|| PlutusRatio.truncate ||]) +ratTruncate = $$(compile [||PlutusRatio.truncate||]) ratProperFraction :: CompiledCode (Plutus.Rational -> (Plutus.Integer, Plutus.Rational)) -ratProperFraction = $$(compile [|| PlutusRatio.properFraction ||]) +ratProperFraction = $$(compile [||PlutusRatio.properFraction||]) ratRecip :: CompiledCode (Plutus.Rational -> Plutus.Rational) -ratRecip = $$(compile [|| PlutusRatio.recip ||]) +ratRecip = $$(compile [||PlutusRatio.recip||]) ratAbs :: CompiledCode (Plutus.Rational -> Plutus.Rational) -ratAbs = $$(compile [|| PlutusRatio.abs ||]) +ratAbs = $$(compile [||PlutusRatio.abs||]) ratFromInteger :: CompiledCode (Plutus.Integer -> Plutus.Rational) -ratFromInteger = $$(compile [|| PlutusRatio.fromInteger ||]) +ratFromInteger = $$(compile [||PlutusRatio.fromInteger||]) genNegate :: CompiledCode (Plutus.Rational -> Plutus.Rational) -genNegate = $$(compile [|| Plutus.negate ||]) +genNegate = $$(compile [||Plutus.negate||]) genAbs :: CompiledCode (Plutus.Rational -> Plutus.Rational) -genAbs = $$(compile [|| Plutus.abs ||]) +genAbs = $$(compile [||Plutus.abs||]) genScale :: CompiledCode (Plutus.Integer -> Plutus.Rational -> Plutus.Rational) -genScale = $$(compile [|| \s v -> PlutusRatio.fromInteger s Plutus.* v ||]) +genScale = $$(compile [||\s v -> PlutusRatio.fromInteger s Plutus.* v||])