diff --git a/purescript.cabal b/purescript.cabal index 46f3062d..e5ae0ead 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -526,6 +526,7 @@ test-suite tests plutus-core ==1.30.0.0, regex-base >=0.94.0.2 && <0.95, split >=0.2.3.4 && <0.3, + stm >=2.5.0.2 && <2.6, typed-process >=0.2.10.1 && <0.3, tasty ==1.5, tasty-hunit diff --git a/purs-lib/Command/Compile.hs b/purs-lib/Command/Compile.hs index 9cd29b37..7b6fb8f6 100644 --- a/purs-lib/Command/Compile.hs +++ b/purs-lib/Command/Compile.hs @@ -23,6 +23,7 @@ import System.Directory (getCurrentDirectory) import System.FilePath.Glob (glob) import System.IO (hPutStr, hPutStrLn, stderr, stdout) import System.IO.UTF8 (readUTF8FilesT) +import Language.PureScript.Errors (MultipleErrors(..)) data PSCMakeOptions = PSCMakeOptions { pscmInput :: [FilePath] @@ -72,6 +73,7 @@ compile PSCMakeOptions{..} = do printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors exitSuccess +-- No warnings (makes tests output impossible to read) compileForTests :: PSCMakeOptions -> IO () compileForTests PSCMakeOptions{..} = do included <- globWarningOnMisses warnFileTypeNotFound pscmInput @@ -83,13 +85,13 @@ compileForTests PSCMakeOptions{..} = do ] else do moduleFiles <- readUTF8FilesT input - (makeErrors, makeWarnings) <- runMake pscmOpts $ do + (makeErrors, _) <- runMake pscmOpts $ do ms <- CST.parseModulesFromFiles id moduleFiles let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms foreigns <- inferForeignModules filePathMap let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix P.make makeActions (map snd ms) - printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles makeWarnings makeErrors + printWarningsAndErrors (P.optionsVerboseErrors pscmOpts) pscmJSONErrors moduleFiles (MultipleErrors []) makeErrors warnFileTypeNotFound :: String -> IO () warnFileTypeNotFound = hPutStrLn stderr . ("purs compile: No files found using pattern: " ++) diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs index efbce13b..de448589 100644 --- a/src/Language/PureScript/CST/Convert.hs +++ b/src/Language/PureScript/CST/Convert.hs @@ -85,11 +85,9 @@ srcTokenRange = tokRange . tokAnn type signature in scope when we convert the declaration. -} -groupSignaturesAndDeclarations :: (Show a) => [Declaration a] -> [[Declaration a]] +groupSignaturesAndDeclarations :: [Declaration a] -> [[Declaration a]] groupSignaturesAndDeclarations [] = [] -groupSignaturesAndDeclarations decls = - trace ("DECLARATIONS (grouping): \n" <> concatMap ((<> "\n\n") . show) decls) $ - go kindSigs typeSigs decls' +groupSignaturesAndDeclarations decls = go kindSigs typeSigs decls' where ((kindSigs, typeSigs), decls') = foldr diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs index d60a41d0..5c00e190 100644 --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -166,7 +166,6 @@ moduleToCoreFn (A.Module modSS coms mn _decls (Just exps)) = do decls' <- concat <$> traverse (declToCoreFn mn) nonDataDecls let dataDecls' = mkDataDecls mn dataDecls result = Module modSS coms mn (spanName modSS) imports exps' reExps externs decls' dataDecls' - traceM $ prettyStr dataDecls' pure $ result where setModuleName = modify $ \cs -> @@ -219,10 +218,8 @@ lookupType sp tn = do Nothing -> case M.lookup (mkQualified tn mn) (names env) of Nothing -> error $ "No type found for " <> show tn Just (ty, _, nv) -> do - traceM $ "lookupType: " <> showIdent' tn <> " :: " <> ppType 10 ty pure (ty, nv) Just (ty, _, nv) -> do - traceM $ "lookupType: " <> showIdent' tn <> " :: " <> ppType 10 ty pure (ty, nv) getInnerListTy :: Type a -> Maybe (Type a) @@ -238,7 +235,6 @@ getInnerObjectTy _ = Nothing objectToCoreFn :: forall m. (M m) => ModuleName -> SourceSpan -> SourceType -> SourceType -> [(PSString, A.Expr)] -> m (Expr Ann) objectToCoreFn mn ss recTy row objFields = do - traceM $ "ObjLitTy: " <> show row let (tyFields, _) = rowToList row tyMap = M.fromList $ (\x -> (runLabel (rowListLabel x), x)) <$> tyFields resolvedFields <- foldM (go tyMap) [] objFields diff --git a/src/Language/PureScript/CoreFn/Desugar/Utils.hs b/src/Language/PureScript/CoreFn/Desugar/Utils.hs index 957bb428..94d92d58 100644 --- a/src/Language/PureScript/CoreFn/Desugar/Utils.hs +++ b/src/Language/PureScript/CoreFn/Desugar/Utils.hs @@ -562,8 +562,7 @@ binderToCoreFn dict env mn _ss (A.LiteralBinder ss lit) = binderToCoreFn _ _ _ ss A.NullBinder = NullBinder (ss, [], Nothing) binderToCoreFn dict _ _ _ss vb@(A.VarBinder ss name) = - trace ("binderToCoreFn: " <> show vb) $ - VarBinder (ss, [], Nothing) name (dict M.! name) + VarBinder (ss, [], Nothing) name (dict M.! name) binderToCoreFn dict env mn _ss (A.ConstructorBinder ss dctor@(Qualified mn' _) bs) = let (_, tctor, _, _) = lookupConstructor env dctor args = binderToCoreFn dict env mn _ss <$> bs diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs index 16d77ae1..b000d2d4 100644 --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -133,11 +133,10 @@ rebuildModuleWithIndex MakeActions {..} exEnv externs m@(Module _ _ moduleName _ regrouped <- createBindingGroups moduleName . collapseBindingGroups $ deguarded let mod' = Module ss coms moduleName regrouped exps - traceM $ "PURUS START HERE: " <> T.unpack (runModuleName moduleName) + --traceM $ "PURUS START HERE: " <> T.unpack (runModuleName moduleName) -- pTrace regrouped -- pTrace exps ((coreFn, chkSt'), nextVar'') <- runSupplyT nextVar' $ runStateT (CFT.moduleToCoreFn mod') chkSt -- (emptyCheckState env') - traceM . T.unpack $ CFT.prettyModuleTxt coreFn let corefn = coreFn (optimized, nextVar''') = runSupply nextVar'' $ CF.optimizeCoreFn corefn (renamedIdents, renamed) = renameInModule optimized @@ -162,16 +161,7 @@ rebuildModuleWithIndex MakeActions {..} exEnv externs m@(Module _ _ moduleName _ evalSupplyT nextVar''' $ codegen renamed docs exts return exts - where - prettyEnv :: Environment -> String - prettyEnv Environment {..} = M.foldlWithKey' goPretty "" names - where - goPretty acc ident (ty, _, _) = - acc - <> "\n" - <> T.unpack (showQualified showIdent ident) - <> " :: " - <> ppType 10 ty + {- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.cbor@ file. diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index c76603ea..2aaa4863 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -80,6 +80,7 @@ import Language.PureScript.Types import Debug.Trace import Language.PureScript.Pretty.Values (renderValue) import Language.Purus.Pretty.Types (prettyTypeStr) +import Language.PureScript.Constants.Prim qualified as C moduleTraces :: Bool moduleTraces = False @@ -216,7 +217,7 @@ typesOf bindingGroupType moduleName vals = goTrace ("TYPESOF: " <> T.unpack (run finalState <- get let replaceTypes' = replaceTypes (checkSubstitution finalState) runTypeSearch' gen = runTypeSearch (guard gen $> foldMap snd inferred) finalState - raisePreviousWarnings gen = escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes') + raisePreviousWarnings gen = escalateWarningWhen (\er -> isHoleError er || isIncompleteCoverageError er) . tell . onErrorMessages (runTypeSearch' gen . replaceTypes') raisePreviousWarnings False wInfer forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> @@ -259,6 +260,10 @@ typesOf bindingGroupType moduleName vals = goTrace ("TYPESOF: " <> T.unpack (run isHoleError (ErrorMessage _ HoleInferredType {}) = True isHoleError _ = False + isIncompleteCoverageError :: ErrorMessage -> Bool + isIncompleteCoverageError (ErrorMessage _ (NoInstanceFound (Constraint _ C.Partial _ _ (Just PartialConstraintData{})) _ _ )) = True + isIncompleteCoverageError _ = False + {- | A binding group contains multiple value definitions, some of which are typed and some which are not. diff --git a/src/Language/Purus/Eval.hs b/src/Language/Purus/Eval.hs index 0ccdb13f..8b0595ec 100644 --- a/src/Language/Purus/Eval.hs +++ b/src/Language/Purus/Eval.hs @@ -2,8 +2,11 @@ module Language.Purus.Eval ( compileToUPLC, compileToUPLCTerm, + convertToUPLCAndEvaluate, evaluateUPLCTerm, evaluateTerm, + evaluateTermU_, + evaluateTermU, parseData, (#), applyArgs, @@ -22,7 +25,7 @@ import Control.Monad (join, void) import Control.Monad.Reader (Reader, runReader) import Control.Monad.Trans.Except (ExceptT, runExceptT) -import Language.Purus.Types (PIRTerm, PLCTerm) +import Language.Purus.Types (PIRTerm, PLCTerm, UPLCTerm) import PlutusCore ( getDefTypeCheckConfig, @@ -36,7 +39,6 @@ import PlutusCore.Default ( ) import PlutusCore.Evaluation.Machine.Ck ( EvaluationResult (EvaluationFailure, EvaluationSuccess), - unsafeToEvaluationResult, evaluateCk ) import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC @@ -45,10 +47,20 @@ import PlutusIR.Compiler (CompilationCtx, Compiling, compileProgram, compileToRe import PlutusIR.Compiler.Provenance (Provenance (Original)) import PlutusIR.Compiler.Types (coDoSimplifierRemoveDeadBindings) import PlutusIR.Error (Error) -import Control.Lens (over, set) -import System.IO (readFile) +import Control.Lens (set) import PlutusCore.Data qualified as PLC import PlutusCore.MkPlc (mkConstant) +import PlutusCore.Evaluation.Machine.ExBudget ( + ExBudget (ExBudget), + ExRestrictingBudget (ExRestrictingBudget), + minusExBudget, + ) +import PlutusCore.Compiler.Erase (eraseTerm) +import UntypedPlutusCore.DeBruijn ( deBruijnTerm ) +import PlutusCore.Evaluation.Machine.ExBudgetingDefaults (defaultCekParametersForTesting) +import PlutusCore.Evaluation.Machine.ExMemory (ExCPU (ExCPU), ExMemory (ExMemory)) +import UntypedPlutusCore.Evaluation.Machine.Cek qualified as Cek +import Language.Purus.Pretty.Common (prettyStr) type PLCProgram uni fun a = PLC.Program PLC.TyName PLC.Name uni fun (Provenance a) @@ -58,8 +70,8 @@ type PLCProgram uni fun a = PLC.Program PLC.TyName PLC.Name uni fun (Provenance {- Evaluates a UPLC Program -} runPLCProgram :: PLCProgram DefaultUni DefaultFun () -> (EvaluationResult PLCTerm, [Text]) -runPLCProgram (PLC.Program _ _ c) = case evaluateCk PLC.defaultBuiltinsRuntimeForTesting . void $ c of - (result, logs) -> case result of +runPLCProgram (PLC.Program _ _ c) = case evaluateCk PLC.defaultBuiltinsRuntimeForTesting . void $ c of + (result, logs) -> case result of Left _ -> (EvaluationFailure, logs) Right t -> (EvaluationSuccess t, logs) @@ -67,8 +79,7 @@ runPLCProgram (PLC.Program _ _ c) = case evaluateCk PLC.defaultBuiltinsRuntimeFo f # a = PLC.Apply () f a applyArgs :: PLCTerm -> [PLCTerm] -> PLCTerm -applyArgs f [] = f -applyArgs f (arg:args) = applyArgs (f # arg) args +applyArgs f args = foldl (#) f args -- Parse a file containing a "show'd" piece of Data into a PLC term. -- Mainly for testing but might have some other uses. @@ -85,6 +96,11 @@ dummyData = mkConstant () $ PLC.I 0 evaluateTerm :: PIRTerm -> IO (EvaluationResult (PLC.Term PLC.TyName Name DefaultUni DefaultFun ()), [Text]) evaluateTerm term = runPLCProgram <$> compileToUPLC term +convertToUPLCAndEvaluate :: PIRTerm -> IO () +convertToUPLCAndEvaluate t = evaluateTerm t >>= \case + (EvaluationSuccess plcTerm ,_) -> evaluateTermU_ reasonablySizedBudget plcTerm + (EvaluationFailure,logs) -> error (show logs) + {- Compile a PIR Term to a UPLC Program-} compileToUPLC :: PIRTerm -> IO (PLCProgram DefaultUni DefaultFun ()) compileToUPLC e = do @@ -98,7 +114,7 @@ compileToUPLCTerm e = compileToUPLC e >>= \case PLC.Program a b c -> pure (void c) evaluateUPLCTerm :: PLCTerm -> IO (EvaluationResult PLCTerm, [Text]) -evaluateUPLCTerm e = do +evaluateUPLCTerm e = do let input = PLC.Program (Original ()) latestVersion (Original <$> e) withErrors = either (throwIO . userError) pure pure $ runPLCProgram input @@ -127,3 +143,40 @@ runCompile x = -> CompilationCtx DefaultUni DefaultFun () disableDeadCodeElimination = set (ccOpts . coDoSimplifierRemoveDeadBindings ) False + +toDeBruijnUPLC :: PLCTerm -> Either String UPLCTerm +toDeBruijnUPLC t = first prettyStr x + where + x :: Either (Error DefaultUni DefaultFun ()) UPLCTerm + x = deBruijnTerm (eraseTerm t) + +reasonablySizedBudget :: ExBudget +reasonablySizedBudget = ExBudget (ExCPU 100000000) (ExMemory 100000) + + +-- stolen from plutarch + +evaluateTermU :: + ExBudget -> + PLCTerm -> + Either (String, Maybe ExBudget, [Text]) (UPLCTerm,ExBudget,[Text]) +evaluateTermU budget t = case toDeBruijnUPLC t of + Left err -> Left (err, Nothing, []) + Right uplc -> case Cek.runCekDeBruijn defaultCekParametersForTesting (Cek.restricting (ExRestrictingBudget budget)) Cek.logEmitter uplc of + (errOrRes, Cek.RestrictingSt (ExRestrictingBudget final), logs) -> case errOrRes of + Left err -> Left (show err, Just $ budget `minusExBudget` final, logs) + Right res -> Right (res, budget `minusExBudget` final, logs) + +-- for tests +evaluateTermU_ :: + ExBudget -> + PLCTerm -> + IO () +evaluateTermU_ budget t = case evaluateTermU budget t of + Left (msg,mBudg,logs) -> do + let prettyErr = "Failed to evaluate term\nError Message:\n" <> msg <> + (case mBudg of + Nothing -> "" + Just resBudg -> "\nCost: " <> prettyStr resBudg <> "\nLog: " <> prettyStr logs) + throwIO $ userError prettyErr + Right _ -> pure () diff --git a/src/Language/Purus/Make.hs b/src/Language/Purus/Make.hs index 07f43ff9..f8b121aa 100644 --- a/src/Language/Purus/Make.hs +++ b/src/Language/Purus/Make.hs @@ -1,35 +1,30 @@ {-# LANGUAGE TypeApplications #-} -module Language.Purus.Make where +module Language.Purus.Make (compile, make, allValueDeclarations) where import Prelude -import Control.Exception (throwIO) import Data.Text (Text) import Data.Text qualified as T -import Data.Text.Lazy qualified as LT import Data.Map qualified as M import Data.Set qualified as S import Data.Function (on) -import Control.Exception -import Control.Monad (forM) -import Data.Foldable (foldrM, forM_) -import Data.List (delete, foldl', groupBy, sortBy, stripPrefix, find) +import Control.Exception ( throwIO ) +import Data.Foldable (foldrM) +import Data.List (delete, foldl', groupBy, sortBy, stripPrefix) import System.FilePath ( makeRelative, - takeBaseName, takeDirectory, takeExtensions, (), ) -import System.IO import Language.PureScript.CoreFn.Ann (Ann) -import Language.PureScript.CoreFn.Expr (Bind (..), PurusType, cfnBindIdents) +import Language.PureScript.CoreFn.Expr (Bind (..), PurusType) import Language.PureScript.CoreFn.Module (Module (..)) import Language.PureScript.Names ( Ident (Ident), @@ -38,8 +33,7 @@ import Language.PureScript.Names ( runModuleName, ) -import Language.Purus.Eval -import Language.Purus.IR.Utils (IR_Decl, foldBinds, stripSkolemsFromExpr) +import Language.Purus.IR.Utils (IR_Decl, foldBinds) import Language.Purus.Pipeline.CompileToPIR (compileToPIR) import Language.Purus.Pipeline.DesugarCore (desugarCoreModule) import Language.Purus.Pipeline.DesugarObjects ( @@ -63,13 +57,12 @@ import Language.Purus.Pipeline.Monad ( runPlutusContext, ) import Language.Purus.Pretty.Common (prettyStr, docString) -import Language.Purus.Prim.Data (primDataPS, primData) -import Language.Purus.Types (PIRTerm, PLCTerm, initDatatypeDict) +import Language.Purus.Prim.Data (primDataPS) +import Language.Purus.Types (PIRTerm, initDatatypeDict) import Language.Purus.Utils ( decodeModuleIO, - findDeclBodyWithIndex, findMain, + findDeclBodyWithIndex, ) -import Language.Purus.Make.Prim (syntheticPrim) import Language.Purus.Pipeline.EliminateCases.EliminateNested (eliminateNestedCases) import Control.Monad.Except (MonadError (throwError), when) @@ -84,22 +77,8 @@ import Algebra.Graph.AdjacencyMap.Algorithm (topSort) import System.FilePath.Glob qualified as Glob -import PlutusCore.Evaluation.Result (EvaluationResult(..)) import PlutusIR.Core.Instance.Pretty.Readable (prettyPirReadable) - -import Language.Purus.Pipeline.Lift.Types -import System.Directory - - -import Debug.Trace (traceM) -import Language.Purus.IR (expTy) - --- TODO: Move the stuff that needs this to the tests -import Test.Tasty -import Test.Tasty.HUnit --- import PlutusIR.Core.Instance.Pretty.Readable (prettyPirReadable) - {- Compiles a main function to PIR, given its module name, dependencies, and a Prim module that will be compiled before anything else. (This is kind of a hack-ey shim to let us write e.g. serialization functions and provide them by default without a @@ -243,30 +222,6 @@ make path mainModule mainFunction primModule = do (Nothing, m : ms) -> either (throwIO . userError) pure $ compile m ms (ModuleName mainModule) (Ident mainFunction) _ -> throwIO . userError $ "Error: No modules found for compilation" --- for exploration/repl testing, this hardcodes `tests/purus/passing/Lib` as the target directory and --- we only select the name of the main function -makeForTest :: Text -> IO PIRTerm -makeForTest main = make "tests/purus/passing/CoreFn/Misc" "Lib" main (Just syntheticPrim) - - - -{- Takes a path to a Purus project directory, the name of - a target module, and a list of expression names and - compiles them to PIR. - - Assumes that the directory already contains an "output" directory with serialized - CoreFn files --} -evalForTest_ :: Text -> IO () -evalForTest_ main = (fst <$> evalForTest main) >>= \case - EvaluationSuccess res -> pure () -- print $ prettyPirReadable res - _ -> error $ "failed to evaluate " <> T.unpack main - -evalForTest :: Text -> IO (EvaluationResult PLCTerm, [Text]) -evalForTest main = do - pir <- makeForTest main - -- traceM . docString $ prettyPirReadable pir - evaluateTerm pir -- TODO put this somewhere else note :: (MonadError String m) => String -> Maybe a -> m a @@ -274,33 +229,6 @@ note msg = \case Nothing -> throwError msg Just x -> pure x -makeTestModule :: FilePath -> IO [(Text,PIRTerm)] -makeTestModule path = do - mdl@Module{..} <- decodeModuleIO path - let toTest :: [Ident] - toTest = concatMap cfnBindIdents moduleDecls - nm = runModuleName moduleName - goCompile = pure . compile syntheticPrim [mdl] moduleName - forM toTest $ \x -> goCompile x >>= \case - Left err -> error $ "Error while compiling " <> T.unpack (runIdent x) <> "\nReason: " <> err - Right res -> pure (runIdent x,res) - -evalTestModule :: FilePath -> IO () -evalTestModule path = do - made <- makeTestModule path - putStrLn $ "Starting evaluation of: " <> prettyStr (fst <$> made) - evaluated <- flip traverse made $ \(x,e) -> do - res <- fst <$> evaluateTerm e - pure (x,res) - forM_ evaluated $ \(eNm,eRes) -> case eRes of - EvaluationFailure -> putStrLn $ "\n\n> FAIL: Failed to evaluate " <> T.unpack eNm - EvaluationSuccess res -> do - putStrLn $ "\n\n> SUCCESS: Evaluated " <> T.unpack eNm - print $ prettyPirReadable res - -sanityCheck :: IO () -sanityCheck = evalTestModule "tests/purus/passing/CoreFn/Misc/output/Lib/Lib.cfn" - -- takes a path to a project dir, returns (ModuleName,Decl Identifier) allValueDeclarations :: FilePath -> IO [(ModuleName,Text)] allValueDeclarations path = do @@ -310,112 +238,3 @@ allValueDeclarations path = do NonRec _ ident _ -> [(mn,runIdent ident)] Rec xs -> map (\((_,ident),_) -> (mn,runIdent ident)) xs pure $ concatMap (\(mdl,dcls) -> concatMap (go mdl) dcls) allDecls - -compileDirNoEval :: FilePath -> IO () -compileDirNoEval path = do - allDecls <- allValueDeclarations path - let allModuleNames = runModuleName . fst <$> allDecls - forM_ allModuleNames $ \mn -> do - let outFilePath = path T.unpack mn <> "_pir_no_eval.txt" - outFileExists <- doesFileExist outFilePath - when outFileExists $ - removeFile outFilePath - forM_ allDecls $ \(runModuleName -> mn, declNm) -> do - let outFilePath = path T.unpack mn <> "_pir_no_eval.txt" - withFile outFilePath AppendMode $ \h -> do - result <- make path mn declNm (Just syntheticPrim) - let nmStr = T.unpack declNm - pirStr = docString $ prettyPirReadable result - msg = "\n------ " <> nmStr <> " ------\n" - <> pirStr - <> "\n------------\n" - -- putStrLn msg - hPutStr h msg - hClose h - --- Makes a TestTree. Should probably be in the test dir but don't feel like sorting out imports there -compileDirNoEvalTest :: FilePath -> IO TestTree -compileDirNoEvalTest path = do - allDecls <- allValueDeclarations path - let allModuleNames = runModuleName . fst <$> allDecls - forM_ allModuleNames $ \mn -> do - let outFilePath = path T.unpack mn <> "_pir_no_eval.txt" - outFileExists <- doesFileExist outFilePath - when outFileExists $ - removeFile outFilePath - testCases <- forM allDecls $ \(runModuleName -> mn, declNm) -> do - let outFilePath = path T.unpack mn <> "_pir_no_eval.txt" - testNm = path <> " - " <> T.unpack mn <> ":" <> T.unpack declNm - pure $ testCase testNm $ do - withFile outFilePath AppendMode $ \h -> do - result <- make path mn declNm (Just syntheticPrim) - let nmStr = T.unpack declNm - pirStr = docString $ prettyPirReadable result - msg = "\n------ " <> nmStr <> " ------\n" - <> pirStr - <> "\n------------\n" - -- putStrLn msg - hPutStr h msg - hClose h - pure $ testGroup "PIR Compilation (No Eval)" testCases - -compileDirEvalTest :: FilePath -> IO TestTree -compileDirEvalTest path = do - allDecls <- allValueDeclarations path - let allModuleNames = runModuleName . fst <$> allDecls - forM_ allModuleNames $ \mn -> do - let outFilePath = path T.unpack mn <> "_pir_eval.txt" - outFileExists <- doesFileExist outFilePath - when outFileExists $ - removeFile outFilePath - testCases <- forM allDecls $ \(runModuleName -> mn, declNm) -> do - let outFilePath = path T.unpack mn <> "_pir_eval.txt" - testNm = path <> " - " <> T.unpack mn <> ":" <> T.unpack declNm - pure $ testCase testNm $ do - withFile outFilePath AppendMode $ \h -> do - result <- snd <$> (evaluateTerm =<< make path mn declNm (Just syntheticPrim)) - let nmStr = T.unpack declNm - pirStr = prettyStr result - msg = "\n------ " <> nmStr <> " ------\n" - <> pirStr - <> "\n------------\n" - hPutStr h msg - hClose h - pure $ testGroup "PIR Evaluation" testCases - -compileModuleNoEval :: FilePath -> IO () -compileModuleNoEval path = do - let baseName = takeBaseName path - pathDir = takeDirectory path - outFilePath = pathDir baseName "_pir_decls_no_eval.txt" - mdl <- decodeModuleIO path - removeFile outFilePath - withFile outFilePath AppendMode $ \h -> do - made <- makeTestModule path - forM_ made $ \(nm,pirterm) -> do - let nmStr = T.unpack nm - pirStr = docString $ prettyPirReadable pirterm - origStr = unsafeFindDeclStr mdl nm - msg = "\n\n------ " <> nmStr <> " ------\n\n" - <> "Original coreFn declaration:\n" <> origStr - <> "\n\nCompiled PIR expression:\n" <> pirStr - <> "\n------------\n" - putStrLn msg - hPutStr h msg - hClose h - where - findDecl :: Ident -> [Bind Ann] -> Maybe (Bind Ann) - findDecl _ [] = Nothing - findDecl i (bnd@(NonRec _ i' _):bs) - | i == i' = Just bnd - | otherwise = findDecl i bs - findDecl i (Rec xs:bs) = case find (\x -> snd (fst x) == i) xs of - Nothing -> findDecl i bs - Just ((a,_),body) -> Just $ NonRec a i body - - unsafeFindDeclStr :: Module (Bind Ann) PurusType PurusType Ann - -> Text - -> String - unsafeFindDeclStr mdl nm = case findDecl (Ident nm) (moduleDecls mdl) of - Nothing -> "error: couldn't find a declaration for " <> prettyStr nm - Just bnd -> prettyStr bnd diff --git a/src/Language/Purus/Types.hs b/src/Language/Purus/Types.hs index 214dcef5..699ea5ce 100644 --- a/src/Language/Purus/Types.hs +++ b/src/Language/Purus/Types.hs @@ -20,6 +20,7 @@ import PlutusCore qualified as PLC import PlutusIR qualified as PIR import Control.Lens.TH (makeLenses) +import UntypedPlutusCore qualified as UPLC type PIRDatatype = PIR.Datatype @@ -34,6 +35,8 @@ type PIRTerm = PIR.Term PIR.TyName PIR.Name PLC.DefaultUni PLC.DefaultFun () type PLCTerm = PLC.Term PLC.TyName PLC.Name PLC.DefaultUni PLC.DefaultFun () +type UPLCTerm = UPLC.Term UPLC.NamedDeBruijn PLC.DefaultUni PLC.DefaultFun () + data DatatypeDictionary = DatatypeDictionary { _pirDatatypes :: Map (Qualified (ProperName 'TypeName)) PIRDatatype -- ^ The datatype declarations & their corresponding PS type name diff --git a/tests/TestPurus.hs b/tests/TestPurus.hs index 0402deba..c3c4a4d2 100644 --- a/tests/TestPurus.hs +++ b/tests/TestPurus.hs @@ -1,36 +1,59 @@ {-# LANGUAGE TypeApplications #-} -module TestPurus where +module TestPurus (shouldPassTests) where import Prelude import Data.Text (Text) +import Data.Text qualified as T import Command.Compile ( compileForTests, PSCMakeOptions(..) ) -import Control.Monad (when,unless) +import Control.Monad (when,unless, void) import System.FilePath + ( makeRelative, (), takeDirectory, takeExtensions ) import Language.PureScript qualified as P import Data.Set qualified as S -import Data.Foldable (traverse_) -import System.Directory +import System.Directory + ( createDirectory, + doesDirectoryExist, + listDirectory, + removeDirectoryRecursive ) import System.FilePath.Glob qualified as Glob import Data.Function (on) import Data.List (sortBy, stripPrefix, groupBy) -import Language.Purus.Make +import Language.Purus.Make ( allValueDeclarations, make ) import Language.Purus.Eval -import Language.Purus.Types -import PlutusCore.Evaluation.Result -import PlutusIR.Core.Instance.Pretty.Readable (prettyPirReadable) -import Test.Tasty -import Test.Tasty.HUnit + ( applyArgs, + parseData, + dummyData, + evaluateTerm, + convertToUPLCAndEvaluate, + compileToUPLCTerm, + evaluateUPLCTerm ) +import Language.Purus.Types ( PIRTerm ) +import Test.Tasty + ( TestTree, + defaultMain, + withResource, + sequentialTestGroup, + testGroup, + DependencyType(AllFinish) ) +import Test.Tasty.HUnit ( testCase, assertFailure ) import Language.Purus.Make.Prim (syntheticPrim) +import Language.PureScript (ModuleName, runModuleName) +import Control.Concurrent.STM + ( atomically, TVar, newTVarIO, readTVarIO, modifyTVar' ) +import Data.Map (Map) +import Data.Map qualified as M +import Unsafe.Coerce ( unsafeCoerce ) +import Control.Exception (SomeException, try, Exception (displayException)) shouldPassTests :: IO () shouldPassTests = do - cfn <- coreFnTests - pirNoEval <- pirTestsNoEval - pirEval <- pirTestsEval - let validatorTest = testCase "validator apply/eval" mkValidatorTest - policyTest = testCase "minting policy apply/eval" mkMintingPolicyTest - defaultMain $ sequentialTestGroup "Purus Tests" AllFinish [cfn,pirNoEval,pirEval,validatorTest,policyTest] - + generatedTests <- mkShouldPassTests "tests/purus/passing/CoreFn" + let allTests = testGroup "Passing" [generatedTests,validatorTest,mintingPolicyTest] + defaultMain allTests + +{- The PureScript -> CoreFn part of the pipeline. Need to run this to output the CoreFn + files which the other tests depend upon. (The Purus pipeline starts by parsing those CoreFn files) +-} runPurusCoreFn :: P.CodegenTarget -> FilePath -> IO () runPurusCoreFn target dir = do outDirExists <- doesDirectoryExist outputDir @@ -49,97 +72,116 @@ runPurusCoreFn target dir = do pscmInput = files, pscmExclude = [], pscmOutputDir = outputDir, - pscmOpts = purusOpts, + pscmOpts = unsafeCoerce purusOpts, -- IT IS THE RIGHT TYPE BUT HLS WILL NOT SHUT UP ABOUT IT pscmUsePrefix = False, pscmJSONErrors = False } purusOpts :: P.Options purusOpts = P.Options { - optionsVerboseErrors = True, + optionsVerboseErrors = False, optionsNoComments = True, optionsCodegenTargets = S.singleton target } --- TODO: Move modules into a directory specifically for PIR non-eval tests (for now this should be OK) -pirTestsNoEval :: IO TestTree -pirTestsNoEval = do - let coreFnTestPath = "tests/purus/passing/CoreFn" - allTestDirectories <- listDirectory coreFnTestPath - trees <- mapM (\dir -> compileDirNoEvalTest (coreFnTestPath dir)) allTestDirectories-- allTestDirectories - pure $ sequentialTestGroup "PIR Tests (No Evaluation)" AllFinish trees - -pirTestsEval :: IO TestTree -pirTestsEval = do - let coreFnTestPath = "tests/purus/passing/CoreFn" - allTestDirectories <- listDirectory coreFnTestPath - trees <- mapM (\dir -> compileDirEvalTest (coreFnTestPath dir)) allTestDirectories-- allTestDirectories - pure $ sequentialTestGroup "PIR Tests (Evaluation)" AllFinish trees --- path to a Purus project directory, outputs serialized CoreFn -compileToCoreFnTest :: FilePath -> TestTree -compileToCoreFnTest path = testCase (path) $ runPurusCoreFnDefault path - -coreFnTests :: IO TestTree -coreFnTests = do - let coreFnTestPath = "tests/purus/passing/CoreFn" - allTestDirectories <- listDirectory coreFnTestPath - let trees = map (\dir -> compileToCoreFnTest (coreFnTestPath dir)) allTestDirectories - pure $ sequentialTestGroup "CoreFn Tests" AllFinish trees +{- Generated PIR non-evaluation tests (i.e. only checks that the *Purus* pipeline reaches the PIR stage, + does not typecheck/compile/evaluate PIR). + The TVar should be passed in empty. The path should be the full path to the project directory. The + list of declarations is passed in primarily to make the types line up (can't write this without + returning an IO [TestTree] if we don't pass it in afaict) +-} +-- TODO? withResource? We can do it w/ the TVar arg I think +mkPIRNoEval :: TVar (Map (ModuleName,Text) PIRTerm) -> FilePath -> [(ModuleName,Text)] -> [TestTree] +mkPIRNoEval tv path ioInput = mkCase <$> ioInput + where + mkCase :: (ModuleName, Text) -> TestTree + mkCase (mn'@(runModuleName -> mn),dn) = testCase testName $ do + term <- make path mn dn (Just syntheticPrim) + atomically $ modifyTVar' tv (M.insert (mn',dn) term) + where + testName = T.unpack mn <> "." <> T.unpack dn -runPurusCoreFnDefault :: FilePath -> IO () -runPurusCoreFnDefault path = runPurusCoreFn P.CoreFn path +{- Generates automated evaluation tests. + + The first argument is an evaluation function. We want this as parameter so we can use (e.g.) + variants that don't throw an error if the execution budget is exceeded. -runPurusGolden :: FilePath -> IO () -runPurusGolden path = runPurusCoreFn P.CheckCoreFn path + Second argument is the name of the test tree being generated. -runFullPipeline_ :: FilePath -> Text -> Text -> IO () -runFullPipeline_ targetDir mainModuleName mainFunctionName = do - runPurusCoreFnDefault targetDir - pir <- make targetDir mainModuleName mainFunctionName Nothing - result <- evaluateTerm pir - print $ prettyPirReadable result + Third argument is a TVar which should be *full* (i.e. non-empty) -runFullPipeline :: FilePath -> Text -> Text -> IO (EvaluationResult PLCTerm, [Text]) -runFullPipeline targetDir mainModuleName mainFunctionName = do - runPurusCoreFnDefault targetDir - pir <- make targetDir mainModuleName mainFunctionName Nothing - evaluateTerm pir + Fourth argument is a list of declarations, which, as before, is mainly used to make the types line up. +-} +mkPIREvalMany :: (PIRTerm -> IO ()) + -> String + -> TVar (Map (ModuleName,Text) PIRTerm) + -> [(ModuleName,Text)] + -> TestTree +mkPIREvalMany f nm tv decls = withResource (readTVarIO tv) (\_ -> pure ()) $ \tvIO -> + testGroup nm $ mkPIREval1 tvIO <$> decls + where + mkPIREval1 :: IO (Map (ModuleName,Text) PIRTerm) -> (ModuleName,Text) -> TestTree + mkPIREval1 dict declNm@(runModuleName -> mn,dn) = do + let testName = T.unpack mn <> "." <> T.unpack dn + testCase testName $ do + dict' <- dict + case M.lookup declNm dict' of + Nothing -> error $ "failure: no PIRTerm compiled at " <> show testName + Just term -> void $ f term + +{- Full pipeline tests for things we expect will succeed at the CoreFn -> PIR -> PLC -> UPLC -> Evaluation + path. Reads from the modules in the `tests/purus/passing/CoreFn` directory. + + All functions tested here *should terminate*. +-} +mkShouldPassTests :: FilePath -> IO TestTree +mkShouldPassTests testDirPath = do + allProjectDirectories <- listDirectory testDirPath + testGroup "Generated (Passing)" <$> traverse (go . (testDirPath )) allProjectDirectories + where + go :: FilePath -> IO TestTree + go path = try @SomeException initialize >>= \case + Left err -> pure . testCase ("PIR: " <> show path) $ assertFailure ("Failed during CoreFn compilation with reason: " <> displayException err) + Right decls -> do + declDict <- newTVarIO M.empty + let pirNoEval = testGroup "No Eval" $ mkPIRNoEval declDict path decls + pirEvalPlc = mkPIREvalMany (void . evaluateTerm) "Eval (PLC)" declDict decls + pirEvalUplc = mkPIREvalMany convertToUPLCAndEvaluate "Eval (UPLC)" declDict decls + pure $ sequentialTestGroup ("PIR: " <> show path) AllFinish [pirNoEval,pirEvalPlc,pirEvalUplc] + where + initialize :: IO [(ModuleName,Text)] + initialize = do + void $ runPurusCoreFnDefault path + allValueDeclarations path + +{- Runs the PureScript -> CoreFn part of the compiler pipeline in default mode (i.e. not in Golden mode, i.e. + this actually writes output files in the project directories) +-} +runPurusCoreFnDefault :: FilePath -> IO () +runPurusCoreFnDefault path = runPurusCoreFn P.CoreFn path -mkValidatorTest :: IO () -mkValidatorTest = do +{- Manual tests for scripts. These require us to apply arguments and parse an example script context. +-} +-- TODO: Change these so they run through the UPLC evaluator using the new machinery +validatorTest :: TestTree +validatorTest = testCase "Basic Validator Test" $ do scriptContext <- parseData "sampleContext" - -- Data -> Data -> Data -> wBoolean + -- Data -> Data -> Data -> Boolean validatorPIR <- make "tests/purus/passing/CoreFn/Validator" "Validator" "validate" (Just syntheticPrim) validatorPLC <- compileToUPLCTerm validatorPIR let validatorApplied = applyArgs validatorPLC [dummyData,dummyData,scriptContext] res <- evaluateUPLCTerm validatorApplied print res -mkMintingPolicyTest :: IO () -mkMintingPolicyTest = do +mintingPolicyTest :: TestTree +mintingPolicyTest = testCase "Basic Minting Policy Test" $ do scriptContext <- parseData "sampleContext" policyPIR <- make "tests/purus/passing/CoreFn/MintingPolicy" "MintingPolicy" "oneAtATime" (Just syntheticPrim) policyPLC <- compileToUPLCTerm policyPIR let policyApplied = applyArgs policyPLC [dummyData,dummyData,scriptContext] res <- evaluateUPLCTerm policyApplied print res -{- These assumes that name of the main module is "Main" and the - name of the main function is "Main". - - For now this recompiles everything from scratch --} - -runDefaultCheckEvalSuccess :: String -> FilePath -> Assertion -runDefaultCheckEvalSuccess nm targetDir - = (fst <$> runFullPipeline targetDir "Main" "main") >>= assertBool nm . isEvaluationSuccess - -runDefaultEvalTest :: String -> FilePath -> PLCTerm -> Assertion -runDefaultEvalTest nm targetDir expected - = (fst <$> runFullPipeline targetDir "Main" "main") >>= \case - EvaluationSuccess resTerm -> assertEqual nm expected resTerm - EvaluationFailure -> assertFailure nm - getTestFiles :: FilePath -> IO [[FilePath]] getTestFiles testDir = do diff --git a/tests/purus/passing/NonTerminating/TestInliner.purs b/tests/purus/passing/NonTerminating/TestInliner.purs new file mode 100644 index 00000000..e69de29b diff --git a/tests/purus/passing/ShouldFail/Misc/IncompleteCases.purs b/tests/purus/passing/ShouldFail/Misc/IncompleteCases.purs new file mode 100644 index 00000000..56c138f3 --- /dev/null +++ b/tests/purus/passing/ShouldFail/Misc/IncompleteCases.purs @@ -0,0 +1,8 @@ +module IncompleteCses where + +testIncompleteCases :: Int -> Int +testIncompleteCases = case _ of + 0 -> 0 + 1 -> 1 + 2 -> 2 + 3 -> 3