Newer
Older
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
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')