{-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} module ReduceCSpec where import Control.Monad import System.Directory import System.FilePath import Test.Hspec import Test.Hspec.Glitter import qualified Language.C as C import qualified Text.PrettyPrint as P import Control.Monad.RTree (extract, iinputs) import Data.Functor import Data.RPath import qualified Language.C.System.GCC as C import ReduceC import System.Process.Typed spec :: Spec spec = do cases <- runIO (listDirectory "test/cases") forM_ cases \cname -> do let cfrom = "test/cases" </> cname </> "main.c" let expected = "test/expected" </> cname onGlitterWith (expected </> "pp.c") (preproc cfrom) do it "should be valid" \(cf, _) -> validate cf it "should be parsed equally" \(cf, c) -> do C.parseCFilePre cf >>= \case Left err -> fail (show err) Right c' -> c' $> () `shouldBe` c $> () describe "reduction" do it "should extract itself" \(_, c) -> do extract (reduceC c) `shouldBe` c onGlitterWith (expected </> "reduction") ( \a () -> do c <- parse cfrom createDirectoryIfMissing True a forM_ (take 20 $ iinputs (reduceC c)) \(i, c') -> do let rfile = expected </> "reduction" </> "r" <> debugShow i <.> "c" render rfile c' pure a ) do it "should validate all reductions" \a -> do listDirectory a >>= mapM_ \x -> validate (a </> x) validate :: FilePath -> IO () validate fp = do ec <- runProcess (proc "clang" ["-o", "/dev/null", fp]) case ec of ExitFailure _ -> fail ("could not validate " <> show fp) ExitSuccess -> pure () render :: FilePath -> C.CTranslUnit -> IO () render cto c = do createDirectoryIfMissing True (takeDirectory cto) writeFile cto (P.render (C.pretty c) <> "\n") parse :: FilePath -> IO C.CTranslUnit parse cfrom = do cf <- C.parseCFile (C.newGCC "clang") Nothing [] cfrom case cf of Left err -> fail (show err) Right cf' -> pure cf' preproc :: FilePath -> FilePath -> () -> IO (FilePath, C.CTranslUnit) preproc cfrom cto _ = do cf' <- parse cfrom render cto cf' pure (cfrom, cf')