Include MoreTests.hs

MoreTests.hs

@@ -0,0 +1,167 @@
+module Main where
+
+import qualified GRAMMAR.Lex as U
+import qualified GRAMMAR.Par as U
+import qualified GRAMMAR.Abs as U
+import qualified GRAMMAR.Print as U
+import GRAMMAR.ErrM
+
+import Control.Applicative
+import Control.Monad
+import System.IO (stderr, hPutStrLn)
+import System.Environment (getArgs)
+import Test.HUnit
+
+parse s = U.pProgram (U.myLexer s)
+
+parseResult :: String -> IO U.Program
+parseResult s = case parse s of
+                  Ok prog -> return prog
+                  Bad err ->
+                    error ("Error in " ++ s ++ ":\n<<<<<<<<<<<<<<<<<<<<<<\n" ++
+                           err ++ "\n>>>>>>>>>>>>>>>>>>>>>>")
+
+sameAST :: String -> String -> Test
+sameAST s1 s2 = TestCase $ do
+  prog1 <- parseResult s1
+  prog2 <- parseResult s2
+  assertBool (s1 ++ "\n" ++ show prog1 ++ "\n~/=\n" ++ s2 ++ "\n" ++ show prog2)
+    (prog1 == prog2)
+
+expInMain :: String -> String
+expInMain s = "int main() { " ++ s ++ "; }"
+
+sameExpAST e1 e2 = sameAST (expInMain e1) (expInMain e2)
+
+isBad (Ok _) = False
+isBad (Bad _) = True
+
+isGood = not . isBad
+
+shouldReject :: String -> String -> Test
+shouldReject msg s = TestCase $ do
+  let res = parse s
+  assertBool (msg ++ ": Program `" ++ s ++ "` should be rejected by the parser.\n") (isBad res)
+
+
+shouldAccept :: String -> String -> Test
+shouldAccept msg s = TestCase $ do
+  let res = parse s
+  assertBool (msg ++ ": Program `" ++ s ++ "` should be accepted by the parser.\n") (isGood res)
+
+shouldRejectExp :: String -> String -> Test
+shouldRejectExp msg e = shouldReject msg $ expInMain e
+
+shouldAcceptExp :: String -> String -> Test
+shouldAcceptExp msg e = shouldAccept msg $ expInMain e
+
+tests :: Test
+tests =
+  TestList [
+           -- Basic assoc tests
+             sameExpAST "e1 * e2 * e3" "(e1 * e2) * e3"
+           , sameExpAST "e1 / e2 / e3" "(e1 / e2) / e3"
+
+           , sameExpAST "e1 * e2 / e3" "(e1 * e2) / e3"
+           , sameExpAST "e1 / e2 * e3" "(e1 / e2) * e3"
+
+           , sameExpAST "e1 + e2 + e3" "(e1 + e2) + e3"
+           , sameExpAST "e1 - e2 - e3" "(e1 - e2) - e3"
+
+           , sameExpAST "e1 + e2 - e3" "(e1 + e2) - e3"
+           , sameExpAST "e1 - e2 + e3" "(e1 - e2) + e3"
+
+           , sameExpAST "e1 && e2 && e3" "(e1 && e2) && e3"
+           , sameExpAST "e1 || e2 || e3" "(e1 || e2) || e3"
+
+           , sameExpAST "e1 = e2 = e3" "e1 = (e2 = e3)"
+
+           -- More involved tests
+           , sameExpAST "++x * y" "(++x) * y"
+           , sameExpAST "++x / y" "(++x) / y"
+           , sameExpAST "--x * y" "(--x) * y"
+           , sameExpAST "--x / y" "(--x) / y"
+
+           , sameExpAST "i + x * 5" "i + (x * 5)"
+           , sameExpAST "i + x / 5" "i + (x / 5)"
+           , sameExpAST "i - x * 5" "i - (x * 5)"
+           , sameExpAST "i - x / 5" "i - (x / 5)"
+           , sameExpAST "x * 5 + i" "(x * 5) + i"
+           , sameExpAST "x * 5 - i" "(x * 5) - i"
+           , sameExpAST "x / 5 + i" "(x / 5) + i"
+           , sameExpAST "x / 5 - i" "(x / 5) - i"
+
+           , sameExpAST "x || y && z" "x || (y && z)"
+           , sameExpAST "x && y || z" "(x && y) || z"
+
+           , sameExpAST "x == y && z" "(x == y) && z"
+           , sameExpAST "x == y || z" "(x == y) || z"
+           , sameExpAST "x && y == z" "x && (y == z)"
+           , sameExpAST "x || y == z" "x || (y == z)"
+           , sameExpAST "x != y && z" "(x != y) && z"
+           , sameExpAST "x != y || z" "(x != y) || z"
+           , sameExpAST "x && y != z" "x && (y != z)"
+           , sameExpAST "x || y != z" "x || (y != z)"
+
+           -- Duplicate
+           , sameExpAST "a + b + c" "(a + b) + c"
+
+           , sameExpAST "a && b || c && e > 9" "(a && b) || (c && (e > 9))"
+
+           , sameExpAST "a = b || c" "a = (b || c)"
+
+           -- Duplicate
+           , sameExpAST "x = y = z" "x = (y = z)"
+
+           -- , shouldAcceptExp
+           --     "Conditional as parentheses around assignment"
+           --     "true ? x = false : false"
+
+
+           -- , shouldReject "Multiple expressions when indexing"
+           --   "int main() { x[1, 2]; }"
+
+           , shouldAcceptExp "mult applied to bool"       "true * false"
+           , shouldAcceptExp "div applied to bool"        "true / false"
+           , shouldAcceptExp "add applied to bool"        "true + false"
+           , shouldAcceptExp "sub applied to bool"        "true - false"
+           , shouldAcceptExp "lt applied to bool"         "true < false"
+           , shouldAcceptExp "gt applied to bool"         "true > false"
+           , shouldAcceptExp "ge applied to bool"         "true >= false"
+           , shouldAcceptExp "le applied to bool"         "true <= false"
+           , shouldAcceptExp "conjunction applied to int" "1 && 0"
+           , shouldAcceptExp "disjunction applied to int" "1 || 0"
+           ]
+
+main = runTestTT tests
+{-
+instance Enumerable Id where
+  enumerate = consts [ nullary $ Id "a"
+                     , nullary $ Id "b"
+                     , nullary $ Id "c" ]
+
+c1 f = fmap f shared
+
+c2 f = c1 (funcurry f)
+
+instance Enumerable Type where
+  enumerate = consts $ map (fmap TNoRef) base ++ map (fmap TRef) base
+    where base =  [ nullary Type1_bool
+                  , nullary Type1_int
+                  , nullary Type1_void
+                  , nullary Type1_double
+                  , unary TQConst
+                  ]
+
+sanitizeChar :: Char -> Char
+sanitizeChar x | x >= 'a' && x <= 'z' = x
+               | otherwise = 'x'
+
+fmap concat $ mapM deriveEnumerable'
+       [ dExcept 'NameTempl [| c2 $ \x -> NameTempl x . nonEmpty |] $
+           dAll ''Name
+       , dAll ''QConst
+       , dExcept 'EChar [| c1 $ EChar . sanitizeChar |] $
+         dAll ''Exp
+       ]
+-}

cabal.project

@@ -3,3 +3,5 @@
 -- All rights reserved.
 
 packages: .
+
+write-ghc-environment-files: always

plt-test-lab1.cabal

@@ -20,6 +20,7 @@ tested-with:
    || ==8.10.7 || ==8.8.4 || ==8.6.5
 
 extra-source-files:
+  MoreTests.hs
   bad/*.cc
   good/*.cc
   good-CMM/*.cc
@@ -45,6 +46,8 @@ executable plt-test-lab1
     , filepath   >= 1.4.2.1  && < 1.6
     , process    >= 1.6.5.0  && < 1.7
     -- , ghc-paths ^>= 0.1.0.12  -- not reliable
+    -- Extra dependency for MoreTests.hs
+    , HUnit       >= 1.6.0  && < 1.7
 
   -- These following tools are not needed to _build_ the testsuite runner,
   -- but to _run_ it, namely to build the parser from the given LBNF file.

plt-test-lab1.hs

@@ -65,6 +65,10 @@ defaultBad = ["bad"]
 doDebug :: IORef Bool
 doDebug = unsafePerformIO $ newIORef False
 
+{-# NOINLINE doExtra #-}
+doExtra :: IORef Bool
+doExtra = unsafePerformIO $ newIORef False
+
 -- | Print debug message if debug is set to @True@.
 debug :: String -> IO ()
 debug s = do
@@ -164,25 +168,31 @@ data Options = Options
   { optDebug :: Bool        -- ^ Print debug information?
   , optGood  :: [FilePath]  -- ^ Good tests.
   , optBad   :: [FilePath]  -- ^ Bad tests.
+  , extraFlag :: Bool
   }
 
 defaultOptions :: Options
 defaultOptions = Options
   { optDebug = False
   , optGood  = []
   , optBad   = []
+  , extraFlag = True
   }
 
 optDescr :: [OptDescr (Options -> Options)]
 optDescr =
   [ Option []    ["debug"] (NoArg  enableDebug       ) "print debug messages"
   , Option ['g'] ["good"]  (ReqArg addGood     "PATH") "good test case PATH"
   , Option ['b'] ["bad"]   (ReqArg addBad      "PATH") "bad test case PATH"
+  , Option []    ["no-extra"] (NoArg disableExtra    ) "skip MoreTests"
   ]
 
 enableDebug :: Options -> Options
 enableDebug o = o { optDebug = True }
 
+disableExtra :: Options -> Options
+disableExtra options = options { extraFlag = False }
+
 addGood, addBad :: FilePath -> Options -> Options
 addGood f o = o { optGood = f : optGood o }
 addBad  f o = o { optBad  = f : optBad  o }
@@ -202,6 +212,7 @@ parseArgs argv = case getOpt RequireOrder optDescr argv of
     when (optDebug options) $ writeIORef doDebug True
     let expandPath f = doesDirectoryExist f >>= \b -> if b then listCCFiles f else return [f]
     testSuite' <- bothM ((concat <$>) . mapM expandPath) $ testSuiteOption options
+    when (extraFlag options) $ writeIORef doExtra True
     return (cfFile, testSuite')
 
   (_,_,_) -> do
@@ -246,6 +257,8 @@ mainOpts cfFile testSuite = do
   -- We change into the working directory.
   -- Files of the testsuite with a relative name need to be updated by "../".
   setCurrentDirectory dir
+  -- If we have position date in our tokens then the MoreTests tests do not work :(
+  runPrgNoFail_ "sed" ["-i.bak", "-e", "s/position token/token/g"] $ grammar <.> "cf"
   let adjustPath f = if isRelative f then ".." </> f else f
       testSuite'   = (map adjustPath *** map adjustPath) testSuite
 
@@ -273,6 +286,27 @@ mainOpts cfFile testSuite = do
   report "Good programs: " good
   report "Bad programs:  " bad
 
+  -- To be merged with standard test suite
+  e <- readIORef doExtra
+  when e $ do
+    putStr "Running additional tests... "
+    copyFile (".." </> "MoreTests.hs") "MoreTests.hs"
+    runPrgNoFail_ "sed" ["-i.bak", "-e", "s/GRAMMAR/" ++ grammar ++ "/g"] "MoreTests.hs"
+
+    -- Run MoreTests via Stack rather than ghc (Andreas, 2022-11-21, 2024-11-04).
+    -- This makes sure that the HUnit package is found.
+    copyFile (".." </> "plt-test-lab1.cabal") "plt-test-lab1.cabal"
+    copyFile (".." </> "stack.yaml") "stack.yaml"
+    callProcess "stack" ["exec", "runghc", "--", "MoreTests.hs"]
+
+-- #ifdef HC_OPTS
+--     callProcess "ghc" $ ["--make"] ++ words HC_OPTS ++ ["-o", "MoreTests", "MoreTests.hs"]
+-- #else
+--     callProcess "ghc" ["--make", "-o", "MoreTests", "MoreTests.hs"]
+-- #endif
+--     callProcess ("." </> "MoreTests") []
+    putStrLn "."
+
 main :: IO ()
 main = setup >> getArgs >>= parseArgs >>= uncurry mainOpts