Refactor/testing io monad

grammars/silver/compiler/extension/testing/MainTestSuite.sv

@@ -9,6 +9,10 @@ import silver:compiler:definition:type:syntax;
 import silver:compiler:modification:ffi;
 import silver:compiler:modification:collection;
 import silver:compiler:modification:list;
+import silver:compiler:modification:copper;
+
+import silver:compiler:extension:convenience;
+import silver:compiler:extension:do_notation hiding DoDoubleColon_t;
 
 terminal MainTestSuite_t 'mainTestSuite' lexer classes {KEYWORD};
 terminal MakeTestSuite_t 'makeTestSuite' lexer classes {KEYWORD};
@@ -55,104 +59,30 @@ top::AGDcl ::= 'mainTestSuite' nme::IdLower_t ';'
 {
   top.unparse = "mainTestSuite " ++ nme.lexeme ++ ";\n";
 
-  forwards to 
-  appendAGDcl(
-   functionDcl(
-    -- function main
-    'function', name("main"),
-    -- IOVal<Integer> ::= args::[String]  mainIO::IOToken
-    functionSignature(
-      nilConstraint(), '=>',
-     functionLHS(
-       appTypeExpr(
-         nominalTypeExpr(qNameTypeId(terminal(IdUpper_t, "IOVal"))),
-         bTypeList('<', typeListSingle(integerTypeExpr('Integer')), '>'))),
-     '::=',
-     productionRHSCons(
-      productionRHSElemType(elemNotShared(), listTypeExpr('[', stringTypeExpr('String'), ']')),
-      productionRHSCons(
-       productionRHSElem(
-        elemNotShared(),
-        name("mainIO"),
-        '::', typerepTypeExpr(ioForeignType)),
-       productionRHSNil()))),
-    -- body::ProductionBody 
-   productionBody('{',
-    foldl(productionStmtsSnoc(_, _), productionStmtsNil(), [
-     --  local testResults :: TestSuite;
-     localAttributeDcl(
-      'local', 'attribute', name("testResults"), '::',
-      nominalTypeExpr( qNameTypeId(terminal(IdUpper_t,"TestSuite"))), ';'),
-     -- testResults = name()
-     valueEq( qName("testResults"), '=', 
-                 applicationEmpty( baseExpr( qNameId(nameIdLower(nme))), 
-                  '(', ')'),
-                 ';'),
-     -- testResults.ioIn = ...
-     attributeDef( 
-         concreteDefLHS( qName("testResults")), '.', qNameAttrOccur(qName("ioIn")),
-         '=', mkNameExpr("mainIO"), ';'),
-     -- return ...
-     returnDef('return',
-        mkStrFunctionInvocation("ioval",
-         [
-          mkStrFunctionInvocation("exitT",
-           [ attrAcc("testResults","numFailed"),
-             mkStrFunctionInvocation("printT",
-              [ foldStringExprs(
-                 [ strCnst("\n\n"),
-                   strCnst("============================================================\n"),
-                   strCnst("Test Results:\n"), 
-                   attrAcc("testResults","msg"),
-                   strCnst("\n\n"), 
-                   strCnst("Passed "), 
-                   Silver_Expr { silver:core:integerToString(testResults.numPassed) },
-                   strCnst(" tests out of "), 
-                   Silver_Expr { silver:core:integerToString(testResults.numTests) },
-                   strCnst("\n"), 
-                   strCnst("============================================================\n") 
-                 ]),
-                attrAcc("testResults", "ioOut")
-              ])
-           ]),
-           intConst( terminal(Int_t, "0")) 
-         ]), 
-         ';')
-    ]), '}')),
-
-  makeTestSuite_p( 'makeTestSuite', nme, ';'));
-}
-
-
-{-
-function main
-IOToken ::= args::String mainIO::IOToken
-{
- local testResults :: TestSuite = core_tests();
- testResults.ioIn = mainIO;
-
- return
-   exitT( testResults.numTests - testResults.numPassed,
-     printT("\n\n" ++
-            "============================================================\n" ++
-            "Test results: \n" ++
-            testResults.msg ++ "\n\n" ++ 
-            "Passed " ++ toString(testResults.numPassed) ++
-            " tests out of " ++ 
-            toString(testResults.numTests) ++ "\n" ++
-            "============================================================\n",
-            testResults.ioOut) 
-);
-}
+  local mainDcl::AGDcl = Silver_AGDcl {
+    function main
+    IOVal<Integer> ::= args::[String] mainIO::IOToken
+    {
+      local testResults :: TestSuite = $QName{qNameId(nameIdLower(nme))}();
+      testResults.ioIn = mainIO;
+
+      return evalIO(
+        do {
+          print("\n\n" ++
+                "============================================================\n" ++
+                "Test results: \n" ++
+                testResults.msg ++ "\n\n" ++ 
+                "Passed " ++ toString(testResults.numPassed) ++
+                " tests out of " ++ 
+                toString(testResults.numTests) ++ "\n" ++
+                "============================================================\n");
+
+          exit( testResults.numTests - testResults.numPassed );    
+        },
+        testResults.ioOut
+      );
+    }
+  };
 
-abstract production core_tests
-t::TestSuite ::= 
-{
- forwards to tsAsNT;
- local tsAsNT :: TestSuite = testsAsNT( testsToPerform);
- production attribute testsToPerform :: [ Test ] with ++;
- testsToPerform := [ ];
+  forwards to appendAGDcl(@mainDcl, makeTestSuite_p( 'makeTestSuite', nme, ';'));
 }
-
-mainTestSuite core_tests;
--}

grammars/silver/testing/ParsingTests.sv

@@ -0,0 +1,84 @@
+grammar silver:testing;
+
+abstract production parseOnlyTestAfterCPP
+t::Test ::= fn::String parseF::(ParseResult<a> ::= String String)
+{
+
+  local act :: EitherT<String IO ()> = do {
+    exists    :: Boolean <- lift(isFile(fn));
+    unless(exists, fail("File \"" ++ fn ++ "\" not found.\n"));
+
+    let cppCommand :: String
+    = -- "cpp -P " ++ fn ++ " | tail -n +3 > " ++ fn ++ ".cpp" ;
+        "cpp " ++ fn ++ " > " ++ fn ++ ".cpp" ;
+    -- even the -P option to cpp leaves 2 blanks lines, so we also
+    -- use tail to remove these blank lines
+
+    mkCPPfile :: Integer <- lift(system(cppCommand));
+    unless(mkCPPfile == 0, fail(
+      "The cpp process failed with error code " ++ 
+      toString(mkCPPfile) ++ "\n" ++
+      "The cpp command was:\n" ++ cppCommand ++ "\n"));
+
+    text      :: String <- lift(readFile(fn++".cpp"));
+    let pr    :: ParseResult<a> = parseF(text, fn);
+
+    unless(pr.parseSuccess, fail("Parser error: " ++ pr.parseErrors ++ "\n"));
+  };
+
+  local msg :: IOVal<Either<String ()>> = evalIO(act.run, t.ioIn);
+
+  t.pass = msg.iovalue.isLeft;
+
+  t.msg = fromLeft(msg.iovalue, "");
+
+  t.ioOut = msg.io;
+
+}
+
+
+abstract production parseOnlyTest
+t::Test ::= fn::String parseF::(ParseResult<a> ::= String String)
+{
+  local act :: EitherT<String IO ()> = do {
+    exists  :: Boolean <- lift(isFile(fn));
+    unless(exists, fail("File \"" ++ fn ++ "\" not found.\n"));
+
+    text    :: String <- lift(readFile(fn));
+    let pr  :: ParseResult<a> = parseF(text, fn);
+    unless(pr.parseSuccess, fail("Parser error: " ++ pr.parseErrors ++ "\n"));
+  };
+
+  local msg :: IOVal<Either<String ()>> = evalIO(act.run, t.ioIn);
+
+  t.pass = msg.iovalue.isLeft;
+
+  t.msg = fromLeft(msg.iovalue, "");
+
+  t.ioOut = msg.io;
+
+}
+
+abstract production parseFailTest
+t::Test ::= fn::String parseF::(ParseResult<a> ::= String String)
+{
+  local act :: EitherT<String IO ()> = do {
+    exists  :: Boolean <- lift(isFile(fn));
+
+    unless(exists, fail("File \"" ++ fn ++ "\" not found.\n"));
+
+    text    :: String <- lift(readFile(fn));
+    let pr  :: ParseResult<a> = parseF(text, fn);
+    unless(pr.parseSuccess, fail("Error: File should not be parseable."));
+  };
+
+  local msg :: IOVal<Either<String ()>> = evalIO(act.run, t.ioIn);
+
+  t.pass = msg.iovalue.isLeft;
+
+  t.msg = fromLeft(msg.iovalue, "");
+
+  t.ioOut = msg.io;
+
+}
+

grammars/silver/testing/bin/Main.sv

@@ -3,31 +3,23 @@ grammar silver:testing:bin ;
 import silver:testing;
 
 function main
-IOVal<Integer> ::= args::[String] ioIn::IOToken
-{ return
-   -- if true then printDirs(initDirs, ioIn) else
-   -- uncomment above line to just experiment with the traverse function
-   -- when used for printing directories.
-   ioval(
-    printT( "============================================================\n" ++
-           (if   runTests.iovalue.numFailed == 0
+IO<Integer> ::= args::[String]
+{ 
+  local attribute initDirs :: [ String ] ;
+  initDirs = map(cleanDirName, args) ;
+
+  return do {
+    startDir <- cwd();
+    runTests :: TestingResults <- traverseDirectoriesAndPerform
+                    ( startDir, initDirs, runTest, dirSkip, pure(testingResults(0)) );
+    print("============================================================\n" ++
+           (if   runTests.numFailed == 0
             then "All tests passed. \n"
-            else toString(runTests.iovalue.numFailed) ++ 
+            else toString(runTests.numFailed) ++ 
                  " tests failed. \n") ++
-           "============================================================\n"
-         , runTests.io ) 
-       , runTests.iovalue.numFailed  )
-  ;
-
- local runTests :: IOVal<TestingResults> 
-  = traverseDirectoriesAndPerform
-      ( startDir.iovalue, initDirs, runTest, dirSkip,
-        ioval(startDir.io, testingResults(0) ) );
-
- local startDir :: IOVal<String> = cwdT(ioIn) ;
-
- local attribute initDirs :: [ String ] ;
- initDirs = map(cleanDirName, args) ; -- was  explode(" ",args)) ;
+           "============================================================\n");
+    return runTests.numFailed;
+  };
 }
 
 function cleanDirName
@@ -44,4 +36,4 @@ String ::= dirName::String
                       "somewhere as a directory name now ends with a sapce. \n"
                      )
           else dirName ;
-}
+}