quebex

 1-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>
 2--
 3-- SPDX-License-Identifier: GPL-3.0-only
 4
 5module Golden (goldenTests) where
 6
 7import Language.QBE (parse)
 8import System.Exit (ExitCode (..))
 9import System.FilePath
10import System.IO (IOMode (WriteMode), hClose, hGetContents, openFile)
11import System.Process
12import Test.Tasty
13import Test.Tasty.Golden.Advanced
14
15type QBEResult = (ExitCode, String)
16
17runQBE :: FilePath -> IO QBEResult
18runQBE filePath = do
19  devNull <- openFile "/dev/null" WriteMode
20
21  (_, _, Just herr, p) <-
22    createProcess
23      (proc "qbe" [filePath])
24        { std_out = UseHandle devNull,
25          std_err = CreatePipe
26        }
27
28  ret <- waitForProcess p <* hClose devNull
29  out <- hGetContents herr
30  return (ret, out)
31
32runQuebex :: FilePath -> IO QBEResult
33runQuebex filePath = do
34  content <- readFile filePath
35  case parse filePath content of
36    Right _ -> pure (ExitSuccess, "")
37    Left err -> pure (ExitFailure 1, show err)
38
39simpleCmp :: QBEResult -> QBEResult -> IO (Maybe String)
40simpleCmp (exit, out) (exit', out') =
41  return $
42    if exit == exit'
43      then Nothing
44      else Just ("Parsing mismatch: " ++ err)
45  where
46    err :: String
47    err = "qbe=(" ++ show exit ++ "): " ++ show out ++ " quebex=(" ++ show exit' ++ "):" ++ show out'
48
49runTest :: TestName -> TestTree
50runTest testName =
51  goldenTest
52    testName
53    (runQBE fullPath)
54    (runQuebex fullPath)
55    simpleCmp
56    (\_ -> pure ())
57  where
58    fullPath :: FilePath
59    fullPath = "test" </> "golden" </> (testName ++ ".ssa")
60
61------------------------------------------------------------------------
62
63goldenTests :: TestTree
64goldenTests =
65  testGroup
66    "goldenTests"
67    [ runTest "data-definition-whitespace",
68      runTest "empty-definitions",
69      runTest "function-definition",
70      runTest "call-instruction",
71      runTest "load-instructions",
72      runTest "value-global"
73    ]