fir-0.1.0.0: test/Test.hs
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
module Test where
-- base
import Control.Concurrent
( forkIO, newEmptyMVar, putMVar, takeMVar )
import Control.Monad
( when )
import Data.Maybe
( fromMaybe )
import System.IO
( hClose )
-- bytestring
import Data.ByteString
( ByteString )
import qualified Data.ByteString as ByteString
( readFile, writeFile
, hGetContents, hPut
, null, take
)
import qualified Data.ByteString.Char8 as ByteString
( lines, unlines, stripSuffix )
-- directory
import System.Directory
( doesFileExist, renameFile, removeFile )
-- filepath
import System.FilePath
( (</>), (<.>), splitDirectories )
import qualified System.FilePath.Posix as Posix
( joinPath )
-- process
import System.Process
( proc, createProcess
, CreateProcess
( std_in, std_out, std_err )
, StdStream
( CreatePipe )
, waitForProcess
)
-- text
import Data.Text
( Text )
import qualified Data.Text as Text
( pack, lines
, take, drop, dropWhile, dropWhileEnd
, dropAround, breakOn, isPrefixOf
, null, replace
)
import qualified Data.Text.Encoding as Text
( encodeUtf8, decodeUtf8With )
import qualified Data.Text.Encoding.Error as Text
( lenientDecode )
-- fir
import FIR
( CompilerFlag(..) )
--------------------------------------------------
data Test
= Typecheck
| CodeGen
| Validate
deriving stock ( Eq, Show )
data TestFailure
= MissingSource
| WrongTypecheckOutput
| ExpectedTypecheck
| UnexpectedTypecheck
| CodeGenFail Text
| ValidateFail Text
| CGOutputParseError
| FIRNotBuiltOrUnusableError
| OtherError
deriving stock ( Eq, Show )
data TestOutput
= Failure TestFailure
| Success
| NewTest
deriving stock ( Eq, Show )
runTest :: Test -> FilePath -> IO TestOutput
runTest Typecheck = typeCheck
runTest CodeGen = codeGen
runTest Validate = validate
--------------------------------------------------
-- truly disgusting testing setup
validator :: FilePath
validator = "spirv-val"
codeGen, validate :: FilePath -> IO TestOutput
codeGen testName = compileTest [Debug, Assert, NoCode] testName
validate testName = compileTest [Debug, Assert] testName
-- | Run an executable with the given arguments, feeding it the given input
-- on stdin, and return what it wrote to stdout and stderr.
readProcessOutput :: FilePath -> [String] -> ByteString -> IO (ByteString, ByteString)
readProcessOutput exe args input = do
(Just inHandle, Just outHandle, Just errHandle, processHandle)
<- createProcess
( proc exe args )
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = CreatePipe
}
outVar <- newEmptyMVar
errVar <- newEmptyMVar
_ <- forkIO $ ByteString.hGetContents outHandle >>= putMVar outVar
_ <- forkIO $ ByteString.hGetContents errHandle >>= putMVar errVar
ByteString.hPut inHandle input
hClose inHandle
out <- takeMVar outVar
err <- takeMVar errVar
_ <- waitForProcess processHandle
pure (out, err)
-- | Run GHC in the package environment of the cabal project, which provides
-- the in-place build of 'fir'.
--
-- A package environment file in the project directory is not reliable:
-- every cabal invocation with @write-ghc-environment-files@ rewrites it,
-- including those of the Haskell Language Server with its own build directory.
readGhcOutput :: [String] -> ByteString -> IO (ByteString, ByteString)
readGhcOutput args = readProcessOutput "cabal" ( [ "exec", "--verbose=0", "--", "ghc" ] ++ args )
decodeOutput :: ByteString -> Text
decodeOutput = Text.decodeUtf8With Text.lenientDecode
compileTest :: [CompilerFlag] -> FilePath -> IO TestOutput
compileTest flags testName = do
srcExists <- doesFileExist src
case srcExists of
False -> pure ( Failure MissingSource )
True ->
do
(out, err) <-
readGhcOutput
[ "--interactive"
, src
, "-w"
, "-package", "fir"
, "-threaded"
]
( Text.encodeUtf8 ( compile <> "\n:q\n" ) )
let res = parseCGOutput ( decodeOutput out )
res' <- case res of
Failure ExpectedTypecheck
-> do ByteString.writeFile test err
pure res
Failure (CodeGenFail _)
-> do ByteString.writeFile test out
pure res
Failure _
-> do let errLines = dropWhile ignoreLineText . linesText $ decodeOutput err
case errLines of
( l1 : _ )
| Text.take 43 l1 == "<command line>: cannot satisfy -package fir"
-> pure (Failure FIRNotBuiltOrUnusableError)
_ -> do ByteString.writeFile test err
pure res
Success
-> do failExists <- doesFileExist test
when ( NoCode `elem` flags && failExists ) ( removeFile test )
pure res
NewTest
-> pure res
if res' /= Success || NoCode `elem` flags
then pure res'
else
do (_, valErr) <- readProcessOutput validator [ spv ] ""
if ByteString.null valErr
then do removeFile spv
failExists <- doesFileExist test
when failExists ( removeFile test )
pure Success
else do ByteString.writeFile test valErr
renameFile spv (spv <.> "fail")
pure ( Failure ( ValidateFail ( decodeOutput valErr ) ) )
where dir = "test" </> "Tests"
src = dir </> testName <.> "hs"
test = dir </> testName <.> "fail"
spv = dir </> testName <.> "spv"
compile = "compileTo "
<> Text.pack (show spv)
<> " "
<> Text.pack (show flags)
<> " program"
typeCheck :: FilePath -> IO TestOutput
typeCheck testName = do
srcExists <- doesFileExist src
case srcExists of
False -> pure ( Failure MissingSource )
True ->
do
(_, testContents) <-
readGhcOutput
[ src
, "-w"
, "-fno-code"
, "-package", "fir"
, "-threaded"
]
""
let mbTcOutput = normalisePath <$> parseTcOutput testContents
case mbTcOutput of
Nothing -> pure ( Failure FIRNotBuiltOrUnusableError )
Just tcOutput -> do
goldenExists <- doesFileExist gold
if goldenExists
then do
golden <- ByteString.readFile gold
if normaliseDiagnostics golden == normaliseDiagnostics tcOutput
then pure Success
else do
ByteString.writeFile test tcOutput
if golden == cleanTc
then pure ( Failure ExpectedTypecheck)
else
if tcOutput == cleanTc
then pure ( Failure UnexpectedTypecheck )
else pure ( Failure WrongTypecheckOutput )
else do ByteString.writeFile gold tcOutput
pure NewTest
where dir = "test" </> "Tests"
src = dir </> testName <.> "hs"
gold = dir </> testName <.> "golden"
test = dir </> testName <.> "fail"
-- GHC refers to the source file using the path separators of the platform:
-- use forward slashes, so that the expected output is the same on all platforms.
normalisePath :: ByteString -> ByteString
normalisePath
= Text.encodeUtf8
. Text.replace ( Text.pack src ) ( Text.pack ( Posix.joinPath ( splitDirectories src ) ) )
. decodeOutput
-- | Normalise diagnostics, for comparison with expected diagnostics, which might
-- have been produced on a different platform:
--
-- - use LF line endings (the golden files can be checked out with CRLF line endings),
-- - GHC replaces some Unicode characters in its diagnostics with ASCII substitutes
-- when the locale doesn't support Unicode (e.g. with most Windows code pages):
-- make these substitutions.
normaliseDiagnostics :: ByteString -> Text
normaliseDiagnostics
= Text.replace "\r\n" "\n"
. Text.replace "\x2018" "`"
. Text.replace "\x2019" "'"
. Text.replace "\x2022" "*"
. decodeOutput
cleanTc :: ByteString
cleanTc = "No type-checking errors."
ignoreLineBS :: ByteString -> Bool
ignoreLineBS string
| ByteString.null string
|| ByteString.take 4 string == "GHCi"
|| ByteString.take 26 string == "Loaded package environment"
= True
| otherwise
= False
ignoreLineText :: Text -> Bool
ignoreLineText string
| Text.null string
|| Text.take 4 string == "GHCi"
|| Text.take 26 string == "Loaded package environment"
|| Text.take 30 string == "Using default language edition"
= True
| otherwise
= False
-- Split GHC output into lines, accepting both LF and CRLF line endings
-- (GHC uses CRLF on Windows).
linesBS :: ByteString -> [ ByteString ]
linesBS = map ( \ l -> fromMaybe l ( ByteString.stripSuffix "\r" l ) ) . ByteString.lines
linesText :: Text -> [ Text ]
linesText = map ( Text.dropWhileEnd ( == '\r' ) ) . Text.lines
parseTcOutput :: ByteString -> Maybe ByteString
parseTcOutput contents = go ( dropWhile ignoreLineBS ( linesBS contents ) )
where
go :: [ByteString] -> Maybe ByteString
go [] = Just cleanTc
go ls@(l:_)
| ByteString.take 43 l == "<command line>: cannot satisfy -package fir"
= Nothing
| otherwise
= Just $ ByteString.unlines ls
parseCGOutput :: Text -> TestOutput
parseCGOutput contents
= let ls = dropWhile ignoreLineText (linesText contents)
in case ls of
l1 : l2 : l3 : _
| Text.take 8 l1 == "[1 of 1]"
-> case l2 of
"Ok, one module loaded."
-> let l3' = Text.drop 2
. Text.dropWhile ( /= '>' )
$ l3
in case Text.breakOn " " l3' of
( "Left", rest )
-> Failure ( CodeGenFail
( Text.dropAround (== '\"' )
. Text.drop 1
$ rest
)
)
( "Right", _)
-> Success
_ -> Failure CGOutputParseError
_ | "Failed," `Text.isPrefixOf` l2
-> Failure ExpectedTypecheck
| otherwise
-> Failure OtherError
_ -> Failure OtherError