Cleanup Tests

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,
     typed-process >=0.2.10.1 && <0.3,
     tasty ==1.5,
     tasty-hunit

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: " ++)

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

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

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

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.
 

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.
 

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,17 +70,16 @@ 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)
 
 (#) :: PLCTerm -> PLCTerm -> PLCTerm
 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 () 

src/Language/Purus/Make.hs

@@ -359,6 +359,32 @@ compileDirNoEvalTest path = do
        hClose h
   pure $ testGroup "PIR Compilation (No Eval)" testCases 
 
+-- Makes a TestTree. Should probably be in the test dir but don't feel like sorting out imports there
+compileDirNoEvalTest' :: FilePath -> IO [(String,IO ())]
+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
+  forM allDecls $ \(runModuleName -> mn, declNm) -> do
+    let outFilePath = path </> T.unpack mn <> "_pir_no_eval.txt"
+        testNm = path <> " - " <> T.unpack mn <> ":" <> T.unpack declNm
+    (testNm,) <$> do
+     withFile outFilePath AppendMode $ \h -> pure $ 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
+
+
 compileDirEvalTest :: FilePath -> IO TestTree
 compileDirEvalTest path = do
   allDecls <- allValueDeclarations path

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