basic PLC test infrastructure

purescript.cabal

@@ -209,6 +209,8 @@ common defaults
     sourcemap >=0.1.7 && <0.2,
     stm >=2.5.0.2 && <2.6,
     stringsearch >=0.3.6.6 && <0.4,
+    tasty,
+    tasty-hunit,
     template-haskell >=2.18.0.0 && <2.19,
     text >=1.2.5.0 && <2.3,
     th-abstraction,
@@ -255,7 +257,7 @@ library
     Language.PureScript.CoreFn.Convert.DesugarObjects
     Language.PureScript.CoreFn.Convert.Plated
     Language.PureScript.CoreFn.Convert.IR
-     Language.PureScript.CoreFn.Convert.ToPIR
+    Language.PureScript.CoreFn.Convert.ToPIR
     Language.PureScript.CoreFn.CSE
     Language.PureScript.CoreFn.Desugar
     Language.PureScript.CoreFn.Desugar.Utils
@@ -483,11 +485,13 @@ test-suite tests
   build-depends:
     purescript,
     purs-lib,
+    flat,
     generic-random >=1.5.0.1 && <1.6,
     hspec >= 2.10.7 && < 3,
     HUnit >=1.6.2.0 && <1.7,
     newtype >=0.2.2.0 && <0.3,
     QuickCheck >=2.14.2 && <2.15,
+    plutus-core,
     regex-base >=0.94.0.2 && <0.95,
     split >=0.2.3.4 && <0.3,
     typed-process >=0.2.10.1 && <0.3

src/Language/PureScript/CoreFn/Convert/ToPIR.hs

@@ -48,6 +48,11 @@ import PlutusCore qualified as PLC
 import Control.Exception
 import Data.List (sortOn)
 import Control.Lens ((&),(.~),ix)
+import PlutusCore.Evaluation.Machine.Ck
+import PlutusCore.Evaluation.Machine.ExBudgetingDefaults qualified as PLC
+import Test.Tasty
+import Test.Tasty.HUnit
+
 type PLCProgram uni fun a = PLC.Program PLC.TyName PLC.Name uni fun (Provenance a)
 
 fuckThisMonadStack ::
@@ -66,11 +71,24 @@ fuckThisMonadStack x  =
             join $ flip runReader ctx $ runQuoteT $ runExceptT $ runExceptT x
       in  first  show res
 
+runPLCProgram :: PLCProgram DefaultUni DefaultFun () -> (EvaluationResult (PLC.Term TyName Name DefaultUni DefaultFun ()),[Text])
+runPLCProgram (PLC.Program a b c) = unsafeEvaluateCk PLC.defaultBuiltinsRuntime $ void c
+
+runPLCProgramTest :: String
+                  -> (EvaluationResult (PLC.Term TyName Name DefaultUni DefaultFun ()),[Text])
+                  -> FilePath
+                  -> Text
+                  -> TestTree
+runPLCProgramTest testName expected path decl  = testCase testName $ do
+  prog <- declToUPLC path decl
+  let out = runPLCProgram prog
+  assertEqual "program output matches expected "  expected out
 
-runPIR :: FilePath
+
+declToUPLC :: FilePath
        -> Text
        -> IO (PLCProgram  DefaultUni DefaultFun ())
-runPIR path decl = prepPIR path decl >>= \case
+declToUPLC path decl = prepPIR path decl >>= \case
   (mainExpr,dict) -> do
     tcMap <- rethrowIO $ mkTyConMap dict
     ctorMap <- rethrowIO $ mkConstructorMap dict
@@ -281,8 +299,6 @@ toPIR f = \case
    assembleScrutinee :: PIRTerm -> Ty ->  [Alt Exp x] -> State ConvertState (Term TyName Name DefaultUni DefaultFun ())
    assembleScrutinee scrut tx  alts = do
      let _binders = IR.getPat <$> alts
-        -- TODO: remove when implementing multi scrutinee
-         binders =  map head _binders
      alted <-  unzip <$> traverse (locally . goAlt tx) alts
      let sopSchema = head . fst $ alted
          ctorNumberedBranches = snd alted
@@ -329,18 +345,13 @@ toPIR f = \case
              goCtorArgs [(t,VarP nm)] = do
                nm' <- mkTermName (runIdent nm)
                t' <- toPIRType t
-               pure $ LamAbs () nm' t' undefined
+               pure $ LamAbs () nm' t' res
              goCtorArgs ((t,VarP nm):rest) = do
                nm' <- mkTermName (runIdent nm)
                t' <- toPIRType t
                rest' <- goCtorArgs rest
                pure $ LamAbs () nm' t' rest'
 
-
-
-
-
-
        -- NOTE: We don't have force/delay in PIR so I think we have to use type abstraction/instantiation
        -- force ((\cond -> IfThenElse cond (delay caseT) (delay caseF)) cond)
        -- TyInst _

src/Language/PureScript/CoreFn/Expr.hs

@@ -19,6 +19,16 @@ import Control.Lens (Traversal', Lens')
 
 type PurusType = SourceType -- Type ()
 
+{- TODO: IMPORTANT!!!!
+
+   REMOVE THE TYPE ANNOTATION FROM APPLICATIONS.
+
+   I don't know why I did that but it's never necessary and it is the source of
+   endless stupid problems.
+
+
+-}
+
 -- |
 -- Data type for expressions and terms
 --

tests/TestPurus.hs

@@ -13,15 +13,26 @@ import System.FilePath.Glob qualified as Glob
 import Data.Function (on)
 import Data.List (sort, sortBy, stripPrefix, groupBy, find)
 import Control.Exception.Base
-import Language.PureScript.CoreFn.Convert.ToPIR (runPIR)
+import Language.PureScript.CoreFn.Convert.ToPIR
+import PlutusCore.Core
+import Test.Tasty
+import PlutusCore.Evaluation.Machine.Ck (EvaluationResult(..))
+import PlutusCore
+import PlutusCore.Default
 
 shouldPassTests :: IO ()
 shouldPassTests = do
   traverse_ runPurusDefault shouldPass
   let misc =  "./tests/purus/passing/Misc/output/Lib/index.cfn"
-  uplc1 <- runPIR misc "main"
+  uplc1 <- declToUPLC misc "main"
+  defaultMain $
+    runPLCProgramTest
+    "mainTest"
+    (EvaluationSuccess (Constant () (Some (ValueOf DefaultUniInteger 2))),[])
+    misc
+    "main"
   writeFile "./tests/purus/passing/Misc/output/Lib/main.plc" (show uplc1)
-  uplc2 <- runPIR misc "minus"
+  uplc2 <- declToUPLC misc "minus"
   writeFile "./tests/purus/passing/Misc/output/Lib/fakeminus.plc" (show uplc2)
 
 runPurus :: P.CodegenTarget -> FilePath ->  IO ()

tests/purus/passing/Misc/Lib.purs

@@ -117,6 +117,11 @@ aStringLit = "woop"
 aVal :: Int
 aVal = 1
 
+testasum :: ASum -> Int
+testasum x = case x of
+  Constr1 y -> 1
+  Constr2 z -> 2
+
 
 aBool :: Boolean
 aBool = true

tests/purus/passing/Misc/output/Lib/index.cfn.pretty

@@ -32,6 +32,7 @@ Exports:
   anIntLit,
   aStringLit,
   aVal,
+  testasum,
   aBool,
   aList,
   aFunction,
@@ -128,6 +129,13 @@ eq2IntBoolean =
                                                             }): (Eq2$Dict
   Int Boolean))
 
+testasum :: ASum -> Int
+testasum = 
+  \(x: ASum) -> 
+    case (x: ASum) of 
+       Constr1 y -> (1: Int)
+       Constr2 z -> (2: Int)
+
 testBuiltin :: Int
 testBuiltin = ((addInteger: Int -> Int -> Int) (1: Int) (2: Int): Int)
 

tests/purus/passing/Misc/output/cache-db.json

@@ -1 +1 @@
-{"Lib":{"tests/purus/passing/Misc/Lib.purs":["2024-03-23T04:32:51.16219073Z","29c80a631685fa294c0e4598b638156014729534f1208e2b077577b1ab3e57304161c1a863d85958a2691b45929f29ef5858f9cda5d4bc9ac10ee0d6565fc197"]}}
+{"Lib":{"tests/purus/passing/Misc/Lib.purs":["2024-03-26T03:50:35.378009063Z","67df09cb956fddb301a943d3a9301de86d847d195a18b89760b52ee0a7b2a07277a7ea8dda1c56e39db6fb013f871c71b63e44bde504f27e89c6eb8fe5f7b4e0"]}}