From e8f851b3140c8a122833e6a625a50a46af0a1eaf Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Mon, 4 Nov 2024 21:21:54 +0100 Subject: [PATCH 1/2] Include MoreTests.hs --- MoreTests.hs | 167 ++++++++++++++++++++++++++++++++++++++++++++ cabal.project | 2 + plt-test-lab1.cabal | 3 + plt-test-lab1.hs | 33 +++++++++ 4 files changed, 205 insertions(+) create mode 100644 MoreTests.hs diff --git a/MoreTests.hs b/MoreTests.hs new file mode 100644 index 0000000..3c7fd9a --- /dev/null +++ b/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 + ] +-} diff --git a/cabal.project b/cabal.project index 0caa0ac..9c8ee57 100644 --- a/cabal.project +++ b/cabal.project @@ -3,3 +3,5 @@ -- All rights reserved. packages: . + +write-ghc-environment-files: always diff --git a/plt-test-lab1.cabal b/plt-test-lab1.cabal index 2b8675d..674a5fc 100644 --- a/plt-test-lab1.cabal +++ b/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. diff --git a/plt-test-lab1.hs b/plt-test-lab1.hs index 4b9b361..91f9503 100644 --- a/plt-test-lab1.hs +++ b/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,6 +168,7 @@ data Options = Options { optDebug :: Bool -- ^ Print debug information? , optGood :: [FilePath] -- ^ Good tests. , optBad :: [FilePath] -- ^ Bad tests. + , extraFlag :: Bool } defaultOptions :: Options @@ -171,6 +176,7 @@ defaultOptions = Options { optDebug = False , optGood = [] , optBad = [] + , extraFlag = True } optDescr :: [OptDescr (Options -> Options)] @@ -178,11 +184,15 @@ 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,26 @@ 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 cabal rather than ghc (Andreas, 2022-11-21). + -- This makes sure that the HUnit package is found. + copyFile (".." "plt-test-lab1.cabal") "plt-test-lab1.cabal" + callProcess "cabal" ["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 From 35d5b93088d03a75657a045a50b879a454087352 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Mon, 4 Nov 2024 21:26:19 +0100 Subject: [PATCH 2/2] Call MoreTests.hs with Stack instead of Cabal --- plt-test-lab1.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/plt-test-lab1.hs b/plt-test-lab1.hs index 91f9503..dbb838d 100644 --- a/plt-test-lab1.hs +++ b/plt-test-lab1.hs @@ -293,10 +293,11 @@ mainOpts cfFile testSuite = do copyFile (".." "MoreTests.hs") "MoreTests.hs" runPrgNoFail_ "sed" ["-i.bak", "-e", "s/GRAMMAR/" ++ grammar ++ "/g"] "MoreTests.hs" - -- Run MoreTests via cabal rather than ghc (Andreas, 2022-11-21). + -- 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" - callProcess "cabal" ["exec", "--", "runghc", "MoreTests.hs"] + copyFile (".." "stack.yaml") "stack.yaml" + callProcess "stack" ["exec", "runghc", "--", "MoreTests.hs"] -- #ifdef HC_OPTS -- callProcess "ghc" $ ["--make"] ++ words HC_OPTS ++ ["-o", "MoreTests", "MoreTests.hs"]