Newer
Older
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
import qualified Data.Text.Lazy as LazyText
import qualified Data.Text.Lazy.Encoding as LazyText
import qualified Data.Text.Lazy.IO as LazyText
import qualified Language.C as C
import qualified Language.C.System.GCC as C
import ReduceC
import Test.Hspec
import qualified Test.Hspec.Expectations.Pretty as EP
import Test.Hspec.Glitter
import qualified Text.Pretty.Simple as PS
import qualified Text.PrettyPrint as P
specSmallCases :: Spec
specSmallCases = do
let testcases = "test" </> "cases" </> "small"
cases <- runIO (listDirectory testcases)
let expected = "test" </> "expected" </> dropExtensions cname
onGlitter (expected </> "main.hs") (\f -> LazyText.writeFile f (PS.pShowNoColor (void c))) do
pure ()
it "should be valid" . foldMap $ \cf -> do
validate cf
it "should be parsed equally" . foldMap $ \cf -> do
C.parseCFilePre cf >>= \case
Left err -> fail (show err)
describe "reduction" do
it "should extract itself" do
IRTree.extract (defaultReduceC c) $> () `EP.shouldBe` c $> ()
( \a -> do
_ <- tryIOError (removeDirectoryRecursive a)
createDirectoryIfMissing True a
forM_ (take 10 $ RTree.iinputs (defaultReduceC c)) \(i, _) -> do
let rfile = expected </> "reduction" </> "r" <> debugShow i <.> "c"
renderWithChoices rfile (IRTree.probe (defaultReduceC c) i)
specLargeCases :: Spec
specLargeCases = do
cases <- runIO (listDirectory "test/cases/large")
let cfrom = "test" </> "cases" </> "large" </> cname
let expected = "test" </> "expected" </> dropExtensions cname
it "should be valid" . foldMap $ \cf -> do
validate cf
it "should be parsed equally" . foldMap $ \cf -> do
C.parseCFilePre cf >>= \case
Left err -> fail (show err)
onGlitterEach (expected </> "extract.c") (\fp -> render fp (IRTree.extract (defaultReduceC c))) do
it "should be parsed equally" $ \cf -> do
C.parseCFilePre cf >>= \case
Left err -> fail (show err)
Right c' -> when (void c' /= void c) do
expectationFailure "did not parse as we extracted"
( \fp -> do
_ <- tryIOError (removeDirectoryRecursive fp)
createDirectoryIfMissing True fp
0 & fix \rec n -> do
let idx = fromString (replicate (1 `shiftL` n) '1')
let (c', t, _) = IRTree.probe (defaultReduceC c) idx
render (fp </> "x" <> show n <.> "c") c'
renderChoices (fp </> "p" <> show n <.> "path") t
unless (all ((/= Undecided) . choice) t) do
rec (n + 1)
do
it "should validate all reductions" $ \a -> do
when (takeExtension a == ".c") do
validate a
validate :: FilePath -> IO ()
validate fp = do
(ec, _, stderr_) <- readProcess (proc "clang" ["-o", "/dev/null", fp])
ExitFailure _ ->
expectationFailure $
"could not validate "
<> show fp
<> "\n"
<> ( LazyText.unpack
. LazyText.unlines
. filter (LazyText.isInfixOf "error")
. LazyText.lines
ExitSuccess -> pure ()
render :: FilePath -> C.CTranslUnit -> IO ()
render cto c = do
createDirectoryIfMissing True (takeDirectory cto)
writeFile cto (P.render (C.pretty c) <> "\n")
renderChoices :: FilePath -> [AnnotatedChoice (String, C.Position)] -> IO ()
renderChoices file as =
writeFile
file
( ( unlines
. map
( \(AnnotatedChoice cs (reason, pos)) ->
[debugShowChoice cs] <> " " <> reason <> " at " <> show pos
)
$ as
)
<> "\n"
)
renderWithChoices :: FilePath -> (C.CTranslUnit, [AnnotatedChoice (String, C.Position)], Int) -> IO ()
renderWithChoices file (c, a, _) = do
createDirectoryIfMissing True (takeDirectory file)
writeFile
file
( ( unlines
. map
( \(AnnotatedChoice cs (reason, pos)) ->
"// " <> [debugShowChoice cs] <> " " <> reason <> " at " <> show pos