qute-syntax-0.1.0: test/Golden.hs

-- SPDX-FileCopyrightText: 2025 Sören Tempel <soeren+git@soeren-tempel.net>
--
-- SPDX-License-Identifier: GPL-3.0-only

module Golden (goldenTests) where

import Language.QBE (parse)
import System.Exit (ExitCode (..))
import System.FilePath
import System.IO (IOMode (WriteMode), hClose, hGetContents, openFile)
import System.Process
import Test.Tasty
import Test.Tasty.Golden.Advanced

type QBEResult = (ExitCode, String)

runQBE :: FilePath -> IO QBEResult
runQBE filePath = do
  devNull <- openFile "/dev/null" WriteMode

  (_, _, Just herr, p) <-
    createProcess
      (proc "qbe" [filePath])
        { std_out = UseHandle devNull,
          std_err = CreatePipe
        }

  ret <- waitForProcess p <* hClose devNull
  out <- hGetContents herr
  return (ret, out)

runQute :: FilePath -> IO QBEResult
runQute filePath = do
  content <- readFile filePath
  case parse filePath content of
    Right _ -> pure (ExitSuccess, "")
    Left err -> pure (ExitFailure 1, show err)

simpleCmp :: QBEResult -> QBEResult -> IO (Maybe String)
simpleCmp (exit, out) (exit', out') =
  return $
    if exit == exit'
      then Nothing
      else Just ("Parsing mismatch: " ++ err)
  where
    err :: String
    err = "qbe=(" ++ show exit ++ "): " ++ out ++ " qute=(" ++ show exit' ++ "):" ++ out'

runTest :: TestName -> TestTree
runTest testName =
  goldenTest
    testName
    (runQBE fullPath)
    (runQute fullPath)
    simpleCmp
    (\_ -> pure ())
  where
    fullPath :: FilePath
    fullPath = "test" </> "golden" </> (testName ++ ".qbe")

------------------------------------------------------------------------

goldenTests :: TestTree
goldenTests =
  testGroup
    "goldenTests"
    [ runTest "data-definition-whitespace",
      runTest "empty-definitions",
      runTest "function-definition",
      runTest "call-instruction",
      runTest "load-instructions",
      runTest "value-global",
      runTest "bubble-sort",
      runTest "phi-instructions",
      runTest "data",
      runTest "comments",
      runTest "number-literal-plus-sign",
      runTest "float-literal-plus-sign",
      runTest "hare-hello-world",
      runTest "dynconst",
      runTest "scc-prime-numbers"
    ]