Run tests on both unoptimized and optimized code

Dockerfile

@@ -1,4 +1,4 @@
-FROM fpco/stack-build:lts-20.14
+FROM fpco/stack-build:lts-21.25
 ENV TROUPE /Troupe
 ENV STACK_OPTS --system-ghc
 WORKDIR $TROUPE

compiler/app/Main.hs

@@ -10,19 +10,19 @@ import qualified CaseElimination as C
 import System.Environment
 import Util.FileUtil
 import qualified ClosureConv as CC
-import qualified IR as CCIR 
+import qualified IR as CCIR
 -- import qualified IROpt
 -- import qualified RetRewrite as Rewrite
 import qualified CPSOpt as CPSOpt
-import qualified IR2JS 
-import qualified IR2Raw 
+import qualified IR2JS
+import qualified IR2Raw
 -- import qualified Stack 
 import qualified Raw2Stack
-import qualified Stack2JS 
+import qualified Stack2JS
 import qualified RawOpt
 -- import System.IO (isEOF)
 import qualified Data.ByteString as BS
-import Data.ByteString.Base64 (decode) 
+import Data.ByteString.Base64 (decode)
 import qualified Data.ByteString.Char8  as BSChar8
 import qualified Data.ByteString.Lazy.Char8 as BSLazyChar8
 import System.IO
@@ -48,16 +48,18 @@ data Flag
   = IRMode
   | JSONIRMode
   | LibMode
+  | NoRawOpt
   | OutputFile String
   | Verbose
   | Help
-  | Debug 
+  | Debug
   deriving (Show, Eq)
 
 options :: [OptDescr Flag]
 options =
   [ Option ['i']      ["ir"]     (NoArg IRMode)              "ir interactive mode"
   , Option ['j']      ["json"]   (NoArg JSONIRMode)          "ir json interactive mode"
+  , Option []         ["no-rawopt"] (NoArg NoRawOpt) "disable Raw optimization"
   , Option ['v']      ["verbose"] (NoArg Verbose)            "verbose output"
   , Option ['d']      ["debug"]  (NoArg Debug)               "debugging information in the .js file"
   , Option ['l']      ["lib"]    (NoArg LibMode)             "compiling a library"
@@ -76,7 +78,8 @@ process flags fname input = do
         if elem LibMode flags then Export
         else Normal
 
-  let verbose = elem Verbose flags
+  let verbose = Verbose `elem` flags
+      noRawOpt = NoRawOpt `elem` flags
 
   case ast of
     Left err -> do
@@ -146,24 +149,29 @@ process flags fname input = do
 
       ----- RAW OPT --------------------------------------
 
-      let rawopt = RawOpt.rawopt raw
-      when verbose $ printSep  "OPTIMIZING RAW OPT"
-      when verbose $ writeFileD "out/out.rawopt" (show rawopt)
+      rawopt <- do
+            if noRawOpt
+            then return raw
+            else do
+              let opt = RawOpt.rawopt raw
+              when verbose $ printSep  "OPTIMIZING RAW OPT"
+              when verbose $ writeFileD "out/out.rawopt" (show opt)
+              return opt
 
       ----- STACK ----------------------------------------
-      let stack = Raw2Stack.rawProg2Stack rawopt 
+      let stack = Raw2Stack.rawProg2Stack rawopt
       when verbose $ printSep "GENARTING STACK"
       when verbose $ writeFileD "out/out.stack" (show stack)
-      let stackjs = Stack2JS.irProg2JSString compileMode debugOut stack 
+      let stackjs = Stack2JS.irProg2JSString compileMode debugOut stack
       let jsFile = outFile flags (fromJust fname)
-      writeFile jsFile stackjs 
+      writeFile jsFile stackjs
+
 
-
       case exports of
         Nothing -> return ()
         Just es -> writeExports jsFile es
       when verbose printHr
-      
+
       exitSuccess
 
 

compiler/stack.yaml

@@ -18,7 +18,7 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-20.14
+resolver: lts-21.25
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.

compiler/test/Golden.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE RecordWildCards #-}
+
 import Test.Tasty (defaultMain, TestTree, testGroup)
 import Test.Tasty.Golden (goldenVsStringDiff,  goldenVsString, findByExtension)
 import System.Directory
@@ -10,6 +12,17 @@ import System.Info
 import System.Environment 
 -- import qualified System.IO.Strict
 
+-- When having multiple optimizations / optional compiler stages or
+-- other flags changing the output, probably want to generate all combinations
+-- and run the tests on them.
+newtype TestConfig = TestConfig { tcRawOpt :: Bool }
+
+ppTestConfig TestConfig{..} =
+    if tcRawOpt
+    then "Raw optimized"
+    else "Raw NOT optimized"
+
+
 getOptionalInput :: String -> IO String 
 getOptionalInput testfile = do 
     inputExists <- doesFileExist $ testfile ++ ".input"
@@ -20,52 +33,66 @@ getOptionalInput testfile = do
         return ""        
 
 
+mkRunArgs :: TestConfig -> [String]
+mkRunArgs TestConfig{..} =
+  if tcRawOpt
+  then []
+  else ["--no-rawopt"]
 
-runLocal testname = do 
-    input <- getOptionalInput testname 
-    readProcessWithExitCode "./local.sh" [testname] input
+runLocal :: String -> TestConfig -> IO (ExitCode, String, String)
+runLocal testname tc = do
+    input <- getOptionalInput testname
+    readProcessWithExitCode "./local.sh" (mkRunArgs tc ++ [testname]) input
 
 -- We use this to test the commands with timeouts.
 -- Observe the current value for the timeout is 2 seconds.
 
-runTimeout n testname = do 
-    let timeout = if os == "darwin" then "gtimeout" else "timeout"        
-    readProcessWithExitCode timeout [show n, "./local.sh", testname] ""
+runTimeout :: Int -> String -> TestConfig -> IO (ExitCode, String, String)
+runTimeout n testname tc = do
+    let timeout = if os == "darwin" then "gtimeout" else "timeout"
+    readProcessWithExitCode timeout ([show n, "./local.sh"] ++ mkRunArgs tc ++ [testname]) ""
 
 
-runPositiveTimeout :: Int -> String -> IO LBS.ByteString 
-runPositiveTimeout t testname = do 
-    (code, out, err) <- runTimeout t testname 
+runPositiveTimeout :: Int -> String -> TestConfig -> IO LBS.ByteString
+runPositiveTimeout t testname tc = do
+    (code, out, err) <- runTimeout t testname tc
     case code of 
         ExitFailure _ -> return $ (LBS.fromStrict . Data.ByteString.Char8.pack) (out ++ err)
         ExitSuccess -> fail testname 
 
 
 
-runPositive :: String -> IO LBS.ByteString 
-runPositive testname = do 
-    (code, out, err) <- runLocal testname 
+runPositive :: String -> TestConfig -> IO LBS.ByteString
+runPositive testname tc = do
+    (code, out, err) <- runLocal testname tc
     case code of 
         ExitSuccess -> return $ (LBS.fromStrict . Data.ByteString.Char8.pack) out
         ExitFailure _ -> fail testname 
 
 
-runNegative :: String -> IO LBS.ByteString 
-runNegative testname = do 
-    (code, out, err) <- runLocal testname 
+runNegative :: String -> TestConfig -> IO LBS.ByteString
+runNegative testname tc = do
+    (code, out, err) <- runLocal testname tc
     case code of 
         ExitFailure _ -> return $ (LBS.fromStrict . Data.ByteString.Char8.pack) err
         ExitSuccess -> fail testname 
 
 
 main :: IO () 
-main = do 
+main = do
          troupeDir <- getEnv "TROUPE"
          setCurrentDirectory troupeDir
-         defaultMain =<< goldenTests 
+         -- Create tests
+         tests <- mapM goldenTests
+           [ TestConfig { tcRawOpt = True }
+           , TestConfig { tcRawOpt = False }
+           ]
+         -- Run tests
+         defaultMain $ testGroup "Troupe golden tests" tests
 
 
-goldenTests = do 
+goldenTests :: TestConfig -> IO TestTree
+goldenTests tc = do
     let extensions =  [".trp", ".pico", ".atto", ".picox", ".femto"] 
     negativeTestsForCompiler <- findByExtension extensions "tests/cmp"
     positiveTestsForRuntime  <- findByExtension extensions "tests/rt/pos"
@@ -74,19 +101,19 @@ goldenTests = do
     timeoutTestsForRuntime   <- findByExtension extensions "tests/rt/timeout/blocking"
     divergingTestsForRuntime <- findByExtension extensions "tests/rt/timeout/diverging"
 
-    return $ (testGroup "Troupe golden tests" 
+    return $ (testGroup ("Troupe golden tests (" ++ ppTestConfig tc ++ ")") $ map ($ tc)
                                 [ compilerTests negativeTestsForCompiler
                                 , runtimeTests $ concat [positiveTestsForRuntime, negativeTestsForRuntime, warningTestsForRuntime]
                                 , timeoutTests timeoutTestsForRuntime
                                 , divergingTests divergingTestsForRuntime ] )
 
 
-compilerTests testFiles =
+compilerTests testFiles tc =
     testGroup "Compiler (negative) tests"
         [goldenVsString 
             troupeFile 
             goldenFile 
-            (runNegative troupeFile) 
+            (runNegative troupeFile tc)
         | troupeFile <- testFiles 
         , let goldenFile = replaceExtension troupeFile ".golden"
         ]
@@ -103,39 +130,38 @@ diff_n ref new = ["tests/_util/diff_n.sh", ref, new ]
 
 -- 2019-03-04: AA: we should probably use type classes... 
 
-runtimeTests testFiles =
+runtimeTests testFiles tc =
     testGroup "Runtime tests" 
         [ goldenVsStringDiff  
             troupeFile
             diff 
             goldenFile 
-            (runPositive troupeFile) 
+            (runPositive troupeFile tc)
         | troupeFile <- testFiles 
         , let goldenFile = replaceExtension troupeFile ".golden"
         ] 
 
 
-timeoutTests testFiles = 
+timeoutTests testFiles tc =
     testGroup "Timeout tests" 
         [ goldenVsStringDiff  
             troupeFile            
             diff 
             goldenFile 
-            (runPositiveTimeout 8 troupeFile) 
+            (runPositiveTimeout 8 troupeFile tc)
         | troupeFile <- testFiles 
         , let goldenFile = replaceExtension troupeFile ".golden"
         ] 
 
 
-divergingTests testFiles = 
+divergingTests testFiles tc =
     testGroup "Diverging tests" 
         [ goldenVsStringDiff  
             troupeFile            
             diff_n
             goldenFile 
-            (runPositiveTimeout 8 troupeFile)
+            (runPositiveTimeout 8 troupeFile tc)
         | troupeFile <- testFiles 
         , let goldenFile = replaceExtension troupeFile ".golden"
-        ] 
+        ]
 
-

local.sh

@@ -2,7 +2,7 @@
 
 tmp=`mktemp`.js
 
-$TROUPE/bin/troupec $1 --output=$tmp
+$TROUPE/bin/troupec $@ --output=$tmp
 
 if [ $? -eq 0 ]; then
     node --stack-trace-limit=1000 $TROUPE/rt/built/troupe.mjs  -f=$tmp --localonly  #--debug