diff --git a/plutus-benchmark/cek-calibration/Main.hs b/plutus-benchmark/cek-calibration/Main.hs index 0741ffd74f6..99a2b84a2a8 100644 --- a/plutus-benchmark/cek-calibration/Main.hs +++ b/plutus-benchmark/cek-calibration/Main.hs @@ -82,7 +82,7 @@ writePlc p = traverseOf UPLC.progTerm UPLC.unDeBruijnTerm p of Left e -> throw e - Right p' -> Haskell.print . PP.prettyPlcClassicDebug $ p' + Right p' -> Haskell.print . PP.prettyPlcClassicSimple $ p' main1 :: Haskell.IO () diff --git a/plutus-benchmark/nofib/exe/Main.hs b/plutus-benchmark/nofib/exe/Main.hs index 06a8403ac18..86ea031bf71 100644 --- a/plutus-benchmark/nofib/exe/Main.hs +++ b/plutus-benchmark/nofib/exe/Main.hs @@ -35,7 +35,7 @@ import PlutusCore.Default (DefaultFun, DefaultUni) import PlutusCore.Evaluation.Machine.ExBudget (ExBudget (..)) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (..), ExMemory (..)) -import PlutusCore.Pretty (prettyPlcClassicDebug) +import PlutusCore.Pretty (prettyPlcClassicSimple) import PlutusTx (getPlcNoAnn) import PlutusTx.Code (CompiledCode, sizePlc) import PlutusTx.Prelude hiding (fmap, mappend, traverse_, (<$), (<$>), (<*>), (<>)) @@ -311,7 +311,7 @@ main :: IO () main = do execParser (info (helper <*> options) (fullDesc <> progDesc description <> footerDoc (Just footerInfo))) >>= \case RunPLC pa -> - print . prettyPlcClassicDebug . evaluateWithCek . getTerm $ pa + print . prettyPlcClassicSimple . evaluateWithCek . getTerm $ pa RunHaskell pa -> case pa of Clausify formula -> print $ Clausify.runClausify formula @@ -322,7 +322,7 @@ main = do Primetest n -> if n<0 then Hs.error "Positive number expected" else print $ Prime.runPrimalityTest n DumpPLC pa -> - traverse_ putStrLn $ unindent . prettyPlcClassicDebug . UPLC.Program () PLC.latestVersion . getTerm $ pa + traverse_ putStrLn $ unindent . prettyPlcClassicSimple . UPLC.Program () PLC.latestVersion . getTerm $ pa where unindent d = map (dropWhile isSpace) $ (Hs.lines . Hs.show $ d) DumpFlatNamed pa -> writeFlatNamed . UPLC.Program () PLC.latestVersion . getTerm $ pa diff --git a/plutus-benchmark/nofib/test/Spec.hs b/plutus-benchmark/nofib/test/Spec.hs index d7722d27ad9..f0fc5648215 100644 --- a/plutus-benchmark/nofib/test/Spec.hs +++ b/plutus-benchmark/nofib/test/Spec.hs @@ -32,7 +32,7 @@ runTestGhc = runTestNested ["nofib", "test"] . pure . testNestedGhc -- Unit tests comparing PLC and Haskell computations on given inputs runAndCheck :: Tx.Lift DefaultUni a => Term -> a -> IO () -runAndCheck term value = cekResultMatchesHaskellValue term (@?=) value +runAndCheck term = cekResultMatchesHaskellValue term (@?=) ---------------- Clausify ---------------- diff --git a/plutus-benchmark/script-contexts/test/Spec.hs b/plutus-benchmark/script-contexts/test/Spec.hs index 62557c4ccb5..1b8b844005d 100644 --- a/plutus-benchmark/script-contexts/test/Spec.hs +++ b/plutus-benchmark/script-contexts/test/Spec.hs @@ -25,7 +25,7 @@ assertSucceeded t = case runTermCek t of (Right _, _) -> pure () (Left err, logs) -> assertFailure . Text.unpack . Text.intercalate "\n" $ - [ render (prettyPlcClassicDebug err) + [ render (prettyPlcClassicSimple err) , "Cek logs:" ] ++ logs diff --git a/plutus-core/changelog.d/20240510_200705_Yuriy.Lazaryev_4808_unique_names_roundtrip_tests.md b/plutus-core/changelog.d/20240510_200705_Yuriy.Lazaryev_4808_unique_names_roundtrip_tests.md new file mode 100644 index 00000000000..e011c711290 --- /dev/null +++ b/plutus-core/changelog.d/20240510_200705_Yuriy.Lazaryev_4808_unique_names_roundtrip_tests.md @@ -0,0 +1,3 @@ +### Changed + +- All names are printed with their unique suffixes by default. diff --git a/plutus-core/executables/plc/Main.hs b/plutus-core/executables/plc/Main.hs index e822b729dfc..6589bea6622 100644 --- a/plutus-core/executables/plc/Main.hs +++ b/plutus-core/executables/plc/Main.hs @@ -168,9 +168,9 @@ runTypecheck (TypecheckOptions inp fmt) = do PLC.inferTypeOfProgram tcConfig (void prog) of Left (e :: PLC.Error PLC.DefaultUni PLC.DefaultFun ()) -> - errorWithoutStackTrace $ PP.displayPlcDef e + errorWithoutStackTrace $ PP.displayPlc e Right ty -> - T.putStrLn (PP.displayPlcDef ty) >> exitSuccess + T.putStrLn (PP.displayPlc ty) >> exitSuccess ---------------- Optimisation ---------------- diff --git a/plutus-core/executables/plutus/AnyProgram/IO.hs b/plutus-core/executables/plutus/AnyProgram/IO.hs index 5e61e0ff368..91b34895319 100644 --- a/plutus-core/executables/plutus/AnyProgram/IO.hs +++ b/plutus-core/executables/plutus/AnyProgram/IO.hs @@ -90,10 +90,10 @@ writeProgram sng ast file = prettyWithStyle :: PP.PrettyPlc a => PrettyStyle -> a -> Doc ann prettyWithStyle = \case - Classic -> PP.prettyPlcClassicDef - ClassicDebug -> PP.prettyPlcClassicDebug - Readable -> PP.prettyPlcReadableDef - ReadableDebug -> PP.prettyPlcReadableDebug + Classic -> PP.prettyPlcClassic + ClassicSimple -> PP.prettyPlcClassicSimple + Readable -> PP.prettyPlcReadable + ReadableSimple -> PP.prettyPlcReadableSimple readFileName :: (?opts :: Opts) => FileName -> IO BS.ByteString diff --git a/plutus-core/executables/plutus/Debugger/TUI/Event.hs b/plutus-core/executables/plutus/Debugger/TUI/Event.hs index 642d2830241..c0c76783e22 100644 --- a/plutus-core/executables/plutus/Debugger/TUI/Event.hs +++ b/plutus-core/executables/plutus/Debugger/TUI/Event.hs @@ -148,13 +148,13 @@ handleDebuggerEvent _ hsDir (B.AppEvent (UpdateClientEvent budgetData cekState)) BE.editorText EditorReturnValue Nothing - (PLC.displayPlcDef (dischargeCekValue v)) + (PLC.displayPlc (dischargeCekValue v)) Terminating t -> dsReturnValueEditor .~ BE.editorText EditorReturnValue Nothing - (PLC.render $ vcat ["Evaluation Finished. Result:", line, PLC.prettyPlcDef t]) + (PLC.render $ vcat ["Evaluation Finished. Result:", line, PLC.prettyPlc t]) Starting{} -> id handleDebuggerEvent _ _ (B.AppEvent (CekErrorEvent budgetData e)) = modify' $ \st -> @@ -163,7 +163,7 @@ handleDebuggerEvent _ _ (B.AppEvent (CekErrorEvent budgetData e)) = -- on the chain: the difference is that on the chain, a budget may become zero (exhausted) -- but is not allowed to become negative. st & set dsBudgetData budgetData - & appendToLogsEditor ("Error happened:" <+> PLC.prettyPlcDef e) + & appendToLogsEditor ("Error happened:" <+> PLC.prettyPlc e) handleDebuggerEvent _ _ (B.AppEvent (DriverLogEvent t)) = modify' $ appendToLogsEditor ("Driver logged:" <+> pretty t) handleDebuggerEvent _ _ (B.AppEvent (CekEmitEvent t)) = diff --git a/plutus-core/executables/plutus/Debugger/TUI/Main.hs b/plutus-core/executables/plutus/Debugger/TUI/Main.hs index 3fdc3903318..c17ac9a57c3 100644 --- a/plutus-core/executables/plutus/Debugger/TUI/Main.hs +++ b/plutus-core/executables/plutus/Debugger/TUI/Main.hs @@ -88,7 +88,7 @@ main sn sa prog = do STxSrcSpans -> progN -- make sure to not display annotations - let progTextN = withA @PP.Pretty sa $ PP.displayPlcDef $ void progN + let progTextN = withA @PP.Pretty sa $ PP.displayPlc $ void progN -- the parsed prog with uplc.srcspan progWithUplcSpan <- either (fail . show @(PLC.Error DefaultUni DefaultFun PLC.SrcSpan)) pure $ @@ -168,7 +168,7 @@ driverThread driverMailbox brickMailbox prog mbudget = do let term = prog ^. UPLC.progTerm ndterm <- case runExcept @FreeVariableError $ deBruijnTerm term of Right t -> pure t - Left _ -> fail $ "deBruijnTerm failed: " <> PLC.displayPlcDef (void term) + Left _ -> fail $ "deBruijnTerm failed: " <> PLC.displayPlc (void term) -- if user provided `--budget` the mode is restricting; otherwise just counting -- See Note [Budgeting implementation for the debugger] let exBudgetMode = case mbudget of diff --git a/plutus-core/executables/plutus/GetOpt.hs b/plutus-core/executables/plutus/GetOpt.hs index 93dc745faec..b3db80e9eef 100644 --- a/plutus-core/executables/plutus/GetOpt.hs +++ b/plutus-core/executables/plutus/GetOpt.hs @@ -153,7 +153,7 @@ optDescrs = -- PRETTY-STYLE for OUTPUT & ERRORS , Option ['p'] ["pretty"] - (ReqArg (set prettyStyle . read) "STYLE") "Make program's textual-output&error output pretty. Ignored for non-textual output (flat/cbor). Values: `classic`, `readable, `classic-debug`, `readable-debug` " + (ReqArg (set prettyStyle . read) "STYLE") "Make program's textual-output&error output pretty. Ignored for non-textual output (flat/cbor). Values: `classic`, `readable, `classic-simple`, `readable-simple` " -- OUTPUT , Option ['o'] [] (ReqArg (setOutput . AbsolutePath) "FILE") "Write compiled program to file" @@ -257,14 +257,14 @@ instance Read Ann where instance Read PrettyStyle where readsPrec _prec = one . \case "classic" -> Classic - "classic-debug" -> ClassicDebug + "classic-simple" -> ClassicSimple "readable" -> Readable - "readable-debug" -> ReadableDebug + "readable-simple" -> ReadableSimple -- synonyms for lazy people like me "c" -> Classic - "cd" -> ClassicDebug + "cs" -> ClassicSimple "r" -> Readable - "rd" -> ReadableDebug + "rs" -> ReadableSimple _ -> error "Failed to read --pretty=STYLE." instance Read ExBudget where diff --git a/plutus-core/executables/plutus/Types.hs b/plutus-core/executables/plutus/Types.hs index 0653d3f0135..ab012b7c067 100644 --- a/plutus-core/executables/plutus/Types.hs +++ b/plutus-core/executables/plutus/Types.hs @@ -109,9 +109,9 @@ data DebugInterface -- | ONLY applicable for Text output. data PrettyStyle = Classic - | ClassicDebug + | ClassicSimple | Readable - | ReadableDebug + | ReadableSimple deriving stock (Show) data Verbosity diff --git a/plutus-core/executables/src/PlutusCore/Executable/Common.hs b/plutus-core/executables/src/PlutusCore/Executable/Common.hs index 8333287d342..809064866c8 100644 --- a/plutus-core/executables/src/PlutusCore/Executable/Common.hs +++ b/plutus-core/executables/src/PlutusCore/Executable/Common.hs @@ -180,7 +180,7 @@ printBudgetStateTally term model (Cek.CekExTally costs) = do putStrLn "" putStrLn $ "Total builtin costs: " ++ budgetToString totalBuiltinCosts printf "Time spent executing builtins: %4.2f%%\n" - (100 * (getCPU totalBuiltinCosts) / (getCPU totalCost)) + (100 * getCPU totalBuiltinCosts / getCPU totalCost) putStrLn "" putStrLn $ "Total budget spent: " ++ printf (budgetToString totalCost) putStrLn $ "Predicted execution time: " @@ -316,7 +316,7 @@ writeFlat :: writeFlat outp flatMode prog = do -- ASTs are always serialised with unit annotations to save space: `flat` -- does not need any space to serialise (). - let flatProg = serialiseProgramFlat flatMode (() <$ prog) + let flatProg = serialiseProgramFlat flatMode (void prog) case outp of FileOutput file -> BSL.writeFile file flatProg StdOutput -> BSL.putStr flatProg @@ -327,10 +327,10 @@ writeFlat outp flatMode prog = do getPrintMethod :: PP.PrettyPlc a => PrintMode -> (a -> Doc ann) getPrintMethod = \case - Classic -> PP.prettyPlcClassicDef - Debug -> PP.prettyPlcClassicDebug - Readable -> PP.prettyPlcReadableDef - ReadableDebug -> PP.prettyPlcReadableDebug + Classic -> PP.prettyPlcClassic + Simple -> PP.prettyPlcClassicSimple + Readable -> PP.prettyPlcReadable + ReadableSimple -> PP.prettyPlcReadableSimple writeProgram :: ( ProgramLike p @@ -380,20 +380,20 @@ data SomeExample = SomeTypedExample SomeTypedExample | SomeUntypedExample SomeUn prettySignature :: ExampleName -> SomeExample -> Doc ann prettySignature name (SomeTypedExample (SomeTypeExample (TypeExample kind _))) = - pretty name <+> "::" <+> PP.prettyPlcDef kind + pretty name <+> "::" <+> PP.prettyPlc kind prettySignature name (SomeTypedExample (SomeTypedTermExample (TypedTermExample ty _))) = - pretty name <+> ":" <+> PP.prettyPlcDef ty + pretty name <+> ":" <+> PP.prettyPlc ty prettySignature name (SomeUntypedExample _) = pretty name prettyExample :: SomeExample -> Doc ann prettyExample = \case - SomeTypedExample (SomeTypeExample (TypeExample _ ty)) -> PP.prettyPlcDef ty + SomeTypedExample (SomeTypeExample (TypeExample _ ty)) -> PP.prettyPlc ty SomeTypedExample (SomeTypedTermExample (TypedTermExample _ term)) -> - PP.prettyPlcDef $ PLC.Program () PLC.latestVersion term + PP.prettyPlc $ PLC.Program () PLC.latestVersion term SomeUntypedExample (SomeUntypedTermExample (UntypedTermExample term)) -> - PP.prettyPlcDef $ UPLC.Program () PLC.latestVersion term + PP.prettyPlc $ UPLC.Program () PLC.latestVersion term toTypedTermExample :: PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () -> TypedTermExample @@ -405,7 +405,7 @@ toTypedTermExample term = TypedTermExample ty term PLC.inferTypeOfProgram tcConfig program ty = case errOrTy of Left (err :: PLC.Error PLC.DefaultUni PLC.DefaultFun ()) -> - error $ PP.displayPlcDef err + error $ PP.displayPlc err Right vTy -> PLC.unNormalized vTy getInteresting :: IO [(ExampleName, PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun ())] diff --git a/plutus-core/executables/src/PlutusCore/Executable/Parsers.hs b/plutus-core/executables/src/PlutusCore/Executable/Parsers.hs index 78784aa9234..3ee330301a1 100644 --- a/plutus-core/executables/src/PlutusCore/Executable/Parsers.hs +++ b/plutus-core/executables/src/PlutusCore/Executable/Parsers.hs @@ -100,12 +100,12 @@ printmode :: Parser PrintMode printmode = option auto ( long "print-mode" <> metavar "MODE" - <> value Debug + <> value Simple <> showDefault <> help ("Print mode for textual output (ignored elsewhere): Classic -> plcPrettyClassicDef, " <> "Debug -> plcPrettyClassicDebug, " - <> "Readable -> prettyPlcReadableDef, ReadableDebug -> prettyPlcReadableDebug" )) + <> "Readable -> prettyPlcReadable, ReadableSimple -> prettyPlcReadableSimple" )) printOpts :: Parser PrintOptions printOpts = PrintOptions <$> input <*> output <*> printmode diff --git a/plutus-core/executables/src/PlutusCore/Executable/Types.hs b/plutus-core/executables/src/PlutusCore/Executable/Types.hs index 61e7a3a116f..293047bb197 100644 --- a/plutus-core/executables/src/PlutusCore/Executable/Types.hs +++ b/plutus-core/executables/src/PlutusCore/Executable/Types.hs @@ -53,7 +53,7 @@ instance Show Input where data Output = FileOutput FilePath | StdOutput | NoOutput data TimingMode = NoTiming | Timing Integer deriving stock (Eq) -- Report program execution time? data CekModel = Default | Unit -- Which cost model should we use for CEK machine steps? -data PrintMode = Classic | Debug | Readable | ReadableDebug deriving stock (Show, Read) +data PrintMode = Classic | Simple | Readable | ReadableSimple deriving stock (Show, Read) data TraceMode = None | Logs | LogsWithTimestamps | LogsWithBudgets deriving stock (Show, Read) type ExampleName = T.Text data ExampleMode = ExampleSingle ExampleName | ExampleAvailable diff --git a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Default.hs index d64c6275c9a..cdbb574f1f4 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Core/Instance/Pretty/Default.hs @@ -20,17 +20,17 @@ import PlutusCore.Pretty.PrettyConst import Universe instance Pretty TyName where - pretty = prettyClassicDef + pretty = prettyClassic instance Pretty Name where - pretty = prettyClassicDef + pretty = prettyClassic instance Pretty ann => Pretty (Kind ann) where - pretty = prettyClassicDef + pretty = prettyClassic instance (PrettyClassic tyname, PrettyParens (SomeTypeIn uni), Pretty ann) => Pretty (Type tyname uni ann) where - pretty = prettyClassicDef + pretty = prettyClassic instance ( PrettyClassic tyname @@ -39,7 +39,7 @@ instance , Pretty fun , Pretty ann ) => Pretty (Term tyname name uni fun ann) where - pretty = prettyClassicDef + pretty = prettyClassic instance ( PrettyClassic tyname @@ -48,4 +48,4 @@ instance , Pretty fun , Pretty ann ) => Pretty (Program tyname name uni fun ann) where - pretty = prettyClassicDef + pretty = prettyClassic diff --git a/plutus-core/plutus-core/src/PlutusCore/DeBruijn/Internal.hs b/plutus-core/plutus-core/src/PlutusCore/DeBruijn/Internal.hs index 452c02356bd..03a924d6a35 100644 --- a/plutus-core/plutus-core/src/PlutusCore/DeBruijn/Internal.hs +++ b/plutus-core/plutus-core/src/PlutusCore/DeBruijn/Internal.hs @@ -9,41 +9,41 @@ {-# OPTIONS_GHC -Wno-identities #-} -- | Support for using de Bruijn indices for term and type names. -module PlutusCore.DeBruijn.Internal ( - Index (..), - HasIndex (..), - DeBruijn (..), - NamedDeBruijn (..), +module PlutusCore.DeBruijn.Internal + ( Index (..) + , HasIndex (..) + , DeBruijn (..) + , NamedDeBruijn (..) -- we follow the same approach as Renamed: expose the constructor from Internal module, -- but hide it in the parent module. - FakeNamedDeBruijn (..), - TyDeBruijn (..), - NamedTyDeBruijn (..), - FreeVariableError (..), - AsFreeVariableError (..), - Level (..), - LevelInfo (..), - declareUnique, - declareBinder, - withScope, - getIndex, - getUnique, - unNameDeBruijn, - unNameTyDeBruijn, - fakeNameDeBruijn, - fakeTyNameDeBruijn, - nameToDeBruijn, - tyNameToDeBruijn, - deBruijnToName, - deBruijnToTyName, - freeIndexThrow, - freeIndexAsConsistentLevel, - freeUniqueThrow, - runDeBruijnT, - deBruijnInitIndex, - toFake, - fromFake, -) where + , FakeNamedDeBruijn (..) + , TyDeBruijn (..) + , NamedTyDeBruijn (..) + , FreeVariableError (..) + , AsFreeVariableError (..) + , Level (..) + , LevelInfo (..) + , declareUnique + , declareBinder + , withScope + , getIndex + , getUnique + , unNameDeBruijn + , unNameTyDeBruijn + , fakeNameDeBruijn + , fakeTyNameDeBruijn + , nameToDeBruijn + , tyNameToDeBruijn + , deBruijnToName + , deBruijnToTyName + , freeIndexThrow + , freeIndexAsConsistentLevel + , freeUniqueThrow + , runDeBruijnT + , deBruijnInitIndex + , toFake + , fromFake + ) where import PlutusCore.Name.Unique import PlutusCore.Pretty @@ -95,7 +95,7 @@ the optimized `Flat DeBruijn` instance. This is ok, because `FND<->D` are isomorphic. -} -{-| A relative index used for de Bruijn identifiers. +{- | A relative index used for de Bruijn identifiers. FIXME: downside of using newtype+Num instead of type-synonym is that `-Woverflowed-literals` does not work, e.g.: `DeBruijn (-1)` has no warning. To trigger the warning you have to bypass @@ -116,14 +116,14 @@ data NamedDeBruijn = NamedDeBruijn {ndbnString :: !T.Text, ndbnIndex :: !Index} deriving stock (Show, Generic, Read) deriving anyclass (Hashable, NFData) -{-| A wrapper around `NamedDeBruijn` that *must* hold the invariant of name=`fakeName`. +{- | A wrapper around `NamedDeBruijn` that *must* hold the invariant of name=`fakeName`. We do not export the `FakeNamedDeBruijn` constructor: the projection `FND->ND` is safe but injection `ND->FND` is unsafe, thus they are not isomorphic. See Note [Why newtype FakeNamedDeBruijn] -} -newtype FakeNamedDeBruijn = FakeNamedDeBruijn { unFakeNamedDeBruijn :: NamedDeBruijn } +newtype FakeNamedDeBruijn = FakeNamedDeBruijn {unFakeNamedDeBruijn :: NamedDeBruijn} deriving newtype (Show, Eq, Hashable, NFData, PrettyBy config) toFake :: DeBruijn -> FakeNamedDeBruijn @@ -164,15 +164,14 @@ instance Wrapped TyDeBruijn instance (HasPrettyConfigName config) => PrettyBy config NamedDeBruijn where prettyBy config (NamedDeBruijn txt (Index ix)) - -- See Note [Pretty-printing names with uniques] - | showsUnique = pretty . toPrintedName $ txt <> "_i" <> render (pretty ix) + | showsUnique = pretty $ toPrintedName txt <> "!" <> render (pretty ix) | otherwise = pretty $ toPrintedName txt where PrettyConfigName showsUnique = toPrettyConfigName config instance (HasPrettyConfigName config) => PrettyBy config DeBruijn where prettyBy config (DeBruijn (Index ix)) - | showsUnique = "i" <> pretty ix + | showsUnique = "!" <> pretty ix | otherwise = "" where PrettyConfigName showsUnique = toPrettyConfigName config @@ -304,12 +303,12 @@ getUnique ix h = do -- (absolute) level. h ix -unNameDeBruijn :: - NamedDeBruijn -> DeBruijn +unNameDeBruijn + :: NamedDeBruijn -> DeBruijn unNameDeBruijn (NamedDeBruijn _ ix) = DeBruijn ix -unNameTyDeBruijn :: - NamedTyDeBruijn -> TyDeBruijn +unNameTyDeBruijn + :: NamedTyDeBruijn -> TyDeBruijn unNameTyDeBruijn (NamedTyDeBruijn db) = TyDeBruijn $ unNameDeBruijn db fakeNameDeBruijn :: DeBruijn -> NamedDeBruijn @@ -318,32 +317,32 @@ fakeNameDeBruijn = coerce . toFake fakeTyNameDeBruijn :: TyDeBruijn -> NamedTyDeBruijn fakeTyNameDeBruijn (TyDeBruijn n) = NamedTyDeBruijn $ fakeNameDeBruijn n -nameToDeBruijn :: - (MonadReader LevelInfo m) => - (Unique -> m Index) -> - Name -> - m NamedDeBruijn +nameToDeBruijn + :: (MonadReader LevelInfo m) + => (Unique -> m Index) + -> Name + -> m NamedDeBruijn nameToDeBruijn h (Name str u) = NamedDeBruijn str <$> getIndex u h -tyNameToDeBruijn :: - (MonadReader LevelInfo m) => - (Unique -> m Index) -> - TyName -> - m NamedTyDeBruijn +tyNameToDeBruijn + :: (MonadReader LevelInfo m) + => (Unique -> m Index) + -> TyName + -> m NamedTyDeBruijn tyNameToDeBruijn h (TyName n) = NamedTyDeBruijn <$> nameToDeBruijn h n -deBruijnToName :: - (MonadReader LevelInfo m) => - (Index -> m Unique) -> - NamedDeBruijn -> - m Name +deBruijnToName + :: (MonadReader LevelInfo m) + => (Index -> m Unique) + -> NamedDeBruijn + -> m Name deBruijnToName h (NamedDeBruijn str ix) = Name str <$> getUnique ix h -deBruijnToTyName :: - (MonadReader LevelInfo m) => - (Index -> m Unique) -> - NamedTyDeBruijn -> - m TyName +deBruijnToTyName + :: (MonadReader LevelInfo m) + => (Index -> m Unique) + -> NamedTyDeBruijn + -> m TyName deBruijnToTyName h (NamedTyDeBruijn n) = TyName <$> deBruijnToName h n -- | The default handler of throwing an error upon encountering a free name (unique). @@ -362,10 +361,10 @@ These generated uniques remain free; i.e. if the original term was open, it wil after applying this handler. These generated free uniques are consistent across the open term (by using a state cache). -} -freeIndexAsConsistentLevel :: - (MonadReader LevelInfo m, MonadState (M.Map Level Unique) m, MonadQuote m) => - Index -> - m Unique +freeIndexAsConsistentLevel + :: (MonadReader LevelInfo m, MonadState (M.Map Level Unique) m, MonadQuote m) + => Index + -> m Unique freeIndexAsConsistentLevel ix = do cache <- get LevelInfo current _ <- ask diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/ErrorWithCause.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/ErrorWithCause.hs index 32bdc30d797..3ed12d175ab 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/ErrorWithCause.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/ErrorWithCause.hs @@ -48,7 +48,7 @@ instance (PrettyBy config cause, PrettyBy config err) => instance (PrettyPlc cause, PrettyPlc err) => Show (ErrorWithCause err cause) where - show = render . prettyPlcReadableDebug + show = render . prettyPlcReadableSimple deriving anyclass instance (PrettyPlc cause, PrettyPlc err, Typeable cause, Typeable err) => Exception (ErrorWithCause err cause) diff --git a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Result.hs b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Result.hs index d45c768a58e..a0a3163ccc6 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Evaluation/Result.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Evaluation/Result.hs @@ -129,7 +129,7 @@ instance PrettyBy config a => PrettyBy config (EvaluationResult a) where prettyBy _ EvaluationFailure = "Failure" instance PrettyClassic a => Pretty (EvaluationResult a) where - pretty = prettyClassicDef + pretty = prettyClassic -- | Check whether an 'EvaluationResult' is an 'EvaluationSuccess'. isEvaluationSuccess :: EvaluationResult a -> Bool diff --git a/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs b/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs index fc2bcc5809d..d07e721d1b3 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Name/Unique.hs @@ -106,8 +106,7 @@ data Named a = Named instance (HasPrettyConfigName config) => PrettyBy config Name where prettyBy config (Name txt (Unique uniq)) - -- See Note [Pretty-printing names with uniques] - | showsUnique = pretty . toPrintedName $ txt <> "_" <> render (pretty uniq) + | showsUnique = pretty $ toPrintedName txt <> "-" <> render (pretty uniq) | otherwise = pretty $ toPrintedName txt where PrettyConfigName showsUnique = toPrettyConfigName config @@ -182,14 +181,3 @@ instance HasUnique TyName TypeUnique -- | A lens focused on the 'Unique' of a name. theUnique :: (HasUnique name unique) => Lens' name Unique theUnique = unique . coerced - -{- Note [Pretty-printing names with uniques] - -Our parser can't currently parse unqiues properly. As a hacky workaround, when pretty-printing, -we print the uniques as part of the names. That is, if the name proper is @++@ and the -unique is 123, then it is printed as @`++_123`@, rather than @`++`_123@. - -This way, when it is parsed back, the entire @`++_123`@ becomes the name proper. This works: -a program would be alpha-equivalent after being pretty-printed and then parsed back. But we -should still fix this and do it properly. --} diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs index 2beb0485580..419008947ef 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser/Builtin.hs @@ -148,3 +148,7 @@ constant = do Refl <- reoption $ checkStar uni -- Parse the constant of the type represented by the type tag. someValueOf uni <$> constantOf ExpectParensYes uni + +data ExpectParens + = ExpectParensYes + | ExpectParensNo diff --git a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs index d211e97da9e..006b5250ecc 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Parser/ParserCommon.hs @@ -5,20 +5,22 @@ -- | Common functions for parsers of UPLC, PLC, and PIR. module PlutusCore.Parser.ParserCommon where -import Control.Monad (void, when) +import Control.Monad (when) import Control.Monad.Except (MonadError) import Control.Monad.Reader (ReaderT, ask, local, runReaderT) -import Control.Monad.State (MonadState (..), StateT, evalStateT) +import Control.Monad.State (StateT, evalStateT) import Data.Map qualified as M -import Data.Text qualified as T +import Data.Text (Text) import Text.Megaparsec hiding (ParseError, State, parse, some) import Text.Megaparsec.Char (char, space1) import Text.Megaparsec.Char.Lexer qualified as Lex hiding (hexadecimal) +import Control.Monad.State.Class (MonadState, get, put) import PlutusCore.Annotation import PlutusCore.Core.Type import PlutusCore.Error -import PlutusCore.Name.Unique +import PlutusCore.Name.Unique (Name (..), Unique (..), isIdentifierChar, isIdentifierStartingChar, + isQuotedIdentifierChar) import PlutusCore.Quote {- Note [Whitespace invariant] @@ -27,35 +29,17 @@ sure to enclose every 'Parser' that doesn't consume trailing whitespce (e.g. 'ta 'manyTill', 'Lex.decimal' etc) in a call to 'lexeme'. -} -newtype ParserState = ParserState {identifiers :: M.Map T.Text Unique} +newtype ParserState = ParserState {identifiers :: M.Map Text Unique} deriving stock (Show) type Parser = - ParsecT ParserError T.Text (StateT ParserState (ReaderT (Maybe Version) Quote)) + ParsecT ParserError Text (StateT ParserState (ReaderT (Maybe Version) Quote)) instance (Stream s, MonadQuote m) => MonadQuote (ParsecT e s m) initial :: ParserState initial = ParserState M.empty -{- | Return the unique identifier of a name. -If it's not in the current parser state, map the name to a fresh id -and add it to the state. Used in the Name parser. --} -intern :: - (MonadState ParserState m, MonadQuote m) => - T.Text -> - m Unique -intern n = do - st <- get - case M.lookup n (identifiers st) of - Just u -> return u - Nothing -> do - fresh <- freshUnique - let identifiers' = M.insert n fresh $ identifiers st - put $ ParserState identifiers' - return fresh - -- | Get the version of the program being parsed, if we know it. getVersion :: Parser (Maybe Version) getVersion = ask @@ -75,22 +59,22 @@ whenVersion p act = do Nothing -> pure () Just v -> when (p v) act -parse :: - (AsParserErrorBundle e, MonadError e m, MonadQuote m) => - Parser a -> - String -> - T.Text -> - m a +parse + :: (AsParserErrorBundle e, MonadError e m, MonadQuote m) + => Parser a + -> String + -> Text + -> m a parse p file str = do let res = fmap toErrorB (runReaderT (evalStateT (runParserT p file str) initial) Nothing) throwingEither _ParserErrorBundle =<< liftQuote res -toErrorB :: Either (ParseErrorBundle T.Text ParserError) a -> Either ParserErrorBundle a +toErrorB :: Either (ParseErrorBundle Text ParserError) a -> Either ParserErrorBundle a toErrorB (Left err) = Left $ ParseErrorB err toErrorB (Right a) = Right a -- | Generic parser function in which the file path is just "test". -parseGen :: (AsParserErrorBundle e, MonadError e m, MonadQuote m) => Parser a -> T.Text -> m a +parseGen :: (AsParserErrorBundle e, MonadError e m, MonadQuote m) => Parser a -> Text -> m a parseGen stuff = parse stuff "test" -- | Space consumer. @@ -128,7 +112,7 @@ withSpan = (<* whitespace) . withSpan' lexeme :: Parser a -> Parser a lexeme = Lex.lexeme whitespace -symbol :: T.Text -> Parser T.Text +symbol :: Text -> Parser Text symbol = Lex.symbol whitespace inParens :: Parser a -> Parser a @@ -153,26 +137,43 @@ toSrcSpan start end = version :: Parser Version version = trailingWhitespace $ do x <- Lex.decimal - void $ char '.' + _ <- char '.' y <- Lex.decimal - void $ char '.' + _ <- char '.' Version x y <$> Lex.decimal -- | Parses a `Name`. Does not consume leading or trailing whitespaces. name :: Parser Name name = try $ parseUnquoted <|> parseQuoted where + parseUnquoted :: Parser Name parseUnquoted = do - void $ lookAhead (satisfy isIdentifierStartingChar) + _ <- lookAhead (satisfy isIdentifierStartingChar) str <- takeWhileP (Just "identifier-unquoted") isIdentifierChar - Name str <$> intern str + Name str <$> uniqueSuffix str + + parseQuoted :: Parser Name parseQuoted = do - void $ char '`' - void $ lookAhead (satisfy isQuotedIdentifierChar) + _ <- char '`' + _ <- lookAhead (satisfy isQuotedIdentifierChar) str <- takeWhileP (Just "identifier-quoted") isQuotedIdentifierChar - void $ char '`' - Name str <$> intern str - -data ExpectParens - = ExpectParensYes - | ExpectParensNo + _ <- char '`' + Name str <$> uniqueSuffix str + + -- Tries to parse a `Unique` value. + -- If it fails then looks up the `Unique` value for the given name. + -- If lookup fails too then generates a fresh `Unique` value. + uniqueSuffix :: Text -> Parser Unique + uniqueSuffix nameStr = try (Unique <$> (char '-' *> Lex.decimal)) <|> uniqueForName nameStr + + -- Return the unique identifier of a name. + -- If it's not in the current parser state, map the name to a fresh id and add it to the state. + uniqueForName :: (MonadState ParserState m, MonadQuote m) => Text -> m Unique + uniqueForName nameStr = do + parserState <- get + case M.lookup nameStr (identifiers parserState) of + Just u -> pure u + Nothing -> do + fresh <- freshUnique + put $ ParserState $ M.insert nameStr fresh $ identifiers parserState + pure fresh diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty.hs index 05b594fb866..536c9d8426f 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty.hs @@ -12,10 +12,10 @@ module PlutusCore.Pretty , displayBy , juxtRenderContext -- * Defaults - , prettyPlcDef - , displayPlcDef - , prettyPlcDebug - , displayPlcDebug + , prettyPlc + , displayPlc + , prettyPlcSimple + , displayPlcSimple -- * Global configuration , CondensedErrors (..) , DefaultPrettyPlcStrategy @@ -23,30 +23,30 @@ module PlutusCore.Pretty , PrettyConfigPlcStrategy (..) , PrettyConfigPlc (..) , PrettyPlc - , defPrettyConfigPlcOptions - , defPrettyConfigPlcClassic - , debugPrettyConfigPlcClassic - , defPrettyConfigPlcReadable - , debugPrettyConfigPlcReadable + , prettyConfigPlcOptions + , prettyConfigPlcClassic + , prettyConfigPlcClassicSimple + , prettyConfigPlcReadable + , prettyConfigPlcReadableSimple -- * Custom functions for PLC types. - , prettyPlcClassicDef - , prettyPlcClassicDebug - , prettyPlcReadableDef - , prettyPlcReadableDebug + , prettyPlcClassic + , prettyPlcClassicSimple + , prettyPlcReadable + , prettyPlcReadableSimple , prettyPlcCondensedErrorBy , displayPlcCondensedErrorClassic -- * Names , PrettyConfigName (..) , HasPrettyConfigName (..) - , defPrettyConfigName - , debugPrettyConfigName + , prettyConfigName + , prettyConfigNameSimple -- * Classic view , PrettyConfigClassic (..) , PrettyClassicBy , PrettyClassic , consAnnIf - , prettyClassicDef - , prettyClassicDebug + , prettyClassic + , prettyClassicSimple -- * Readable view , ShowKinds (..) , PrettyConfigReadable (..) diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/Classic.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/Classic.hs index d5983f04190..98f97a24df7 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/Classic.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/Classic.hs @@ -12,10 +12,10 @@ module PlutusCore.Pretty.Classic , PrettyParens , juxtRenderContext , consAnnIf - , defPrettyConfigClassic - , debugPrettyConfigClassic - , prettyClassicDef - , prettyClassicDebug + , prettyConfigClassic + , prettyConfigClassicSimple + , prettyClassic + , prettyClassicSimple ) where import PlutusPrelude @@ -30,6 +30,7 @@ data PrettyConfigClassic configName = PrettyConfigClassic { _pccConfigName :: configName -- ^ How to pretty-print names. , _pccDisplayAnn :: Bool -- ^ Whether to display annotations. } + deriving stock (Show) type instance HasPrettyDefaults (PrettyConfigClassic _) = 'True @@ -50,16 +51,16 @@ isEmptyDoc _ = False consAnnIf :: Pretty ann => PrettyConfigClassic configName -> ann -> [Doc dann] -> [Doc dann] consAnnIf config ann rest = filter (not . isEmptyDoc) [pretty ann | _pccDisplayAnn config] ++ rest -defPrettyConfigClassic :: PrettyConfigClassic PrettyConfigName -defPrettyConfigClassic = PrettyConfigClassic defPrettyConfigName False +prettyConfigClassic :: PrettyConfigClassic PrettyConfigName +prettyConfigClassic = PrettyConfigClassic prettyConfigName False -debugPrettyConfigClassic :: PrettyConfigClassic PrettyConfigName -debugPrettyConfigClassic = PrettyConfigClassic debugPrettyConfigName False +prettyConfigClassicSimple :: PrettyConfigClassic PrettyConfigName +prettyConfigClassicSimple = PrettyConfigClassic prettyConfigNameSimple False -- | Pretty-print a value in the default mode using the classic view. -prettyClassicDef :: PrettyClassic a => a -> Doc ann -prettyClassicDef = prettyBy defPrettyConfigClassic +prettyClassic :: PrettyClassic a => a -> Doc ann +prettyClassic = prettyBy prettyConfigClassic --- | Pretty-print a value in the debug mode using the classic view. -prettyClassicDebug :: PrettyClassic a => a -> Doc ann -prettyClassicDebug = prettyBy debugPrettyConfigClassic +-- | Pretty-print a value in the simple mode using the classic view. +prettyClassicSimple :: PrettyClassic a => a -> Doc ann +prettyClassicSimple = prettyBy prettyConfigClassicSimple diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/ConfigName.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/ConfigName.hs index fd8afcdadda..7d248459d18 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/ConfigName.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/ConfigName.hs @@ -1,126 +1,39 @@ --- editorconfig-checker-disable-file {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} -module PlutusCore.Pretty.ConfigName - ( PrettyConfigName (..) - , HasPrettyConfigName (..) - , defPrettyConfigName - , debugPrettyConfigName - ) where - -import Data.Coerce -import Text.PrettyBy -import Text.PrettyBy.Fixity - -{- Note [PLC names pretty-printing] -UPDATE: We no longer have such fancy names that this note describes. -However it's still nice to have a working boileplate-free solution for sophisticated cases. - -There are several possible designs on how to pretty-print PLC names. We choose the simplest one -which leads to less boilerplate on the implementation side and more concise API. The trade-off is -that it's completely inextensible and the pretty-printer configuration for PLC names is hardcoded -to 'PrettyConfigName'. Originally I tried to do a clever thing and allow different pretty-printer -configs for PLC names, but it turned out to be very complicated and the API would make users unhappy. -We may try to improve the current design later, but for now it works fine. - -Here is how the current design is motivated: - -Consider the 'PrettyConfigClassic' class - - newtype PrettyConfigClassic configName = PrettyConfigClassic - { _pccConfigName :: configName - } - -(which only specifies how to print a PLC name) and this hypothethical instance: - - instance PrettyBy configName (tyname a) => - PrettyBy (PrettyConfigClassic configName) (Type tyname a) - -which determines how to pretty-print a 'Type' provided you know how to pretty-print a @tyname a@ -by a 'configName'. "Makes sense" you might think, but our names are tricky: - - newtype TyNameWithKind a = TyNameWithKind { unTyNameWithKind :: TyName (a, Kind a) } - -Here in order to pretty-print a 'TyNameWithKind', 'configName' must specify how to pretty-print -a 'Kind'. And there are at least two strategies to pretty-print a 'Kind': 'Classic' and 'Refined'. -I.e. 'configName' must specify not only a 'PrettyConfigName', but also a strategy to -pretty-print any PLC entity because this can be required in order to pretty-print a name. -Things become worse with - - type RenamedTerm a = Term TyNameWithKind NameWithType a - newtype NameWithType a = NameWithType (Name (a, RenamedType a)) -because in order to pretty-print a 'RenamedTerm' you have to provide a config that specifies -a pretty-printing strategy for 'Term' and has such 'configName' inside that specifies -a pretty-printing strategy for 'RenamedType' (because it's required in order to pretty-print -'NameWithType') which has a 'configName' that specifies a pretty-printing strategy for 'Kind' -(because it's required in order to pretty-print 'TyNameWithKind'). This is either a hell at the -type-level (completely unbearable) or a circular config at the term level which says -"whatever your level of nestedness is, I'm able to handle that". -That latter thing would look like - - data PrettyConfigPlcLoop - = PrettyConfigPlcLoopClassic (PrettyConfigClassic PrettyConfigPlc) - | PrettyConfigPlcLoopRefined (PrettyConfigRefined PrettyConfigPlc) - - data PrettyConfigPlc = PrettyConfigPlc - { _prettyConfigPlcName :: PrettyConfigName - , _prettyConfigPlcLoop :: PrettyConfigPlcLoop - } - -i.e. there is a 'PrettyConfigName' at the current level, but you can descend further and there -will be a a 'PrettyConfigName' as well. While this might work, we're not in the Inception movie -and hence we define - - instance PrettyBy (PrettyConfigClassic configName) (tyname a) => - PrettyBy (PrettyConfigClassic configName) (Type tyname a) - -i.e. require that a @tyname a@ must be pretty-printable with the same config as an entire 'Type'. - -... and immediately run into the O(n * m) number of instances problem: - - [Classic, Refined] x [Name, TyName, NameWithType, TyNameWithKind] - -where @[Classic, Refined]@ are pretty-printing strategies (we can add more in future) and -@[Name, TyName, NameWithType, TyNameWithKind]@ are PLC names (we will likely add more in future). -We do not need this level of extensibility (pretty-printing names differently depending on a -pretty-printing strategy used), so we do the following twist: for any pretty-printing strategy -we require that it must contain a PLC names pretty-printing config and then define a single instance -for each of the PLC names. E.g. for 'Name' it looks like this: - - instance HasPrettyConfigName config => PrettyBy config (Name ann) where - -i.e. "you can pretty-print a 'Name' using any config as long as a 'PrettyConfigName' can be -extracted from it". This results in O(n + m) number of instances, with 'HasPrettyConfigName' -instances being defined like - - instance configName ~ PrettyConfigName => HasPrettyConfigName (PrettyConfigClassic configName) where - toPrettyConfigName = _pccConfigName +module PlutusCore.Pretty.ConfigName + ( PrettyConfigName (..) + , HasPrettyConfigName (..) + , prettyConfigName + , prettyConfigNameSimple + ) where -Here we also hardcode the PLC names pretty-printing config to be 'PrettyConfigName' which sometimes -contains redundant information (e.g. to pretty-print a 'Name' the '_pcnShowsAttached' field is not -required). This is something that we may try to improve later. --} +import Data.Coerce (coerce) +import Text.PrettyBy (HasPrettyDefaults) +import Text.PrettyBy.Fixity (Sole (Sole)) -- | A config that determines how to pretty-print a PLC name. newtype PrettyConfigName = PrettyConfigName - { _pcnShowsUnique :: Bool -- ^ Whether to show the 'Unique' of a name or not. - } + { _pcnShowsUnique :: Bool + -- ^ Whether to show the 'Unique' of a name or not. + } + deriving stock (Eq, Show) type instance HasPrettyDefaults PrettyConfigName = 'True -- | A class of configs from which a 'PrettyConfigName' can be extracted. class HasPrettyConfigName config where - toPrettyConfigName :: config -> PrettyConfigName + toPrettyConfigName :: config -> PrettyConfigName instance HasPrettyConfigName (Sole PrettyConfigName) where - toPrettyConfigName = coerce + toPrettyConfigName = coerce + +-- | The 'PrettyConfigName' used by default: print 'Unique' indexes after nams. +prettyConfigName :: PrettyConfigName +prettyConfigName = PrettyConfigName{_pcnShowsUnique = True} --- | The 'PrettyConfigName' used by default: don't print 'Unique's. -defPrettyConfigName :: PrettyConfigName -defPrettyConfigName = PrettyConfigName False +-- | The 'PrettyConfigName' to be used when 'Unique' indices don't matter. Easier to read. +prettyConfigNameSimple :: PrettyConfigName +prettyConfigNameSimple = PrettyConfigName{_pcnShowsUnique = False} --- | The 'PrettyConfigName' used for debugging: print 'Unique's. -debugPrettyConfigName :: PrettyConfigName -debugPrettyConfigName = PrettyConfigName True diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/Default.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/Default.hs index 9baab6a44e5..f4fc8eee15c 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/Default.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/Default.hs @@ -1,8 +1,8 @@ module PlutusCore.Pretty.Default - ( prettyPlcDef - , displayPlcDef - , prettyPlcDebug - , displayPlcDebug + ( prettyPlc + , displayPlc + , prettyPlcSimple + , displayPlcSimple , displayPlcCondensedErrorClassic ) where @@ -11,22 +11,22 @@ import PlutusPrelude import PlutusCore.Pretty.Plc -- | Pretty-print a value in the default mode using the classic view. -prettyPlcDef :: PrettyPlc a => a -> Doc ann -prettyPlcDef = prettyPlcClassicDef +prettyPlc :: PrettyPlc a => a -> Doc ann +prettyPlc = prettyPlcClassic -- | Render a value to 'String' in the default mode using the classic view. -displayPlcDef :: (PrettyPlc a, Render str) => a -> str -displayPlcDef = render . prettyPlcClassicDef +displayPlc :: (PrettyPlc a, Render str) => a -> str +displayPlc = render . prettyPlcClassic -- | Pretty-print a value in the debug mode using the classic view. -prettyPlcDebug :: PrettyPlc a => a -> Doc ann -prettyPlcDebug = prettyPlcClassicDebug +prettyPlcSimple :: PrettyPlc a => a -> Doc ann +prettyPlcSimple = prettyPlcClassicSimple -- | Render a value to 'String' in the debug mode using the classic view. -displayPlcDebug :: (PrettyPlc a, Render str) => a -> str -displayPlcDebug = render . prettyPlcClassicDebug +displayPlcSimple :: (PrettyPlc a, Render str) => a -> str +displayPlcSimple = render . prettyPlcClassicSimple -- | Render an error to 'String' in the condensed manner using the classic view. displayPlcCondensedErrorClassic :: (PrettyPlc a, Render str) => a -> str displayPlcCondensedErrorClassic = - render . prettyPlcCondensedErrorBy defPrettyConfigPlcClassic + render . prettyPlcCondensedErrorBy prettyConfigPlcClassic diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/Plc.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/Plc.hs index 32261f16901..652ad7ef0c3 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/Plc.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/Plc.hs @@ -17,16 +17,16 @@ module PlutusCore.Pretty.Plc , PrettyConfigPlc (..) , PrettyPlc , DefaultPrettyPlcStrategy - , defPrettyConfigPlcOptions - , defPrettyConfigPlcClassic - , debugPrettyConfigPlcClassic - , defPrettyConfigPlcReadable - , debugPrettyConfigPlcReadable + , prettyConfigPlcOptions + , prettyConfigPlcClassic + , prettyConfigPlcClassicSimple + , prettyConfigPlcReadable + , prettyConfigPlcReadableSimple -- * Custom functions for PLC types. - , prettyPlcClassicDef - , prettyPlcClassicDebug - , prettyPlcReadableDef - , prettyPlcReadableDebug + , prettyPlcClassic + , prettyPlcClassicSimple + , prettyPlcReadable + , prettyPlcReadableSimple , prettyPlcCondensedErrorBy ) where @@ -46,17 +46,20 @@ data CondensedErrors newtype PrettyConfigPlcOptions = PrettyConfigPlcOptions { _pcpoCondensedErrors :: CondensedErrors } + deriving stock (Show) -- | Strategy for pretty-printing PLC entities. data PrettyConfigPlcStrategy = PrettyConfigPlcClassic (PrettyConfigClassic PrettyConfigName) | PrettyConfigPlcReadable (PrettyConfigReadable PrettyConfigName) + deriving stock (Show) -- | Global configuration used for pretty-printing PLC entities. data PrettyConfigPlc = PrettyConfigPlc { _pcpOptions :: PrettyConfigPlcOptions , _pcpStrategy :: PrettyConfigPlcStrategy } + deriving stock (Show) type instance HasPrettyDefaults PrettyConfigPlc = 'True @@ -85,50 +88,50 @@ instance DefaultPrettyPlcStrategy a => PrettyBy PrettyConfigPlc (PrettyAny a) wh -- | The 'PrettyConfigPlcOptions' used by default: -- print errors in full. -defPrettyConfigPlcOptions :: PrettyConfigPlcOptions -defPrettyConfigPlcOptions = PrettyConfigPlcOptions CondensedErrorsNo +prettyConfigPlcOptions :: PrettyConfigPlcOptions +prettyConfigPlcOptions = PrettyConfigPlcOptions CondensedErrorsNo -- | The 'PrettyConfigPlc' used by default: -- use the classic view and print neither 'Unique's, nor name attachments. -defPrettyConfigPlcClassic :: PrettyConfigPlcOptions -> PrettyConfigPlc -defPrettyConfigPlcClassic opts = - PrettyConfigPlc opts $ PrettyConfigPlcClassic defPrettyConfigClassic +prettyConfigPlcClassic :: PrettyConfigPlcOptions -> PrettyConfigPlc +prettyConfigPlcClassic opts = + PrettyConfigPlc opts $ PrettyConfigPlcClassic prettyConfigClassic -- | The 'PrettyConfigPlc' used for debugging: -- use the classic view and print 'Unique's, but not name attachments. -debugPrettyConfigPlcClassic :: PrettyConfigPlcOptions -> PrettyConfigPlc -debugPrettyConfigPlcClassic opts = - PrettyConfigPlc opts $ PrettyConfigPlcClassic debugPrettyConfigClassic +prettyConfigPlcClassicSimple :: PrettyConfigPlcOptions -> PrettyConfigPlc +prettyConfigPlcClassicSimple opts = + PrettyConfigPlc opts $ PrettyConfigPlcClassic prettyConfigClassicSimple -- | The 'PrettyConfigPlc' used by default and for readability: --- use the refined view and print neither 'Unique's, nor name attachments. -defPrettyConfigPlcReadable :: PrettyConfigPlcOptions -> PrettyConfigPlc -defPrettyConfigPlcReadable opts = +-- use the refined view and print 'Unique's but not name attachments. +prettyConfigPlcReadable :: PrettyConfigPlcOptions -> PrettyConfigPlc +prettyConfigPlcReadable opts = PrettyConfigPlc opts . PrettyConfigPlcReadable $ - topPrettyConfigReadable defPrettyConfigName def + topPrettyConfigReadable prettyConfigName def -- | The 'PrettyConfigPlc' used for debugging and readability: --- use the refined view and print 'Unique's, but not name attachments. -debugPrettyConfigPlcReadable :: PrettyConfigPlcOptions -> PrettyConfigPlc -debugPrettyConfigPlcReadable opts = +-- use the refined view and print neither 'Unique's nor name attachments. +prettyConfigPlcReadableSimple :: PrettyConfigPlcOptions -> PrettyConfigPlc +prettyConfigPlcReadableSimple opts = PrettyConfigPlc opts . PrettyConfigPlcReadable $ - topPrettyConfigReadable debugPrettyConfigName def + topPrettyConfigReadable prettyConfigNameSimple def -- | Pretty-print a PLC value in the default mode using the classic view. -prettyPlcClassicDef :: PrettyPlc a => a -> Doc ann -prettyPlcClassicDef = prettyBy $ defPrettyConfigPlcClassic defPrettyConfigPlcOptions +prettyPlcClassic :: PrettyPlc a => a -> Doc ann +prettyPlcClassic = prettyBy $ prettyConfigPlcClassic prettyConfigPlcOptions --- | Pretty-print a PLC value in the debug mode using the classic view. -prettyPlcClassicDebug :: PrettyPlc a => a -> Doc ann -prettyPlcClassicDebug = prettyBy $ debugPrettyConfigPlcClassic defPrettyConfigPlcOptions +-- | Pretty-print a PLC value witout unique indices using the classic view. +prettyPlcClassicSimple :: PrettyPlc a => a -> Doc ann +prettyPlcClassicSimple = prettyBy $ prettyConfigPlcClassicSimple prettyConfigPlcOptions -- | Pretty-print a PLC value in the default mode using the readable view. -prettyPlcReadableDef :: PrettyPlc a => a -> Doc ann -prettyPlcReadableDef = prettyBy $ defPrettyConfigPlcReadable defPrettyConfigPlcOptions +prettyPlcReadable :: PrettyPlc a => a -> Doc ann +prettyPlcReadable = prettyBy $ prettyConfigPlcReadable prettyConfigPlcOptions --- | Pretty-print a PLC value in the debug mode using the readable view. -prettyPlcReadableDebug :: PrettyPlc a => a -> Doc ann -prettyPlcReadableDebug = prettyBy $ debugPrettyConfigPlcReadable defPrettyConfigPlcOptions +-- | Pretty-print a PLC value witout unique indices using the readable view. +prettyPlcReadableSimple :: PrettyPlc a => a -> Doc ann +prettyPlcReadableSimple = prettyBy $ prettyConfigPlcReadableSimple prettyConfigPlcOptions -- | Pretty-print a PLC value using the condensed way (see 'CondensedErrors') -- of pretty-printing PLC errors (in case there are any). diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/Readable.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/Readable.hs index b6bbbddeef2..247f3e8da2b 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/Readable.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/Readable.hs @@ -43,6 +43,7 @@ data PrettyConfigReadable configName = PrettyConfigReadable , _pcrRenderContext :: RenderContext , _pcrShowKinds :: ShowKinds } + deriving stock (Show) type instance HasPrettyDefaults (PrettyConfigReadable _) = 'True @@ -70,7 +71,7 @@ instance HasRenderContext (PrettyConfigReadable configName) where renderContext = pcrRenderContext {- | For rendering things in a readable manner regardless of the pretty-printing function chosen. -I.e. all of 'show', 'pretty', 'prettyClassicDef' will use 'PrettyReadable' instead of doing what +I.e. all of 'show', 'pretty', 'prettyClassic' will use 'PrettyReadable' instead of doing what they normally do. @prettyBy config (AsReadable x)@ requires @config@ to have a 'PrettyConfigName' and respects it. @@ -90,7 +91,7 @@ instance prettyBy (botPrettyConfigReadable (toPrettyConfigName config) def) x instance (PrettyReadable a) => Show (AsReadable a) where - show = displayBy $ Sole defPrettyConfigName + show = displayBy $ Sole prettyConfigName instance (PrettyReadable a) => Pretty (AsReadable a) where pretty = viaShow diff --git a/plutus-core/plutus-core/src/PlutusCore/Pretty/Utils.hs b/plutus-core/plutus-core/src/PlutusCore/Pretty/Utils.hs index 1a4d399b86b..e8eef31ea35 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Pretty/Utils.hs +++ b/plutus-core/plutus-core/src/PlutusCore/Pretty/Utils.hs @@ -19,4 +19,4 @@ asBytes x = Text 2 $ T.pack $ addLeadingZero $ showHex x mempty | otherwise = id prettyBytes :: BS.ByteString -> Doc ann -prettyBytes b = "#" <> fold (asBytes <$> BS.unpack b) +prettyBytes b = "#" <> foldMap asBytes (BS.unpack b) diff --git a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Type.hs b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Type.hs index 31f30942feb..bcff55db06c 100644 --- a/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Type.hs +++ b/plutus-core/plutus-core/stdlib/PlutusCore/StdLib/Type.hs @@ -510,7 +510,7 @@ instance Show IndicesLengthsMismatchException where show (IndicesLengthsMismatchException expected actual tyName) = concat [ "Wrong number of elements\n" , "expected: ", show expected, " , actual: ", show actual, "\n" - , "while constructing a ", displayPlcDef tyName + , "while constructing a ", displayPlc tyName ] -- | Get the kind of a data type having the kinds of its arguments. diff --git a/plutus-core/plutus-core/test/Names/Spec.hs b/plutus-core/plutus-core/test/Names/Spec.hs index d275a048c41..0bca667e5ec 100644 --- a/plutus-core/plutus-core/test/Names/Spec.hs +++ b/plutus-core/plutus-core/test/Names/Spec.hs @@ -20,7 +20,7 @@ import PlutusCore.Generators.Hedgehog.AST as AST (genName, genProgram, genTerm, import PlutusCore.Generators.Hedgehog.Interesting (fromInterestingTermGens) import PlutusCore.Mark (markNonFreshProgram) import PlutusCore.Parser qualified as Parser -import PlutusCore.Pretty (displayPlcDebug, pretty, render) +import PlutusCore.Pretty (display, displayPlcSimple) import PlutusCore.Rename.Internal (renameProgramM) import PlutusCore.Test (BindingRemoval (BindingRemovalNotOk), Prerename (PrerenameNo), brokenRename, checkFails, noMarkRename, test_scopingGood, test_scopingSpoilRenamer) @@ -133,9 +133,9 @@ test_rebindShadowedVariable = testCase "rebindShadowedVariable" do err = concat - [ displayPlcDebug l2 + [ displayPlcSimple l2 , " and " - , displayPlcDebug r2 + , displayPlcSimple r2 , " are supposed not to be equal, but they are equal" ] @@ -191,13 +191,10 @@ test_printing_parsing_roundtrip = prop_printing_parsing_roundtrip :: Property prop_printing_parsing_roundtrip = property $ generalizeT do name <- forAllPretty $ runAstGen genName - tripping name printName parseName + tripping name display parse where - printName :: Name -> String - printName = render . pretty - - parseName :: String -> Either (PlutusCore.Error DefaultUni DefaultFun ()) Name - parseName str = runQuoteT do + parse :: String -> Either (PlutusCore.Error DefaultUni DefaultFun ()) Name + parse str = runQuoteT do Parser.parse Parser.name "test_printing_parsing_roundtrip" (Text.pack str) test_names :: TestTree diff --git a/plutus-core/plutus-core/test/Pretty/Readable.hs b/plutus-core/plutus-core/test/Pretty/Readable.hs index a346e264b71..3cf2ef8cd69 100644 --- a/plutus-core/plutus-core/test/Pretty/Readable.hs +++ b/plutus-core/plutus-core/test/Pretty/Readable.hs @@ -14,20 +14,21 @@ import Test.Tasty.Extras import Test.Tasty prettyConfigReadable :: PrettyConfigPlc -prettyConfigReadable - = PrettyConfigPlc defPrettyConfigPlcOptions +prettyConfigReadable = + PrettyConfigPlc prettyConfigPlcOptions . PrettyConfigPlcReadable - $ botPrettyConfigReadable defPrettyConfigName def + $ botPrettyConfigReadable prettyConfigNameSimple def -testReadable :: PrettyPlc a => TestName -> a -> TestNested +testReadable :: (PrettyPlc a) => TestName -> a -> TestNested testReadable name = nestedGoldenVsDoc name "" . prettyBy prettyConfigReadable test_PrettyReadable :: TestTree test_PrettyReadable = - testGroup "Bundles" - [ folder stdLib - , folder examples - ] + testGroup + "Bundles" + [ folder stdLib + , folder examples + ] where folder :: Pretty fun => PlcFolderContents DefaultUni fun -> TestTree folder @@ -36,6 +37,7 @@ test_PrettyReadable = test_Pretty :: TestTree test_Pretty = - testGroup "pretty" - [ test_PrettyReadable - ] + testGroup + "pretty" + [ test_PrettyReadable + ] diff --git a/plutus-core/plutus-core/test/Spec.hs b/plutus-core/plutus-core/test/Spec.hs index daf13d8b770..5bfccb91245 100644 --- a/plutus-core/plutus-core/test/Spec.hs +++ b/plutus-core/plutus-core/test/Spec.hs @@ -159,7 +159,7 @@ testLexConstant :: Assertion testLexConstant = for_ smallConsts $ \t -> do let res :: Either ParserErrorBundle (Term TyName Name DefaultUni DefaultFun SrcSpan) - res = runQuoteT $ parseTerm $ displayPlcDef t + res = runQuoteT $ parseTerm $ displayPlc t -- using `void` here to get rid of `SrcSpan` fmap void res @?= Right t where @@ -182,7 +182,7 @@ testLexConstant = genConstantForTest :: AstGen (Some (ValueOf DefaultUni)) genConstantForTest = Gen.frequency - [ (3, someValue <$> pure ()) + [ (3, pure (someValue ())) , (3, someValue <$> Gen.bool) , -- Smallish Integers (5, someValue <$> Gen.integral (Range.linear (-k1) k1)) @@ -211,7 +211,7 @@ genConstantForTest = propLexConstant :: Property propLexConstant = withTests (1000 :: Hedgehog.TestLimit) . property $ do term <- forAllPretty $ Constant () <$> runAstGen genConstantForTest - Hedgehog.tripping term displayPlcDef (fmap void . parseTm) + Hedgehog.tripping term displayPlc (fmap void . parseTm) where parseTm :: T.Text -> @@ -226,7 +226,7 @@ propParser = property $ do prog <- TextualProgram <$> forAllPretty (runAstGen genProgram) Hedgehog.tripping prog - (displayPlcDef . unTextualProgram) + (displayPlc . unTextualProgram) (\p -> fmap (TextualProgram . void) (parseProg p)) where parseProg :: @@ -242,7 +242,7 @@ asIO :: TestFunction -> FilePath -> IO BSL.ByteString asIO f = fmap (either errorgen (BSL.fromStrict . encodeUtf8) . f) . readFile errorgen :: (PrettyPlc a) => a -> BSL.ByteString -errorgen = BSL.fromStrict . encodeUtf8 . displayPlcDef +errorgen = BSL.fromStrict . encodeUtf8 . displayPlcSimple asGolden :: TestFunction -> TestName -> TestTree asGolden f file = goldenVsString file (file ++ ".golden") (asIO f file) @@ -275,7 +275,7 @@ printType :: m T.Text printType txt = runQuoteT $ - T.pack . show . pretty <$> do + render . prettyBy (prettyConfigPlcClassicSimple prettyConfigPlcOptions) <$> do scoped <- parseScoped txt config <- getDefTypeCheckConfig topSrcSpan inferTypeOfProgram config scoped @@ -293,12 +293,12 @@ format cfg = runQuoteT . fmap (displayBy cfg) . (rename <=< parseProgram) testsGolden :: [FilePath] -> TestTree testsGolden = testGroup "golden tests" - . fmap (asGolden (format $ defPrettyConfigPlcClassic defPrettyConfigPlcOptions)) + . fmap (asGolden (format (prettyConfigPlcClassicSimple prettyConfigPlcOptions))) testsRewrite :: [FilePath] -> TestTree testsRewrite = testGroup "golden rewrite tests" - . fmap (asGolden (format $ debugPrettyConfigPlcClassic defPrettyConfigPlcOptions)) + . fmap (asGolden (format (prettyConfigPlcClassic prettyConfigPlcOptions))) tests :: TestTree tests = @@ -311,7 +311,7 @@ tests = where fmt :: T.Text -> Either ParserErrorBundle T.Text fmt = format cfg - cfg = defPrettyConfigPlcClassic defPrettyConfigPlcOptions + cfg = prettyConfigPlcClassicSimple prettyConfigPlcOptions allTests :: [FilePath] -> [FilePath] -> [FilePath] -> [FilePath] -> TestTree allTests plcFiles rwFiles typeFiles typeErrorFiles = diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Spec.hs b/plutus-core/plutus-core/test/TypeSynthesis/Spec.hs index b07512262cc..f9f5794ec4b 100644 --- a/plutus-core/plutus-core/test/TypeSynthesis/Spec.hs +++ b/plutus-core/plutus-core/test/TypeSynthesis/Spec.hs @@ -59,7 +59,8 @@ assertIllTyped semvar term isExpected = case runExcept . runQuoteT $ typecheck s nestedGoldenVsErrorOrThing :: (PrettyPlc e, PrettyReadable a) => String -> Either e a -> TestNested nestedGoldenVsErrorOrThing name = - nestedGoldenVsText name ".plc" . either displayPlcCondensedErrorClassic (display . AsReadable) + nestedGoldenVsText name ".plc" + . either displayPlcCondensedErrorClassic (render . prettyPlcReadableSimple . AsReadable) foldAssertWell :: (ToBuiltinMeaning DefaultUni fun, Pretty fun) @@ -74,10 +75,12 @@ foldAssertWell semvar test_typecheckAvailable :: TestTree test_typecheckAvailable = - testGroup "Available" - [ foldAssertWell def stdLib - , foldAssertWell def examples - ] + let builtinSemanticsVariant :: ToBuiltinMeaning DefaultUni fun => BuiltinSemanticsVariant fun + builtinSemanticsVariant = def + in testGroup "Available" + [ foldAssertWell builtinSemanticsVariant stdLib + , foldAssertWell builtinSemanticsVariant examples + ] -- | Self-application. An example of ill-typed term. -- diff --git a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Error.hs b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Error.hs index 8193ce53c58..6e23e14abe7 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Compiler/Error.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Compiler/Error.hs @@ -31,7 +31,7 @@ instance PLC.AsTypeError (Error uni fun ann) (PLC.Term PLC.TyName PLC.Name uni f _TypeError = _PLCError . PLC._TypeError instance (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty ann) => Show (Error uni fun ann) where - show = show . PLC.prettyPlcClassicDebug + show = show . PLC.prettyPlcClassicSimple instance (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty ann) => PLC.PrettyBy PLC.PrettyConfigPlc (Error uni fun ann) where diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty.hs index e0feee60dfa..0de4ecb6fcd 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty.hs @@ -138,21 +138,21 @@ instance ( PLC.PrettyClassicBy configName tyname instance (PLC.PrettyClassic tyname, Pretty ann) => Pretty (TyVarDecl tyname ann) where - pretty = PLC.prettyClassicDef + pretty = PLC.prettyClassic instance ( PLC.PrettyClassic tyname , PLC.PrettyClassic name , PLC.PrettyParens (PLC.SomeTypeIn uni) , Pretty ann ) => Pretty (VarDecl tyname name uni ann) where - pretty = PLC.prettyClassicDef + pretty = PLC.prettyClassic instance ( PLC.PrettyClassic tyname , PLC.PrettyClassic name , PLC.PrettyUni uni , Pretty ann ) => Pretty (Datatype tyname name uni ann) where - pretty = PLC.prettyClassicDef + pretty = PLC.prettyClassic instance ( PLC.PrettyClassic tyname , PLC.PrettyClassic name @@ -160,7 +160,7 @@ instance ( PLC.PrettyClassic tyname , Pretty fun , Pretty ann ) => Pretty (Binding tyname name uni fun ann) where - pretty = PLC.prettyClassicDef + pretty = PLC.prettyClassic instance ( PLC.PrettyClassic tyname , PLC.PrettyClassic name @@ -168,7 +168,7 @@ instance ( PLC.PrettyClassic tyname , Pretty fun , Pretty ann ) => Pretty (Term tyname name uni fun ann) where - pretty = PLC.prettyClassicDef + pretty = PLC.prettyClassic instance ( PLC.PrettyClassic tyname , PLC.PrettyClassic name @@ -176,7 +176,7 @@ instance ( PLC.PrettyClassic tyname , Pretty fun , Pretty ann ) => Pretty (Program tyname name uni fun ann) where - pretty = PLC.prettyClassicDef + pretty = PLC.prettyClassic deriving via PrettyAny (Term tyname name uni fun ann) diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty/Readable.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty/Readable.hs index bb35473ab45..006aedf37b8 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty/Readable.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Instance/Pretty/Readable.hs @@ -3,15 +3,17 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Eta reduce" #-} -- breaks type inference + module PlutusIR.Core.Instance.Pretty.Readable ( prettyPirReadable + , prettyPirReadableSimple , PrettyPir ) where @@ -27,10 +29,11 @@ type PrettyPir = PrettyBy (PrettyConfigReadable PrettyConfigName) -- | Pretty-print something with the @PrettyConfigReadable@ config. prettyPirReadable :: PrettyPir a => a -> Doc ann -prettyPirReadable = prettyBy prettyConfigReadable - -- Using 'debugPrettyConfigName', because it's actually helpful unlike 'defPrettyConfigName'. - where - prettyConfigReadable = botPrettyConfigReadable debugPrettyConfigName def +prettyPirReadable = prettyBy (topPrettyConfigReadable prettyConfigName def) + +-- | Pretty-print something with the @PrettyConfigReadableSimple@ config. +prettyPirReadableSimple :: PrettyPir a => a -> Doc ann +prettyPirReadableSimple = prettyBy (topPrettyConfigReadable prettyConfigNameSimple def) -- | Split an iterated 'LamAbs' (if any) into a list of variables that it binds and its body. viewLamAbs diff --git a/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs b/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs index 832cc50c6a5..88835d4d6e5 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Core/Type.hs @@ -1,4 +1,3 @@ --- editorconfig-checker-disable-file {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} @@ -7,30 +6,30 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module PlutusIR.Core.Type ( - TyName (..), - Name (..), - VarDecl (..), - TyVarDecl (..), - varDeclNameString, - tyVarDeclNameString, - Kind (..), - Type (..), - Datatype (..), - datatypeNameString, - Recursivity (..), - Strictness (..), - Binding (..), - Term (..), - Program (..), - Version (..), - applyProgram, - termAnn, - bindingAnn, - progAnn, - progVersion, - progTerm, - ) where +module PlutusIR.Core.Type + ( TyName (..) + , Name (..) + , VarDecl (..) + , TyVarDecl (..) + , varDeclNameString + , tyVarDeclNameString + , Kind (..) + , Type (..) + , Datatype (..) + , datatypeNameString + , Recursivity (..) + , Strictness (..) + , Binding (..) + , Term (..) + , Program (..) + , Version (..) + , applyProgram + , termAnn + , bindingAnn + , progAnn + , progVersion + , progTerm + ) where import PlutusCore (Kind, Name, TyName, Type (..), Version (..)) import PlutusCore qualified as PLC @@ -53,8 +52,9 @@ import PlutusCore.Error (ApplyProgramError (MkApplyProgramError)) -- Datatypes -data Datatype tyname name uni a = Datatype a (TyVarDecl tyname a) [TyVarDecl tyname a] name [VarDecl tyname name uni a] - deriving stock (Functor, Show, Generic) +data Datatype tyname name uni a + = Datatype a (TyVarDecl tyname a) [TyVarDecl tyname a] name [VarDecl tyname name uni a] + deriving stock (Functor, Show, Generic) varDeclNameString :: VarDecl tyname Name uni a -> String varDeclNameString = T.unpack . PLC._nameText . _varDeclName @@ -67,31 +67,44 @@ datatypeNameString (Datatype _ tn _ _ _) = tyVarDeclNameString tn -- Bindings --- | Each multi-let-group has to be marked with its scoping: --- * 'NonRec': the identifiers introduced by this multi-let are only linearly-scoped, i.e. an identifier cannot refer to itself or later-introduced identifiers of the group. --- * 'Rec': an identifiers introduced by this multi-let group can use all other multi-lets of the same group (including itself), --- thus permitting (mutual) recursion. +{- | Each multi-let-group has to be marked with its scoping: +* 'NonRec': the identifiers introduced by this multi-let are only linearly-scoped, + i.e. an identifier cannot refer to itself or later-introduced identifiers of the group. +* 'Rec': an identifiers introduced by this multi-let group can use all other multi-lets + of the same group (including itself), thus permitting (mutual) recursion. +-} data Recursivity = NonRec | Rec - deriving stock (Show, Eq, Generic, Ord) - deriving anyclass Hashable + deriving stock (Show, Eq, Generic, Ord) + deriving anyclass (Hashable) --- | Recursivity can form a 'Semigroup' / lattice, where 'NonRec' < 'Rec'. --- The lattice is ordered by "power": a non-recursive binding group can be made recursive and it will still work, but not vice versa. --- The semigroup operation is the "join" of the lattice. +{- | Recursivity can form a 'Semigroup' / lattice, where 'NonRec' < 'Rec'. +The lattice is ordered by "power": a non-recursive binding group can be made recursive +and it will still work, but not vice versa. +The semigroup operation is the "join" of the lattice. +-} instance Semigroup Recursivity where NonRec <> x = x Rec <> _ = Rec data Strictness = NonStrict | Strict - deriving stock (Show, Eq, Generic) - -data Binding tyname name uni fun a = TermBind a Strictness (VarDecl tyname name uni a) (Term tyname name uni fun a) - | TypeBind a (TyVarDecl tyname a) (Type tyname uni a) - | DatatypeBind a (Datatype tyname name uni a) - deriving stock (Functor, Generic) - -deriving stock instance (Show tyname, Show name, GShow uni, Everywhere uni Show, Show fun, Show a, Closed uni) - => Show (Binding tyname name uni fun a) + deriving stock (Show, Eq, Generic) + +data Binding tyname name uni fun a + = TermBind a Strictness (VarDecl tyname name uni a) (Term tyname name uni fun a) + | TypeBind a (TyVarDecl tyname a) (Type tyname uni a) + | DatatypeBind a (Datatype tyname name uni a) + deriving stock (Functor, Generic) + +deriving stock instance + ( Show tyname + , Show name + , Show fun + , Show a + , GShow uni + , Everywhere uni Show + , Closed uni + ) + => Show (Binding tyname name uni fun a) -- Terms @@ -121,104 +134,125 @@ Plutus Core to use reified declarations. -} -- See Note [PIR as a PLC extension] -data Term tyname name uni fun a = - -- Plutus Core (ish) forms, see Note [Declarations in Plutus Core] - Let a Recursivity (NonEmpty (Binding tyname name uni fun a)) (Term tyname name uni fun a) - | Var a name - | TyAbs a tyname (Kind a) (Term tyname name uni fun a) - | LamAbs a name (Type tyname uni a) (Term tyname name uni fun a) - | Apply a (Term tyname name uni fun a) (Term tyname name uni fun a) - | Constant a (PLC.Some (PLC.ValueOf uni)) - | Builtin a fun - | TyInst a (Term tyname name uni fun a) (Type tyname uni a) - | Error a (Type tyname uni a) - | IWrap a (Type tyname uni a) (Type tyname uni a) (Term tyname name uni fun a) - | Unwrap a (Term tyname name uni fun a) - -- See Note [Constr tag type] - | Constr a (Type tyname uni a) Word64 [Term tyname name uni fun a] - | Case a (Type tyname uni a) (Term tyname name uni fun a) [Term tyname name uni fun a] - deriving stock (Functor, Generic) - -deriving stock instance (Show tyname, Show name, GShow uni, Everywhere uni Show, Show fun, Show a, Closed uni) - => Show (Term tyname name uni fun a) +data Term tyname name uni fun a + = -- Plutus Core (ish) forms, see Note [Declarations in Plutus Core] + Let a Recursivity (NonEmpty (Binding tyname name uni fun a)) (Term tyname name uni fun a) + | Var a name + | TyAbs a tyname (Kind a) (Term tyname name uni fun a) + | LamAbs a name (Type tyname uni a) (Term tyname name uni fun a) + | Apply a (Term tyname name uni fun a) (Term tyname name uni fun a) + | Constant a (PLC.Some (PLC.ValueOf uni)) + | Builtin a fun + | TyInst a (Term tyname name uni fun a) (Type tyname uni a) + | Error a (Type tyname uni a) + | IWrap a (Type tyname uni a) (Type tyname uni a) (Term tyname name uni fun a) + | Unwrap a (Term tyname name uni fun a) + | -- See Note [Constr tag type] + Constr a (Type tyname uni a) Word64 [Term tyname name uni fun a] + | Case a (Type tyname uni a) (Term tyname name uni fun a) [Term tyname name uni fun a] + deriving stock (Functor, Generic) + +deriving stock instance + ( Show tyname + , Show name + , GShow uni + , Everywhere uni Show + , Show fun + , Show a + , Closed uni + ) + => Show (Term tyname name uni fun a) -- See Note [ExMemoryUsage instances for non-constants]. instance ExMemoryUsage (Term tyname name uni fun ann) where - memoryUsage = - Prelude.error "Internal error: 'memoryUsage' for IR 'Term' is not supposed to be forced" + memoryUsage = + Prelude.error "Internal error: 'memoryUsage' for IR 'Term' is not supposed to be forced" type instance UniOf (Term tyname name uni fun ann) = uni instance HasConstant (Term tyname name uni fun ()) where - asConstant (Constant _ val) = pure val - asConstant _ = throwNotAConstant + asConstant (Constant _ val) = pure val + asConstant _ = throwNotAConstant - fromConstant = Constant () + fromConstant = Constant () instance TermLike (Term tyname name uni fun) tyname name uni fun where - var = Var - tyAbs = TyAbs - lamAbs = LamAbs - apply = Apply - constant = Constant - builtin = Builtin - tyInst = TyInst - unwrap = Unwrap - iWrap = IWrap - error = Error - constr = Constr - kase = Case - - termLet x (Def vd bind) = Let x NonRec (pure $ TermBind x Strict vd bind) - typeLet x (Def vd bind) = Let x NonRec (pure $ TypeBind x vd bind) + var = Var + tyAbs = TyAbs + lamAbs = LamAbs + apply = Apply + constant = Constant + builtin = Builtin + tyInst = TyInst + unwrap = Unwrap + iWrap = IWrap + error = Error + constr = Constr + kase = Case + + termLet x (Def vd bind) = Let x NonRec (pure $ TermBind x Strict vd bind) + typeLet x (Def vd bind) = Let x NonRec (pure $ TypeBind x vd bind) data Program tyname name uni fun ann = Program - { _progAnn :: ann - -- | The version of the program. This corresponds to the underlying - -- Plutus Core version. - , _progVersion :: Version - , _progTerm :: Term tyname name uni fun ann - } - deriving stock (Functor, Generic) + { _progAnn :: ann + , _progVersion :: Version + -- ^ The version of the program. This corresponds to the underlying Plutus Core version. + , _progTerm :: Term tyname name uni fun ann + } + deriving stock (Functor, Generic) makeLenses ''Program -deriving stock instance (Show tyname, Show name, GShow uni, Everywhere uni Show, Show fun, Show ann, Closed uni) - => Show (Program tyname name uni fun ann) - - -type instance PLC.HasUniques (Term tyname name uni fun ann) = (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) -type instance PLC.HasUniques (Program tyname name uni fun ann) = PLC.HasUniques (Term tyname name uni fun ann) - --- | Applies one program to another. Fails if the versions do not match --- and tries to merge annotations. +deriving stock instance + ( Show tyname + , Show name + , GShow uni + , Everywhere uni Show + , Show fun + , Show ann + , Closed uni + ) + => Show (Program tyname name uni fun ann) + +type instance + PLC.HasUniques (Term tyname name uni fun ann) = + (PLC.HasUnique tyname PLC.TypeUnique, PLC.HasUnique name PLC.TermUnique) + +type instance + PLC.HasUniques (Program tyname name uni fun ann) = + PLC.HasUniques (Term tyname name uni fun ann) + +{- | Applies one program to another. Fails if the versions do not match +and tries to merge annotations. +-} applyProgram - :: (MonadError ApplyProgramError m, Semigroup a) - => Program tyname name uni fun a - -> Program tyname name uni fun a - -> m (Program tyname name uni fun a) -applyProgram (Program a1 v1 t1) (Program a2 v2 t2) | v1 == v2 - = pure $ Program (a1 <> a2) v1 (Apply (termAnn t1 <> termAnn t2) t1 t2) + :: (MonadError ApplyProgramError m, Semigroup a) + => Program tyname name uni fun a + -> Program tyname name uni fun a + -> m (Program tyname name uni fun a) +applyProgram (Program a1 v1 t1) (Program a2 v2 t2) + | v1 == v2 = + pure $ Program (a1 <> a2) v1 (Apply (termAnn t1 <> termAnn t2) t1 t2) applyProgram (Program _a1 v1 _t1) (Program _a2 v2 _t2) = - throwError $ MkApplyProgramError v1 v2 + throwError $ MkApplyProgramError v1 v2 termAnn :: Term tyname name uni fun a -> a termAnn = \case - Let a _ _ _ -> a - Var a _ -> a - TyAbs a _ _ _ -> a - LamAbs a _ _ _ -> a - Apply a _ _ -> a - Constant a _ -> a - Builtin a _ -> a - TyInst a _ _ -> a - Error a _ -> a - IWrap a _ _ _ -> a - Unwrap a _ -> a - Constr a _ _ _ -> a - Case a _ _ _ -> a + Let a _ _ _ -> a + Var a _ -> a + TyAbs a _ _ _ -> a + LamAbs a _ _ _ -> a + Apply a _ _ -> a + Constant a _ -> a + Builtin a _ -> a + TyInst a _ _ -> a + Error a _ -> a + IWrap a _ _ _ -> a + Unwrap a _ -> a + Constr a _ _ _ -> a + Case a _ _ _ -> a bindingAnn :: Binding tyname name uni fun a -> a bindingAnn = \case - TermBind a _ _ _ -> a - TypeBind a _ _ -> a - DatatypeBind a _ -> a + TermBind a _ _ _ -> a + TypeBind a _ _ -> a + DatatypeBind a _ -> a diff --git a/plutus-core/plutus-ir/src/PlutusIR/Error.hs b/plutus-core/plutus-ir/src/PlutusIR/Error.hs index e02a053dfa9..8ecf4d19e09 100644 --- a/plutus-core/plutus-ir/src/PlutusIR/Error.hs +++ b/plutus-core/plutus-ir/src/PlutusIR/Error.hs @@ -79,7 +79,7 @@ deriving anyclass instance (PLC.ThrowableBuiltins uni fun, PP.Pretty ann, Typeable ann) => Exception (Error uni fun ann) instance (PLC.PrettyUni uni, Pretty fun, Pretty ann) => Pretty (Error uni fun ann) where - pretty = PLC.prettyPlcClassicDef + pretty = PLC.prettyPlcClassic instance (PLC.PrettyUni uni, Pretty fun, Pretty ann) => diff --git a/plutus-core/plutus-ir/test/PlutusIR/Analysis/RetainedSize/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Analysis/RetainedSize/Tests.hs index f7d91041b37..d112a7149bf 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Analysis/RetainedSize/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Analysis/RetainedSize/Tests.hs @@ -16,7 +16,7 @@ test_retainedSize :: TestTree test_retainedSize = runTestNested ["plutus-ir", "test", "PlutusIR", "Analysis", "RetainedSize"] $ map - (goldenPir renameAndAnnotate pTerm) + (goldenPirUnique renameAndAnnotate pTerm) [ "typeLet" , "termLet" , "strictLet" @@ -38,7 +38,7 @@ test_retainedSize = , "recBindingComplex" ] where - displayAnnsConfig = PLC.PrettyConfigClassic PLC.defPrettyConfigName True + displayAnnsConfig = PLC.PrettyConfigClassic PLC.prettyConfigNameSimple True renameAndAnnotate = PLC.AttachPrettyConfig displayAnnsConfig . RetainedSize.annotateWithRetainedSize def diff --git a/plutus-core/plutus-ir/test/PlutusIR/Parser/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Parser/Tests.hs index be9afe4f5f1..bc4038a13dd 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Parser/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Parser/Tests.hs @@ -53,24 +53,30 @@ separator :: Char -> Bool separator c = c `elem` separators || isSpace c aroundSeparators :: MonadGen m => m String -> String -> m String -aroundSeparators = go False +aroundSeparators = go False False where -- Quoted names may contain separators, but they are part of the name, so -- we cannot scramble inside quoted names. - go inQuotedName splice = \case + go inQuotedName inUnique splice = \case [] -> pure [] [s] -> (s:) <$> splice + ('`' : '-' : l) | inQuotedName -> do + let (digits, notDigits) = break isDigit l + rest <- go (not inQuotedName) True splice notDigits + pure $ "`-" ++ digits ++ rest ('`' : l) -> do s <- splice - rest <- go (not inQuotedName) splice l - pure $ if inQuotedName then '`' : s ++ rest else s ++ '`' : rest + rest <- go (not inQuotedName) inUnique splice l + pure $ if inQuotedName + then '`' : s ++ rest + else s ++ '`' : rest (a : b : l) - | not (inQuotedName) && separator b -> do + | not inQuotedName && separator b -> do s1 <- splice s2 <- splice - rest <- go inQuotedName splice l + rest <- go inQuotedName inUnique splice l pure $ a : s1 ++ b : s2 ++ rest - | otherwise -> (a :) <$> go inQuotedName splice (b : l) + | otherwise -> (a :) <$> go inQuotedName inUnique splice (b : l) genScrambledWith :: MonadGen m => m String -> m (String, String) genScrambledWith splice = do @@ -118,8 +124,8 @@ propIgnores splice = property $ do (original, scrambled) <- forAll (genScrambledWith splice) let displayProgram :: Program TyName Name PLC.DefaultUni PLC.DefaultFun SrcSpan -> String displayProgram = display - parse1 = displayProgram <$> (parseProg $ T.pack original) - parse2 = displayProgram <$> (parseProg $ T.pack scrambled) + parse1 = displayProgram <$> parseProg (T.pack original) + parse2 = displayProgram <$> parseProg (T.pack scrambled) parse1 === parse2 test_parsing :: TestTree diff --git a/plutus-core/plutus-ir/test/PlutusIR/Purity/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Purity/Tests.hs index e947317a266..7593c086972 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Purity/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Purity/Tests.hs @@ -1,11 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} module PlutusIR.Purity.Tests where import Test.Tasty.Extras import PlutusCore qualified as PLC -import PlutusCore.Pretty (prettyPlcReadableDef) +import PlutusCore.Pretty (prettyPlcReadable) import PlutusCore.Quote import PlutusIR import PlutusIR.Analysis.VarInfo @@ -29,7 +28,7 @@ computeEvalOrderCoarse computeEvalOrderCoarse = termEvaluationOrder def mempty goldenEvalOrder :: String -> TestNested -goldenEvalOrder = goldenPirDoc (prettyPlcReadableDef . computeEvalOrder) pTerm +goldenEvalOrder = goldenPirDoc (prettyPlcReadable . computeEvalOrder) pTerm -- Should hit Unknown before trying to process the undefined. Shows -- that the computation is lazy diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/EvaluateBuiltins/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/EvaluateBuiltins/Tests.hs index da91258a806..b6520a69bfd 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/EvaluateBuiltins/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/EvaluateBuiltins/Tests.hs @@ -41,8 +41,7 @@ test_evaluateBuiltins = , "uncompressAndEqualBlsNonConservative" ] -prop_evaluateBuiltins :: - Bool -> BuiltinSemanticsVariant DefaultFun -> Property +prop_evaluateBuiltins :: Bool -> BuiltinSemanticsVariant DefaultFun -> Property prop_evaluateBuiltins conservative biVariant = withMaxSuccess (2 * 3 * numTestsForPassProp) $ testPassProp diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/Rename/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/Rename/Tests.hs index c767ecf4cca..baa43be5eb7 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/Rename/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/Rename/Tests.hs @@ -3,7 +3,6 @@ module PlutusIR.Transform.Rename.Tests where import Test.Tasty import Test.Tasty.Extras -import PlutusCore.Pretty qualified as PLC import PlutusCore.Quote import PlutusIR.Parser import PlutusIR.Pass @@ -14,17 +13,16 @@ import Test.Tasty.QuickCheck test_rename :: TestTree test_rename = + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "Rename"] $ - map - (goldenPir - (PLC.AttachPrettyConfig debugConfig . runQuote . runTestPass (const renamePass)) pTerm) - [ "allShadowedDataNonRec" - , "allShadowedDataRec" - , "paramShadowedDataNonRec" - , "paramShadowedDataRec" - ] + runGoldenPir <$> + [ "allShadowedDataNonRec" + , "allShadowedDataRec" + , "paramShadowedDataNonRec" + , "paramShadowedDataRec" + ] where - debugConfig = PLC.PrettyConfigClassic PLC.debugPrettyConfigName False + runGoldenPir = goldenPir (runQuote . runTestPass (const renamePass)) pTerm prop_rename :: Property prop_rename = diff --git a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/Tests.hs b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/Tests.hs index a4afde2d2fc..f839c8db161 100644 --- a/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/Tests.hs +++ b/plutus-core/plutus-ir/test/PlutusIR/Transform/RewriteRules/Tests.hs @@ -14,28 +14,25 @@ import Test.Tasty test_rewriteRules :: TestTree test_rewriteRules = - runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "RewriteRules"] $ - (fmap - (goldenPir (runQuote . runTestPass (\tc -> rewritePassSC tc def)) pTerm) - [ "equalsInt.pir" -- this tests that the function works on equalInteger - , "divideInt.pir" -- this tests that the function excludes not commutative functions - , "multiplyInt.pir" -- this tests that the function works on multiplyInteger - , "let.pir" -- this tests that it works in the subterms - , "unConstrConstrDataFst.pir" - , "unConstrConstrDataSnd.pir" - ] - ) - ++ - (fmap - (goldenPirEvalTrace pTermAsProg) - [ "unConstrConstrDataFst.pir.eval" - ] - ) + runTestNested ["plutus-ir", "test", "PlutusIR", "Transform", "RewriteRules"] $ + fmap + (goldenPir (runQuote . runTestPass (\tc -> rewritePassSC tc def)) pTerm) + [ "equalsInt.pir" -- this tests that the function works on equalInteger + , "divideInt.pir" -- this tests that the function excludes not commutative functions + , "multiplyInt.pir" -- this tests that the function works on multiplyInteger + , "let.pir" -- this tests that it works in the subterms + , "unConstrConstrDataFst.pir" + , "unConstrConstrDataSnd.pir" + ] + ++ fmap + (goldenPirEvalTrace pTermAsProg) + [ "unConstrConstrDataFst.pir.eval" + ] where - goldenPirEvalTrace = goldenPirM $ \ast -> ppCatch $ do - -- we need traces to remain for checking the evaluation-order - tplc <- asIfThrown $ compileWithOpts ( set (PIR.ccOpts . PIR.coPreserveLogging) True) ast - runUPlcLogs [void tplc] + goldenPirEvalTrace = goldenPirM $ \ast -> ppCatch prettyPlcClassicSimple $ do + -- we need traces to remain for checking the evaluation-order + tplc <- asIfThrown $ compileWithOpts (set (PIR.ccOpts . PIR.coPreserveLogging) True) ast + runUPlcLogs [void tplc] prop_rewriteRules :: Property prop_rewriteRules = diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Test.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Test.hs index ab045c191d2..97339b2e8cb 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Test.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Test.hs @@ -67,9 +67,9 @@ printSampleProgramAndValue => TermGen a -> IO () printSampleProgramAndValue = getSampleProgramAndValue >=> \(program, value) -> do - putStrLn $ displayPlcDef program + putStrLn $ displayPlc program putStrLn "" - putStrLn $ displayPlcDef value + putStrLn $ displayPlc value -- | Generate a pair of files: @..plc@ and @..plc.golden@. -- The first file contains a term generated by a term generator (wrapped in 'Program'), @@ -86,8 +86,8 @@ sampleProgramValueGolden folder name genTerm = do let filePlc = folder (name ++ ".plc") filePlcGolden = folder (name ++ ".plc.golden") (program, value) <- getSampleProgramAndValue genTerm - Text.writeFile filePlc $ displayPlcDef program - Text.writeFile filePlcGolden $ displayPlcDef value + Text.writeFile filePlc $ displayPlc program + Text.writeFile filePlcGolden $ displayPlc value -- | A property-based testing procedure for evaluators. -- Checks whether a term generated along with the value it's supposed to compute to diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/TypeEvalCheck.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/TypeEvalCheck.hs index 2df1a45e66d..cd9cad55e80 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/TypeEvalCheck.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/TypeEvalCheck.hs @@ -132,6 +132,6 @@ unsafeTypeEvalCheck termOfTbv = do Left err -> error $ concat [ prettyPlcErrorString err , "\nin\n" - , render . prettyPlcClassicDebug $ _termOfTerm termOfTbv + , render . prettyPlcClassicSimple $ _termOfTerm termOfTbv ] Right termOfTecr -> _termCheckResultValue <$> termOfTecr diff --git a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Utils.hs b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Utils.hs index 1730380b9ec..c5b759791e6 100644 --- a/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Utils.hs +++ b/plutus-core/testlib/PlutusCore/Generators/Hedgehog/Utils.hs @@ -64,13 +64,13 @@ forAllPrettyT = forAllWithT display -- | Generate a value using the 'PrettyPlc' constraint for getting its 'String' representation. forAllPrettyPlc :: (Monad m, PrettyPlc a) => Gen a -> PropertyT m a -forAllPrettyPlc = forAllWith displayPlcDef +forAllPrettyPlc = forAllWith displayPlc -- | Generate a value using the 'PrettyPlc' constraint for getting its 'String' representation. -- A supplied generator has access to the 'Monad' the whole property has access to. forAllPrettyPlcT :: (Monad m, PrettyPlc a) => GenT m a -> PropertyT m a -forAllPrettyPlcT = forAllWithT displayPlcDef +forAllPrettyPlcT = forAllWithT displayPlc -- | Pretty-print a PLC error. prettyPlcErrorString :: PrettyPlc err => err -> String -prettyPlcErrorString = render . prettyPlcCondensedErrorBy debugPrettyConfigPlcClassic +prettyPlcErrorString = render . prettyPlcCondensedErrorBy prettyConfigPlcClassicSimple diff --git a/plutus-core/testlib/PlutusCore/Test.hs b/plutus-core/testlib/PlutusCore/Test.hs index 2aee9675ee1..ec8b80b89f9 100644 --- a/plutus-core/testlib/PlutusCore/Test.hs +++ b/plutus-core/testlib/PlutusCore/Test.hs @@ -91,6 +91,7 @@ import Hedgehog.Internal.Property import Hedgehog.Internal.Region import Hedgehog.Internal.Report import Hedgehog.Internal.Runner +import PlutusCore.Pretty qualified as PP -- | Map the 'TestLimit' of a 'Property' with a given function. mapTestLimit :: (TestLimit -> TestLimit) -> Property -> Property @@ -210,7 +211,7 @@ instance (PrettyBy config err) instance (PrettyPlc err) => Show (EvaluationExceptionWithLogsAndBudget err) where - show = render . prettyPlcReadableDebug + show = render . prettyPlcReadableSimple instance (PrettyPlc err, Exception err) => Exception (EvaluationExceptionWithLogsAndBudget err) @@ -301,14 +302,19 @@ runUPlcProfile' values = do Right _ -> pure logs ppCatch :: (PrettyPlc a) => ExceptT SomeException IO a -> IO (Doc ann) -ppCatch value = either (PP.pretty . show) prettyPlcClassicDebug <$> runExceptT value +ppCatch value = either (PP.prettyClassic . show) prettyPlcReadableSimple <$> runExceptT value ppCatch' :: ExceptT SomeException IO (Doc ann) -> IO (Doc ann) -ppCatch' value = either (PP.pretty . show) id <$> runExceptT value +ppCatch' value = either (PP.prettyClassic . show) id <$> runExceptT value -ppCatchReadable :: (PrettyBy (PrettyConfigReadable PrettyConfigName) a) +ppCatchReadable + :: forall a ann + . PrettyBy (PrettyConfigReadable PrettyConfigName) a => ExceptT SomeException IO a -> IO (Doc ann) -ppCatchReadable value = either (PP.pretty . show) (pretty . AsReadable) <$> runExceptT value +ppCatchReadable value = + let pprint :: forall t. PrettyBy (PrettyConfigReadable PrettyConfigName) t => t -> Doc ann + pprint = prettyBy (topPrettyConfigReadable prettyConfigNameSimple def) + in either (pprint . show) pprint <$> runExceptT value goldenTPlcWith :: (ToTPlc a TPLC.DefaultUni TPLC.DefaultFun) => @@ -376,58 +382,29 @@ goldenTEval :: goldenTEval name values = nestedGoldenVsDocM name ".eval" $ ppCatch $ runTPlc values -goldenUEval :: - (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => - String -> - [a] -> - TestNested -goldenUEval name values = - nestedGoldenVsDocM name ".eval" $ ppCatch $ runUPlc values +goldenUEval :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> [a] -> TestNested +goldenUEval name values = nestedGoldenVsDocM name ".eval" $ ppCatch $ runUPlc values -goldenUEvalLogs :: - (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => - String -> - [a] -> - TestNested -goldenUEvalLogs name values = - nestedGoldenVsDocM name ".eval" $ ppCatch $ runUPlcLogs values +goldenUEvalLogs :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> [a] -> TestNested +goldenUEvalLogs name values = nestedGoldenVsDocM name ".eval" $ ppCatch $ runUPlcLogs values -- | This is mostly useful for profiling a test that is normally -- tested with one of the other functions, as it's a drop-in -- replacement and you can then pass the output into `traceToStacks`. -goldenUEvalProfile :: - (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => - String -> - [a] -> - TestNested -goldenUEvalProfile name values = - nestedGoldenVsDocM name ".eval" $ ppCatch $ runUPlcProfile values - -goldenUEvalBudget :: - (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) - => String - -> [a] - -> TestNested -goldenUEvalBudget name values = - nestedGoldenVsDocM name ".budget" $ ppCatch $ runUPlcBudget values - -goldenSize :: - (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => - String -> - a -> - TestNested +goldenUEvalProfile :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> [a] -> TestNested +goldenUEvalProfile name values = nestedGoldenVsDocM name ".eval" $ ppCatch $ runUPlcProfile values + +goldenUEvalBudget :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> [a] -> TestNested +goldenUEvalBudget name values = nestedGoldenVsDocM name ".budget" $ ppCatch $ runUPlcBudget values + +goldenSize :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> a -> TestNested goldenSize name value = - nestedGoldenVsDocM name ".size" $ - pure . pretty . UPLC.programSize =<< rethrow (toUPlc value) + nestedGoldenVsDocM name ".size" $ pure . pretty . UPLC.programSize =<< rethrow (toUPlc value) -- | This is mostly useful for profiling a test that is normally -- tested with one of the other functions, as it's a drop-in -- replacement and you can then pass the output into `traceToStacks`. -goldenUEvalProfile' :: - (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => - String -> - [a] -> - TestNested +goldenUEvalProfile' :: (ToUPlc a TPLC.DefaultUni TPLC.DefaultFun) => String -> [a] -> TestNested goldenUEvalProfile' name values = nestedGoldenVsDocM name ".eval" $ ppCatch' $ fmap (\ts -> PP.vsep (fmap pretty ts)) $ runUPlcProfile' values @@ -597,7 +574,7 @@ prop_scopingFor gen bindRem preren run = withTests 1000 . property $ do prep = runPrerename preren case catchEverything $ checkRespectsScoping bindRem prep (TPLC.runQuote . run) prog of Left exc -> fail $ displayException exc - Right (Left err) -> fail $ displayPlcDef err + Right (Left err) -> fail $ displayPlc err Right (Right ()) -> success -- | Test that a pass does not break global uniqueness. diff --git a/plutus-core/testlib/PlutusIR/Generators/QuickCheck/ShrinkTerms.hs b/plutus-core/testlib/PlutusIR/Generators/QuickCheck/ShrinkTerms.hs index 22a467cbaf0..206ffe140e4 100644 --- a/plutus-core/testlib/PlutusIR/Generators/QuickCheck/ShrinkTerms.hs +++ b/plutus-core/testlib/PlutusIR/Generators/QuickCheck/ShrinkTerms.hs @@ -346,7 +346,7 @@ shrinkTypedTerm tyctx0 ctx0 (ty0, tm0) = concat fun' = fixupTerm tyctx ctx tyctx ctx (TyForall () x k' tyInner') fun ] Left err -> error $ displayPlcCondensedErrorClassic err - Right tyWrong -> error $ "Expected a 'TyForall', but got " ++ displayPlcDef tyWrong + Right tyWrong -> error $ "Expected a 'TyForall', but got " ++ displayPlc tyWrong -- TODO: shrink the kind too like with the type in @LamAbs@ below. TyAbs _ x _ body | not $ Map.member x tyctx -> diff --git a/plutus-core/testlib/PlutusIR/Test.hs b/plutus-core/testlib/PlutusIR/Test.hs index b7422409eb3..37304f33ce3 100644 --- a/plutus-core/testlib/PlutusIR/Test.hs +++ b/plutus-core/testlib/PlutusIR/Test.hs @@ -12,7 +12,7 @@ module PlutusIR.Test , initialSrcSpan , topSrcSpan , rethrow - , PLC.prettyPlcClassicDebug + , PLC.prettyPlcClassicSimple ) where import PlutusPrelude @@ -24,13 +24,17 @@ import Control.Monad.Except import Control.Monad.Morph (hoist) import Control.Monad.Reader as Reader -import PlutusCore qualified as PLC +import PlutusCore.Annotation qualified as PLC import PlutusCore.Builtin qualified as PLC +import PlutusCore.Core qualified as PLC +import PlutusCore.DeBruijn qualified as PLC +import PlutusCore.Default qualified as PLC import PlutusCore.Error (ParserErrorBundle) import PlutusCore.Pretty import PlutusCore.Pretty qualified as PLC import PlutusCore.Quote (runQuoteT) import PlutusCore.Test hiding (ppCatch) +import PlutusCore.TypeCheck qualified as PLC import PlutusIR as PIR import PlutusIR.Analysis.Builtins import PlutusIR.Compiler as PIR @@ -130,34 +134,35 @@ withGoldenFileM name op = do currentDir = joinPath <$> ask -- TODO: deduplicate with the PlutusuCore one -ppCatch :: (PrettyPlc a) => ExceptT SomeException IO a -> IO T.Text -ppCatch value = render <$> (either (pretty . show) prettyPlcClassicDebug <$> runExceptT value) +ppCatch :: (a -> Doc ann) -> ExceptT SomeException IO a -> IO T.Text +ppCatch toDoc value = render . either (pretty . show) toDoc <$> runExceptT value -goldenPir :: (Pretty b) => (a -> b) -> Parser a -> String -> TestNested +goldenPir :: (PrettyPlc b) => (a -> b) -> Parser a -> String -> TestNested goldenPir op = goldenPirM (return . op) +goldenPirUnique :: (Pretty b) => (a -> b) -> Parser a -> String -> TestNested +goldenPirUnique op = goldenPirMUnique (return . op) + goldenPirDoc :: (a -> Doc ann) -> Parser a -> String -> TestNested goldenPirDoc op = goldenPirDocM (return . op) -goldenPirM :: forall a b. (Pretty b) => (a -> IO b) -> Parser a -> String -> TestNested -goldenPirM op parser name = withGoldenFileM name parseOrError +goldenPirMUnique :: forall a b. (Pretty b) => (a -> IO b) -> Parser a -> String -> TestNested +goldenPirMUnique op parser name = withGoldenFileM name parseOrError where parseOrError :: T.Text -> IO T.Text parseOrError = let parseTxt :: T.Text -> Either ParserErrorBundle a parseTxt txt = runQuoteT $ parse parser name txt - in either (return . display) (fmap display . op) - . parseTxt + in either (return . display) (fmap display . op) . parseTxt -goldenPirMUnique :: forall a b. (PrettyPlc b) => (a -> IO b) -> Parser a -> String -> TestNested -goldenPirMUnique op parser name = withGoldenFileM name parseOrError +goldenPirM :: forall a b. (PrettyPlc b) => (a -> IO b) -> Parser a -> String -> TestNested +goldenPirM op parser name = withGoldenFileM name parseOrError where parseOrError :: T.Text -> IO T.Text parseOrError = let parseTxt :: T.Text -> Either ParserErrorBundle a parseTxt txt = runQuoteT $ parse parser name txt - in either (return . display) (fmap (render . prettyPlcReadableDef) . op) - . parseTxt + in either (pure . display) ((render . prettyPlcReadable <$>) . op) . parseTxt goldenPirDocM :: forall a ann. (a -> IO (Doc ann)) -> Parser a -> String -> TestNested goldenPirDocM op parser name = withGoldenFileM name parseOrError @@ -174,7 +179,7 @@ goldenPlcFromPir :: Parser a -> String -> TestNested -goldenPlcFromPir = goldenPirM $ \ast -> ppCatch $ do +goldenPlcFromPir = goldenPirM $ \ast -> ppCatch prettyPlcReadableSimple $ do p <- toTPlc ast withExceptT @_ @PLC.FreeVariableError toException $ traverseOf PLC.progTerm PLC.deBruijnTerm p @@ -184,7 +189,7 @@ goldenPlcFromPirScott :: Parser prog -> String -> TestNested -goldenPlcFromPirScott = goldenPirM $ \ast -> ppCatch $ do +goldenPlcFromPirScott = goldenPirM $ \ast -> ppCatch prettyPlcReadableSimple $ do p <- asIfThrown . fmap void @@ -197,14 +202,14 @@ goldenNamedUPlcFromPir :: Parser a -> String -> TestNested -goldenNamedUPlcFromPir = goldenPirM $ ppCatch . toUPlc +goldenNamedUPlcFromPir = goldenPirM $ ppCatch prettyPlcReadableSimple . toUPlc goldenEvalPir :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) => Parser a -> String -> TestNested -goldenEvalPir = goldenPirM (\ast -> ppCatch $ runUPlc [ast]) +goldenEvalPir = goldenPirM (\ast -> ppCatch prettyPlcReadableSimple $ runUPlc [ast]) goldenTypeFromPir :: forall a. @@ -214,7 +219,7 @@ goldenTypeFromPir :: String -> TestNested goldenTypeFromPir x = - goldenPirM $ \ast -> ppCatch $ + goldenPirM $ \ast -> ppCatch prettyPlcReadable $ withExceptT (toException :: PIR.Error PLC.DefaultUni PLC.DefaultFun a -> SomeException) $ runQuoteT $ do tcConfig <- getDefTypeCheckConfig x diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Default.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Default.hs index a91cec3d9d6..eac92892320 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Default.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Default.hs @@ -19,8 +19,8 @@ import UntypedPlutusCore.Core.Type instance (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty ann) => Pretty (Term name uni fun ann) where - pretty = prettyClassicDef + pretty = prettyClassic instance (PrettyClassic name, PrettyUni uni, Pretty fun, Pretty ann) => Pretty (Program name uni fun ann) where - pretty = prettyClassicDef + pretty = prettyClassic diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs index 12b623e1406..681d1c81ea6 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Core/Instance/Pretty/Readable.hs @@ -34,7 +34,7 @@ viewApp term0 = go term0 [] where go fun args = Just (fun, args) instance - (PrettyReadableBy configName name, PrettyUni uni, Pretty fun) => + (PrettyReadableBy configName name, PrettyUni uni, Pretty fun, Show configName) => PrettyBy (PrettyConfigReadable configName) (Term name uni fun a) where prettyBy = inContextM $ \case diff --git a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs index ea1cccd2fd5..44548468a25 100644 --- a/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs +++ b/plutus-core/untyped-plutus-core/src/UntypedPlutusCore/Evaluation/Machine/Cek/EmitterMode.hs @@ -1,8 +1,11 @@ --- editorconfig-checker-disable-file -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-} -module UntypedPlutusCore.Evaluation.Machine.Cek.EmitterMode (noEmitter, logEmitter, logWithTimeEmitter, logWithBudgetEmitter) where +module UntypedPlutusCore.Evaluation.Machine.Cek.EmitterMode + ( noEmitter + , logEmitter + , logWithTimeEmitter + , logWithBudgetEmitter + ) where import UntypedPlutusCore.Evaluation.Machine.Cek.Internal @@ -30,38 +33,38 @@ noEmitter = EmitterMode $ \_ -> pure $ CekEmitterInfo (\_ -> pure ()) (pure memp -- | Emits log only. logEmitter :: EmitterMode uni fun logEmitter = EmitterMode $ \_ -> do - logsRef <- newSTRef DList.empty - let emitter logs = CekM $ modifySTRef logsRef (`DList.append` logs) - pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef) + logsRef <- newSTRef DList.empty + let emitter logs = CekM $ modifySTRef logsRef (`DList.append` logs) + pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef) -- A wrapper around encoding a record. `cassava` insists on including a trailing newline, which is -- annoying since we're recording the output line-by-line. -encodeRecord :: CSV.ToRecord a => a -> T.Text +encodeRecord :: (CSV.ToRecord a) => a -> T.Text encodeRecord a = T.stripEnd $ T.decodeUtf8 $ BSL.toStrict $ BS.toLazyByteString $ CSV.encodeRecord a -- | Emits log with timestamp. logWithTimeEmitter :: EmitterMode uni fun logWithTimeEmitter = EmitterMode $ \_ -> do - logsRef <- newSTRef DList.empty - let emitter logs = CekM $ do - time <- unsafeIOToST getCurrentTime - let secs = let MkFixed s = nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds time in s - let withTime = logs <&> \str -> encodeRecord (str, secs) - modifySTRef logsRef (`DList.append` withTime) - pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef) + logsRef <- newSTRef DList.empty + let emitter logs = CekM $ do + time <- unsafeIOToST getCurrentTime + let secs = let MkFixed s = nominalDiffTimeToSeconds $ utcTimeToPOSIXSeconds time in s + let withTime = logs <&> \str -> encodeRecord (str, secs) + modifySTRef logsRef (`DList.append` withTime) + pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef) instance CSV.ToField ExCPU where - toField (ExCPU t) = CSV.toField $ unSatInt t + toField (ExCPU t) = CSV.toField $ unSatInt t instance CSV.ToField ExMemory where - toField (ExMemory t) = CSV.toField $ unSatInt t + toField (ExMemory t) = CSV.toField $ unSatInt t -- | Emits log with the budget. logWithBudgetEmitter :: EmitterMode uni fun logWithBudgetEmitter = EmitterMode $ \getBudget -> do - logsRef <- newSTRef DList.empty - let emitter logs = CekM $ do - ExBudget exCpu exMemory <- getBudget - let withBudget = logs <&> \str -> encodeRecord (str, exCpu, exMemory) - modifySTRef logsRef (`DList.append` withBudget) - pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef) + logsRef <- newSTRef DList.empty + let emitter logs = CekM $ do + ExBudget exCpu exMemory <- getBudget + let withBudget = logs <&> \str -> encodeRecord (str, exCpu, exMemory) + modifySTRef logsRef (`DList.append` withBudget) + pure $ CekEmitterInfo emitter (DList.toList <$> readSTRef logsRef) diff --git a/plutus-core/untyped-plutus-core/test/Analysis/Spec.hs b/plutus-core/untyped-plutus-core/test/Analysis/Spec.hs index 78b8efec252..9973f8b95ca 100644 --- a/plutus-core/untyped-plutus-core/test/Analysis/Spec.hs +++ b/plutus-core/untyped-plutus-core/test/Analysis/Spec.hs @@ -6,7 +6,7 @@ import Test.Tasty.Extras import PlutusCore qualified as PLC import PlutusCore.MkPlc -import PlutusCore.Pretty (prettyPlcReadableDef) +import PlutusCore.Pretty (prettyPlcReadable) import PlutusCore.Quote import PlutusPrelude (def) import Test.Tasty @@ -16,7 +16,7 @@ import UntypedPlutusCore.Purity goldenEvalOrder :: String -> Term Name PLC.DefaultUni PLC.DefaultFun () -> TestNested goldenEvalOrder name tm = - nestedGoldenVsDoc name "" (prettyPlcReadableDef $ termEvaluationOrder def tm) + nestedGoldenVsDoc name "" (prettyPlcReadable $ termEvaluationOrder def tm) -- Should hit Unknown before trying to process the undefined. Shows -- that the computation is lazy diff --git a/plutus-core/untyped-plutus-core/test/DeBruijn/UnDeBruijnify.hs b/plutus-core/untyped-plutus-core/test/DeBruijn/UnDeBruijnify.hs index 0ea3f7665f7..ae059afc982 100644 --- a/plutus-core/untyped-plutus-core/test/DeBruijn/UnDeBruijnify.hs +++ b/plutus-core/untyped-plutus-core/test/DeBruijn/UnDeBruijnify.hs @@ -83,5 +83,5 @@ test_undebruijnify = testNested "Golden" mkProg = Program () PLC.latestVersion . termMapNames fakeNameDeBruijn - toPretty = prettyPlcClassicDebug . runExcept @(Error DefaultUni DefaultFun ()) . runQuoteT + toPretty = prettyPlcClassicSimple . runExcept @(Error DefaultUni DefaultFun ()) . runQuoteT diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs index 1212d1167e7..1e396d713fe 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Definition.hs @@ -409,8 +409,8 @@ test_TrackCostsRestricting = let n = 30000 in test_TrackCostsWith "restricting" n $ \term -> case typecheckReadKnownCek def () term of - Left err -> fail $ displayPlcDef err - Right (Left err) -> fail $ displayPlcDef err + Left err -> fail $ displayPlc err + Right (Left err) -> fail $ displayPlc err Right (Right (res :: [Integer])) -> do let expected = n `div` 10 actual = length res @@ -431,8 +431,8 @@ test_TrackCostsRetaining = let (getRes, budgets) = runCekNoEmit params retaining term' in (getRes >>= readKnownSelf, budgets) case typecheckAndRunRetainer () term of - Left err -> fail $ displayPlcDef err - Right (Left err, _) -> fail $ displayPlcDef err + Left err -> fail $ displayPlc err + Right (Left err, _) -> fail $ displayPlc err Right (Right (res :: [Integer]), budgets) -> do -- @length budgets@ is for retaining @budgets@ for as long as possible just in case. -- @3@ is just for giving us room to handle erratic GC behavior. It really should be diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Golden.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Golden.hs index 7cbe242f97f..3da6ca9b6ad 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Golden.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Golden.hs @@ -238,7 +238,7 @@ iteAtStringWithCond = Apply () iteAtString lteExpr -- @string@. It still runs succefully, because even in typed world (the CK machine) we don't look -- at types at runtime. iteAtStringWithCondWithIntegerWithString :: Term TyName Name DefaultUni DefaultFun () -iteAtStringWithCondWithIntegerWithString = mkIterAppNoAnn (iteAtStringWithCond) +iteAtStringWithCondWithIntegerWithString = mkIterAppNoAnn iteAtStringWithCond [ mkConstant @Integer () 33 , mkConstant @Text () "abc" ] @@ -395,7 +395,7 @@ caseNonTag = Case () integer (mkConstant @Integer () 1) [] goldenVsPretty :: PrettyPlc a => String -> String -> a -> TestTree goldenVsPretty extn name value = goldenVsString name ("untyped-plutus-core/test/Evaluation/Golden/" ++ name ++ extn) $ - pure . BSL.fromStrict . encodeUtf8 . render $ prettyPlcClassicDebug value + pure . BSL.fromStrict . encodeUtf8 . render $ prettyPlcClassicSimple value goldenVsEvaluatedCK :: String -> Term TyName Name DefaultUni DefaultFun () -> TestTree goldenVsEvaluatedCK name diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Machines.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Machines.hs index 6174ac0326a..565b00a3f11 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Machines.hs +++ b/plutus-core/untyped-plutus-core/test/Evaluation/Machines.hs @@ -75,8 +75,11 @@ testBudget runtime name term = nestedGoldenVsText name ".uplc" - (render $ - prettyPlcReadableDef $ runCekNoEmit (MachineParameters Plc.defaultCekMachineCostsForTesting runtime) Cek.tallying term) + (render + $ prettyPlcReadable + $ runCekNoEmit + (MachineParameters Plc.defaultCekMachineCostsForTesting runtime) + Cek.tallying term) bunchOfFibs :: PlcFolderContents DefaultUni DefaultFun bunchOfFibs = FolderContents [treeFolderContents "Fib" $ map fibFile [1..3]] where @@ -137,8 +140,7 @@ testTallying name term = nestedGoldenVsText name ".uplc" - (render $ - prettyPlcReadableDef $ runCekNoEmit Plc.defaultCekParametersForTesting Cek.tallying term) + (render $ prettyPlcReadable $ runCekNoEmit Plc.defaultCekParametersForTesting Cek.tallying term) test_tallying :: TestTree test_tallying = diff --git a/plutus-core/untyped-plutus-core/test/Generators.hs b/plutus-core/untyped-plutus-core/test/Generators.hs index 6bf54bc637b..7c56126d1a6 100644 --- a/plutus-core/untyped-plutus-core/test/Generators.hs +++ b/plutus-core/untyped-plutus-core/test/Generators.hs @@ -17,7 +17,7 @@ import PlutusCore.Generators.Hedgehog (forAllPretty) import PlutusCore.Generators.Hedgehog.AST (AstGen, runAstGen) import PlutusCore.Generators.Hedgehog.AST qualified as AST import PlutusCore.Parser (defaultUni, parseGen) -import PlutusCore.Pretty (displayPlcDef) +import PlutusCore.Pretty (displayPlc) import PlutusCore.Quote (QuoteT, runQuoteT) import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Core.Type (Program (Program), Term (..), progTerm, termAnn) @@ -28,7 +28,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Vector qualified as V -import Hedgehog (annotate, failure, property, tripping, (===)) +import Hedgehog (annotate, annotateShow, failure, property, tripping, (===)) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import Test.Tasty (TestTree, testGroup) @@ -79,7 +79,7 @@ propFlat = testPropertyNamed "Flat" "Flat" $ property $ do propParser :: TestTree propParser = testPropertyNamed "Parser" "parser" $ property $ do prog <- TextualProgram <$> forAllPretty (runAstGen Generators.genProgram) - tripping prog (displayPlcDef . unTextualProgram) + tripping prog (displayPlc . unTextualProgram) (\p -> fmap (TextualProgram . void) (parseProg p)) where parseProg @@ -97,6 +97,7 @@ propTermSrcSpan = testPropertyNamed display <$> forAllPretty (view progTerm <$> runAstGen (Generators.genProgram @DefaultFun)) + annotateShow code let (endingLine, endingCol) = length &&& T.length . last $ T.lines code trailingSpaces <- forAllPretty $ Gen.text (Range.linear 0 10) (Gen.element [' ', '\n']) case runQuoteT . parseTerm @ParserErrorBundle $ code <> trailingSpaces of diff --git a/plutus-core/untyped-plutus-core/test/Transform/CaseOfCase/Test.hs b/plutus-core/untyped-plutus-core/test/Transform/CaseOfCase/Test.hs index 3e18bc27bb0..af1aab6571e 100644 --- a/plutus-core/untyped-plutus-core/test/Transform/CaseOfCase/Test.hs +++ b/plutus-core/untyped-plutus-core/test/Transform/CaseOfCase/Test.hs @@ -134,5 +134,5 @@ goldenVsSimplified name = . BSL.fromStrict . encodeUtf8 . render - . prettyClassicDebug + . prettyClassicSimple . caseOfCase diff --git a/plutus-core/untyped-plutus-core/test/Transform/Simplify/Lib.hs b/plutus-core/untyped-plutus-core/test/Transform/Simplify/Lib.hs index 96a6e442e71..476ff9d7c54 100644 --- a/plutus-core/untyped-plutus-core/test/Transform/Simplify/Lib.hs +++ b/plutus-core/untyped-plutus-core/test/Transform/Simplify/Lib.hs @@ -7,7 +7,7 @@ import Data.ByteString.Lazy qualified as BSL import Data.Text.Encoding (encodeUtf8) import PlutusCore qualified as PLC import PlutusCore.Builtin (BuiltinSemanticsVariant) -import PlutusCore.Pretty (PrettyPlc, Render (render), prettyPlcReadableDebug) +import PlutusCore.Pretty (PrettyPlc, Render (render), prettyPlcReadableSimple) import PlutusPrelude (Default (def)) import Test.Tasty (TestTree) import Test.Tasty.Golden (goldenVsString) @@ -19,7 +19,7 @@ goldenVsPretty :: (PrettyPlc a) => String -> String -> a -> TestTree goldenVsPretty extn name value = goldenVsString name ("untyped-plutus-core/test/Transform/" ++ name ++ extn) $ pure . BSL.fromStrict . encodeUtf8 . render $ - prettyPlcReadableDebug value + prettyPlcReadableSimple value goldenVsSimplified :: String -> Term Name PLC.DefaultUni PLC.DefaultFun () -> TestTree goldenVsSimplified name = diff --git a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs index 2e26fd54bd2..84bd19b8027 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/Common/Eval.hs @@ -60,7 +60,7 @@ instance AsScriptDecodeError EvaluationError where _ScriptDecodeError = _CodecError instance Pretty EvaluationError where - pretty (CekError e) = prettyClassicDef e + pretty (CekError e) = prettyClassic e pretty (DeBruijnError e) = pretty e pretty (CodecError e) = pretty e pretty CostModelParameterMismatch = "Cost model parameters were not as we expected" diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Error.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Error.hs index f3768e31111..0de72379a1a 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Error.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Error.hs @@ -74,7 +74,7 @@ data Error uni fun a makeClassyPrisms ''Error instance (PLC.PrettyUni uni, PP.Pretty fun, PP.Pretty a) => PP.Pretty (Error uni fun a) where - pretty = PLC.prettyPlcClassicDebug + pretty = PLC.prettyPlcClassicSimple instance (uni1 ~ uni2, b ~ PIR.Provenance a) => diff --git a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs index 61d50b7c0a0..ae037a1a605 100644 --- a/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs +++ b/plutus-tx-plugin/src/PlutusTx/Compiler/Expr.hs @@ -521,7 +521,7 @@ maybeProfileRhs var t = do CompileContext{ccOpts = compileOpts} <- ask let ty = PLC._varDeclType var varName = PLC._varDeclName var - displayName = T.pack $ PP.displayPlcDef varName + displayName = T.pack $ PP.displayPlc varName isFunctionOrAbstraction = case ty of PLC.TyFun{} -> True; PLC.TyForall{} -> True; _ -> False -- Trace only if profiling is on *and* the thing being defined is a function if coProfile compileOpts == All && isFunctionOrAbstraction diff --git a/plutus-tx-plugin/test/Lib.hs b/plutus-tx-plugin/test/Lib.hs index 66210e22cda..1d75a184cd4 100644 --- a/plutus-tx-plugin/test/Lib.hs +++ b/plutus-tx-plugin/test/Lib.hs @@ -6,8 +6,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-orphans #-} module Lib where import Control.Exception @@ -33,31 +33,50 @@ import UntypedPlutusCore qualified as UPLC import UntypedPlutusCore.Evaluation.Machine.Cek goldenPir - :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) - => String -> CompiledCodeIn uni fun a -> TestNested -goldenPir name value = nestedGoldenVsDoc name ".pir" $ pretty $ getPirNoAnn value + :: (PrettyUni uni, Pretty fun, uni `PLC.Everywhere` Flat, Flat fun) + => String + -> CompiledCodeIn uni fun a + -> TestNested +goldenPir name value = + nestedGoldenVsDoc name ".pir" $ + prettyPlcClassicSimple $ + getPirNoAnn value -runPlcCek :: ToUPlc a PLC.DefaultUni PLC.DefaultFun => [a] -> ExceptT SomeException IO (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun ()) +runPlcCek + :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) + => [a] + -> ExceptT SomeException IO (UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun ()) runPlcCek values = do - ps <- traverse toUPlc values - let p = - foldl1 (unsafeFromRight .* UPLC.applyProgram) ps - fromRightM (throwError . SomeException) $ evaluateCekNoEmit PLC.defaultCekParametersForTesting (p ^. UPLC.progTerm) - -runPlcCekTrace :: - ToUPlc a PLC.DefaultUni PLC.DefaultFun => - [a] -> - ExceptT SomeException IO ([Text], CekExTally PLC.DefaultFun, UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun ()) + ps <- traverse toUPlc values + let p = foldl1 (unsafeFromRight .* UPLC.applyProgram) ps + fromRightM (throwError . SomeException) $ + evaluateCekNoEmit PLC.defaultCekParametersForTesting (p ^. UPLC.progTerm) + +runPlcCekTrace + :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) + => [a] + -> ExceptT + SomeException + IO + ( [Text] + , CekExTally PLC.DefaultFun + , UPLC.Term PLC.Name PLC.DefaultUni PLC.DefaultFun () + ) runPlcCekTrace values = do - ps <- traverse toUPlc values - let p = - foldl1 (unsafeFromRight .* UPLC.applyProgram) ps - let (result, TallyingSt tally _, logOut) = runCek PLC.defaultCekParametersForTesting tallying logEmitter (p ^. UPLC.progTerm) - res <- fromRightM (throwError . SomeException) result - pure (logOut, tally, res) - -goldenEvalCek :: ToUPlc a PLC.DefaultUni PLC.DefaultFun => String -> [a] -> TestNested -goldenEvalCek name values = nestedGoldenVsDocM name ".eval-cek" $ prettyPlcClassicDebug <$> (rethrow $ runPlcCek values) - -goldenEvalCekLog :: ToUPlc a PLC.DefaultUni PLC.DefaultFun => String -> [a] -> TestNested -goldenEvalCekLog name values = nestedGoldenVsDocM name ".eval-cek-log" $ pretty . view _1 <$> (rethrow $ runPlcCekTrace values) + ps <- traverse toUPlc values + let p = + foldl1 (unsafeFromRight .* UPLC.applyProgram) ps + let (result, TallyingSt tally _, logOut) = + runCek PLC.defaultCekParametersForTesting tallying logEmitter (p ^. UPLC.progTerm) + res <- fromRightM (throwError . SomeException) result + pure (logOut, tally, res) + +goldenEvalCek :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) => String -> [a] -> TestNested +goldenEvalCek name values = + nestedGoldenVsDocM name ".eval-cek" $ + prettyPlcClassicSimple <$> (rethrow $ runPlcCek values) + +goldenEvalCekLog :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) => String -> [a] -> TestNested +goldenEvalCekLog name values = + nestedGoldenVsDocM name ".eval-cek-log" $ + prettyPlcClassicSimple . view _1 <$> (rethrow $ runPlcCekTrace values) diff --git a/plutus-tx-plugin/test/Plugin/Debug/Spec.hs b/plutus-tx-plugin/test/Plugin/Debug/Spec.hs index 987405909cb..250d29daa59 100644 --- a/plutus-tx-plugin/test/Plugin/Debug/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Debug/Spec.hs @@ -29,7 +29,7 @@ debug = , goldenPirBy config "fib" fib ] where - config = PrettyConfigClassic defPrettyConfigName True + config = PrettyConfigClassic prettyConfigName True letFun :: CompiledCode (Integer -> Integer -> Bool) letFun = diff --git a/plutus-tx-plugin/test/Plugin/Profiling/Spec.hs b/plutus-tx-plugin/test/Plugin/Profiling/Spec.hs index 999acbebbe2..b611b8b7603 100644 --- a/plutus-tx-plugin/test/Plugin/Profiling/Spec.hs +++ b/plutus-tx-plugin/test/Plugin/Profiling/Spec.hs @@ -1,19 +1,25 @@ --- editorconfig-checker-disable-file +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# 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 #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:profile-all #-} --- | Tests for the profiling machinery. +{-# HLINT ignore "Eta reduce" #-} +{-# HLINT ignore "Use guards" #-} +{-# HLINT ignore "Redundant id" #-} +{-# HLINT ignore "Use id" #-} +{-# HLINT ignore "Use const" #-} +-- | Tests for the profiling machinery. module Plugin.Profiling.Spec where import Test.Tasty.Extras @@ -29,22 +35,56 @@ import Data.Proxy (Proxy (Proxy)) import Prelude profiling :: TestNested -profiling = testNested "Profiling" . pure $ testNestedGhc - [ goldenPir "fib" fibTest - , goldenUEvalLogs "fib4" [toUPlc fibTest, toUPlc $ plc (Proxy @"4") (4::Integer)] - , goldenUEvalLogs "fact4" [toUPlc factTest, toUPlc $ plc (Proxy @"4") (4::Integer)] - , goldenPir "addInt" addIntTest - , goldenUEvalLogs "addInt3" [toUPlc addIntTest, toUPlc $ plc (Proxy @"3") (3::Integer)] - , goldenUEvalLogs "letInFun" [toUPlc letInFunTest, toUPlc $ plc (Proxy @"1") (1::Integer), toUPlc $ plc (Proxy @"4") (4::Integer)] - , goldenUEvalLogs "letInFunMoreArg" [toUPlc letInFunMoreArgTest, toUPlc $ plc (Proxy @"1") (1::Integer), toUPlc $ plc (Proxy @"4") (4::Integer), toUPlc $ plc (Proxy @"5") (5::Integer)] - , goldenUEvalLogs "letRecInFun" [toUPlc letRecInFunTest, toUPlc $ plc (Proxy @"3") (3::Integer)] - , goldenPir "idCode" idTest - , goldenUEvalLogs "id" [toUPlc idTest] - , goldenUEvalLogs "swap" [toUPlc swapTest] - , goldenUEvalLogs "typeclass" [toUPlc typeclassTest, toUPlc $ plc (Proxy @"1") (1::Integer), toUPlc $ plc (Proxy @"4") (4::Integer)] - , goldenUEvalLogs "argMismatch1" [toUPlc argMismatch1] - , goldenUEvalLogs "argMismatch2" [toUPlc argMismatch2] - ] +profiling = + testNested "Profiling" . pure $ do + testNestedGhc + [ goldenPir "fib" fibTest + , goldenUEvalLogs + "fib4" + [ toUPlc fibTest + , toUPlc $ plc (Proxy @"4") (4 :: Integer) + ] + , goldenUEvalLogs + "fact4" + [ toUPlc factTest + , toUPlc $ plc (Proxy @"4") (4 :: Integer) + ] + , goldenPir "addInt" addIntTest + , goldenUEvalLogs + "addInt3" + [ toUPlc addIntTest + , toUPlc $ plc (Proxy @"3") (3 :: Integer) + ] + , goldenUEvalLogs + "letInFun" + [ toUPlc letInFunTest + , toUPlc $ plc (Proxy @"1") (1 :: Integer) + , toUPlc $ plc (Proxy @"4") (4 :: Integer) + ] + , goldenUEvalLogs + "letInFunMoreArg" + [ toUPlc letInFunMoreArgTest + , toUPlc $ plc (Proxy @"1") (1 :: Integer) + , toUPlc $ plc (Proxy @"4") (4 :: Integer) + , toUPlc $ plc (Proxy @"5") (5 :: Integer) + ] + , goldenUEvalLogs + "letRecInFun" + [ toUPlc letRecInFunTest + , toUPlc $ plc (Proxy @"3") (3 :: Integer) + ] + , goldenPir "idCode" idTest + , goldenUEvalLogs "id" [toUPlc idTest] + , goldenUEvalLogs "swap" [toUPlc swapTest] + , goldenUEvalLogs + "typeclass" + [ toUPlc typeclassTest + , toUPlc $ plc (Proxy @"1") (1 :: Integer) + , toUPlc $ plc (Proxy @"4") (4 :: Integer) + ] + , goldenUEvalLogs "argMismatch1" [toUPlc argMismatch1] + , goldenUEvalLogs "argMismatch2" [toUPlc argMismatch2] + ] fact :: Integer -> Integer fact n = @@ -56,11 +96,16 @@ factTest :: CompiledCode (Integer -> Integer) factTest = plc (Proxy @"fact") fact 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)) +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)) fibTest :: CompiledCode (Integer -> Integer) -- not using case to avoid literal cases @@ -74,66 +119,70 @@ addIntTest = plc (Proxy @"addInt") addInt -- \x y -> let f z = z + 1 in f x + f y letInFunTest :: CompiledCode (Integer -> Integer -> Integer) -letInFunTest = - plc - (Proxy @"letInFun") - (\(x::Integer) (y::Integer) - -> let f z = Builtins.addInteger z 1 in Builtins.addInteger (f x) (f y)) +letInFunTest = plc (Proxy @"letInFun") do + \(x :: Integer) (y :: Integer) -> + let f z = Builtins.addInteger z 1 in Builtins.addInteger (f x) (f y) -- \x y z -> let f n = n + 1 in z * (f x + f y) letInFunMoreArgTest :: CompiledCode (Integer -> Integer -> Integer -> Integer) -letInFunMoreArgTest = - plc - (Proxy @"letInFun") - (\(x::Integer) (y::Integer) (z::Integer) - -> let f n = Builtins.addInteger n 1 in - Builtins.multiplyInteger z (Builtins.addInteger (f x) (f y))) +letInFunMoreArgTest = plc (Proxy @"letInFun") do + \(x :: Integer) (y :: Integer) (z :: Integer) -> + let f n = Builtins.addInteger n 1 + in Builtins.multiplyInteger z (Builtins.addInteger (f x) (f y)) -- Try a recursive function so it definitely won't be inlined letRecInFunTest :: CompiledCode (Integer -> Integer) -letRecInFunTest = - plc - (Proxy @"letRecInFun") - (\(x::Integer) -> let f n = if Builtins.equalsInteger n 0 then 0 else Builtins.addInteger 1 (f (Builtins.subtractInteger n 1)) in f x) +letRecInFunTest = plc (Proxy @"letRecInFun") do + \(x :: Integer) -> + let f n = + if Builtins.equalsInteger n 0 + then 0 + else Builtins.addInteger 1 (f (Builtins.subtractInteger n 1)) + in f x idTest :: CompiledCode Integer -idTest = plc (Proxy @"id") (id (id (1::Integer))) +idTest = plc (Proxy @"id") do + id (id (1 :: Integer)) -swap :: (a,b) -> (b,a) -swap (a,b) = (b,a) +swap :: (a, b) -> (b, a) +swap (a, b) = (b, a) swapTest :: CompiledCode (Integer, Bool) -swapTest = plc (Proxy @"swap") (swap (True,1)) +swapTest = plc (Proxy @"swap") (swap (True, 1)) --- Two method typeclasses definitely get dictionaries, rather than just being passed as single functions +-- Two method typeclasses definitely get dictionaries, +-- rather than just being passed as single functions class TwoMethods a where - methodA :: a -> a -> Integer - methodB :: a -> a -> Integer + methodA :: a -> a -> Integer + methodB :: a -> a -> Integer instance TwoMethods Integer where - {-# INLINABLE methodA #-} - methodA = Builtins.addInteger - {-# INLINABLE methodB #-} - methodB = Builtins.subtractInteger + {-# INLINEABLE methodA #-} + methodA = Builtins.addInteger + {-# INLINEABLE methodB #-} + methodB = Builtins.subtractInteger -- Make a function that uses the typeclass polymorphically to check that -useTypeclass :: TwoMethods a => a -> a -> Integer +useTypeclass :: (TwoMethods a) => a -> a -> Integer useTypeclass a b = Builtins.addInteger (methodA a b) (methodB a b) -- Check that typeclass methods get traces typeclassTest :: CompiledCode (Integer -> Integer -> Integer) -typeclassTest = plc (Proxy @"typeclass") (\(x::Integer) (y::Integer) -> useTypeclass x y) +typeclassTest = plc (Proxy @"typeclass") do + \(x :: Integer) (y :: Integer) -> useTypeclass x y -{-# INLINABLE newtypeFunction #-} +{-# INLINEABLE newtypeFunction #-} newtypeFunction :: a -> Identity (a -> a) newtypeFunction _ = Identity (\a -> a) argMismatch1 :: CompiledCode Integer -argMismatch1 = plc (Proxy @"argMismatch1") (runIdentity (newtypeFunction 1) 1) +argMismatch1 = plc (Proxy @"argMismatch1") do + runIdentity (newtypeFunction 1) 1 -{-# INLINABLE obscuredFunction #-} +{-# INLINEABLE obscuredFunction #-} obscuredFunction :: (a -> a -> a) -> a -> a -> a obscuredFunction f a = f a argMismatch2 :: CompiledCode Integer -argMismatch2 = plc (Proxy @"argMismatch2") (obscuredFunction (\a _ -> a) 1 2) +argMismatch2 = plc (Proxy @"argMismatch2") do + obscuredFunction (\a _ -> a) 1 2 diff --git a/plutus-tx-plugin/test/StdLib/Spec.hs b/plutus-tx-plugin/test/StdLib/Spec.hs index 8d45fee88f4..0057ab7d3c1 100644 --- a/plutus-tx-plugin/test/StdLib/Spec.hs +++ b/plutus-tx-plugin/test/StdLib/Spec.hs @@ -1,5 +1,6 @@ --- editorconfig-checker-disable-file +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-} @@ -13,32 +14,31 @@ module StdLib.Spec where import Control.DeepSeq (NFData, force) import Control.Exception (SomeException, evaluate, try) +import Control.Monad.Except (runExceptT) import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Proxy (Proxy (..)) import Data.Ratio ((%)) import GHC.Exts (fromString) import Hedgehog (MonadGen, Property) import Hedgehog qualified import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range -import PlutusCore.Test (TestNested, embed, goldenUEval, testNested, testNestedGhc) -import PlutusTx.Test (goldenPir) -import Test.Tasty (TestName) -import Test.Tasty.Hedgehog (testPropertyNamed) - -import PlutusTx.Eq qualified as PlutusTx -import PlutusTx.Ord qualified as PlutusTx -import PlutusTx.Prelude qualified as PlutusTx -import PlutusTx.Ratio qualified as Ratio - +import PlutusCore.Data qualified as PLC +import PlutusCore.MkPlc qualified as Core +import PlutusCore.Test (TestNested, embed, runUPlc, testNested, testNestedGhc) +import PlutusPrelude (reoption) import PlutusTx.Builtins.Internal (BuiltinData (BuiltinData)) import PlutusTx.Code (CompiledCode, getPlcNoAnn) +import PlutusTx.Eq qualified as PlutusTx import PlutusTx.Lift qualified as Lift +import PlutusTx.Ord qualified as PlutusTx import PlutusTx.Plugin (plc) - -import PlutusCore.Data qualified as PLC - -import Data.Proxy (Proxy (Proxy)) -import PlutusPrelude (reoption) +import PlutusTx.Prelude qualified as PlutusTx +import PlutusTx.Ratio qualified as Ratio +import PlutusTx.Test (goldenPir) +import Test.Tasty (TestName, TestTree) +import Test.Tasty.Hedgehog (testPropertyNamed) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) roundPlc :: CompiledCode (Ratio.Rational -> Integer) roundPlc = plc (Proxy @"roundPlc") Ratio.round @@ -46,7 +46,7 @@ roundPlc = plc (Proxy @"roundPlc") Ratio.round tests :: TestNested tests = testNested "StdLib" . pure $ testNestedGhc - [ goldenUEval "ratioInterop" [ getPlcNoAnn roundPlc, snd (Lift.liftProgramDef (Ratio.fromGHC 3.75)) ] + [ embed testRatioInterop , testRatioProperty "round" Ratio.round round , testRatioProperty "truncate" Ratio.truncate truncate , testRatioProperty "abs" (fmap Ratio.toGHC Ratio.abs) abs @@ -66,8 +66,17 @@ tryHard :: (MonadIO m, NFData a) => a -> m (Maybe a) -- the body, i.e. outside of the call to 'try', defeating the whole purpose. tryHard ~a = reoption <$> (liftIO $ try @SomeException $ evaluate $ force a) -testRatioProperty :: (Show a, Eq a) => TestName -> (Ratio.Rational -> a) -> (Rational -> a) -> TestNested -testRatioProperty nm plutusFunc ghcFunc = embed $ testPropertyNamed nm (fromString nm) $ Hedgehog.property $ do +testRatioInterop :: TestTree +testRatioInterop = testCase "ratioInterop" do + runExceptT (runUPlc [getPlcNoAnn roundPlc, snd (Lift.liftProgramDef (Ratio.fromGHC 3.75))]) + >>= \case + 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 nm plutusFunc ghcFunc = + embed $ testPropertyNamed nm (fromString nm) $ Hedgehog.property $ do rat <- Hedgehog.forAll $ Gen.realFrac_ (Range.linearFrac (-10000) 100000) let ghcResult = ghcFunc rat plutusResult = plutusFunc $ Ratio.fromGHC rat diff --git a/plutus-tx/testlib/PlutusTx/Test.hs b/plutus-tx/testlib/PlutusTx/Test.hs index c6fe9b747e0..edc247bf3b2 100644 --- a/plutus-tx/testlib/PlutusTx/Test.hs +++ b/plutus-tx/testlib/PlutusTx/Test.hs @@ -52,6 +52,7 @@ import PlutusCore.Pretty import PlutusCore.Pretty qualified as PLC import PlutusCore.Test import PlutusIR.Analysis.Builtins as PIR +import PlutusIR.Core.Instance.Pretty.Readable (prettyPirReadableSimple) import PlutusIR.Core.Type (progTerm) import PlutusIR.Test () import PlutusIR.Transform.RewriteRules as PIR @@ -122,7 +123,7 @@ goldenPir :: String -> CompiledCodeIn uni fun a -> TestNested -goldenPir name value = nestedGoldenVsDoc name ".pir" $ pretty $ getPirNoAnn value +goldenPir name value = nestedGoldenVsDoc name ".pir" $ prettyPirReadableSimple $ getPirNoAnn value -- | Does not print uniques. goldenPirReadable :: @@ -132,7 +133,7 @@ goldenPirReadable :: TestNested goldenPirReadable name value = nestedGoldenVsDoc name ".pir" - . maybe "PIR not found in CompiledCode" (pretty . AsReadable . view progTerm) + . maybe "PIR not found in CompiledCode" (prettyPirReadableSimple . view progTerm) $ getPirNoAnn value goldenPirBy :: @@ -143,25 +144,24 @@ goldenPirBy :: TestNested goldenPirBy config name value = nestedGoldenVsDoc name ".pir" $ - pretty $ - AttachPrettyConfig config $ - getPir value + prettyBy config $ getPir value -- Evaluation testing -- TODO: rationalize with the functions exported from PlcTestUtils goldenEvalCek :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) => String -> [a] -> TestNested goldenEvalCek name values = - nestedGoldenVsDocM name ".eval" $ prettyPlcClassicDebug <$> (rethrow $ runPlcCek values) + nestedGoldenVsDocM name ".eval" $ prettyPlcClassicSimple <$> rethrow (runPlcCek values) goldenEvalCekCatch :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) => String -> [a] -> TestNested goldenEvalCekCatch name values = nestedGoldenVsDocM name ".eval" $ - either (pretty . show) prettyPlcClassicDebug <$> runExceptT (runPlcCek values) + either (pretty . show) prettyPlcClassicSimple <$> runExceptT (runPlcCek values) goldenEvalCekLog :: (ToUPlc a PLC.DefaultUni PLC.DefaultFun) => String -> [a] -> TestNested goldenEvalCekLog name values = - nestedGoldenVsDocM name ".eval" $ pretty . view _1 <$> (rethrow $ runPlcCekTrace values) + nestedGoldenVsDocM name ".eval" $ + prettyPlcClassicSimple . view _1 <$> (rethrow $ runPlcCekTrace values) -- Helpers