Newer
Older
1
2
3
4
5
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
86
87
88
89
90
91
92
93
94
95
96
97
98
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PackageImports #-}
import Control.RTree
import Data.Maybe (catMaybes, fromMaybe)
import Language.C qualified as C
import "pretty" Text.PrettyPrint qualified as P
import "transformers" Control.Monad.Trans.Maybe
import "typed-process" System.Process.Typed
main :: IO ()
main = do
C.parseCFilePre "test/data/file2.c" >>= \case
Right file -> do
l <- runMaybeT (reduce' check (reduceC file))
case l of
Just l' -> output l'
Nothing ->
putStrLn "Failure"
Left err ->
print err
where
output l = do
writeFile "test.c" (P.render (C.pretty l))
check l = MaybeT do
putStrLn "Outputting test"
output l
putStrLn "Running test"
err <- runProcess (proc "clang" ["-O0", "test.c"])
putStrLn $ "Done test" <> show err
pure $ if err == ExitSuccess then Just () else Nothing
type Lab = C.Ident
reduceC :: C.CTranslUnit -> RTree' Lab C.CTranslUnit
reduceC (C.CTranslUnit es _) = do
es' <- traverse rCExternalDeclaration es
pure $ C.CTranslUnit (catMaybes es') C.undefNode
rCExternalDeclaration
:: C.CExternalDeclaration C.NodeInfo
-> RTree' Lab (Maybe (C.CExternalDeclaration C.NodeInfo))
rCExternalDeclaration e = case e of
C.CFDefExt fun ->
split
(funName fun)
(pure Nothing)
(Just . C.CFDefExt <$> rCFunctionDef fun)
_ -> pure Nothing <| pure (Just e)
where
funName (C.CFunDef _ (C.CDeclr x _ _ _ _) _ _ _) =
x
rCFunctionDef :: C.CFunctionDef C.NodeInfo -> RTree' Lab (C.CFunctionDef C.NodeInfo)
rCFunctionDef (C.CFunDef spc dec cdecls smt _) = do
smt' <- rCStatement smt
pure $ C.CFunDef spc dec cdecls smt' C.undefNode
rCStatement :: C.CStatement C.NodeInfo -> RTree' Lab (C.CStatement C.NodeInfo)
rCStatement = \case
C.CCompound is cbi _ -> do
cbi' <- traverse rCCompoundBlockItem cbi
pure $ C.CCompound is (catMaybes cbi') C.undefNode
C.CExpr (Just e) _ -> do
e' <- rCExpression e
pure $ C.CExpr e' C.undefNode
a -> pure a
rCExpression :: C.CExpression C.NodeInfo -> RTree' Lab (Maybe (C.CExpression C.NodeInfo))
rCExpression = \case
C.CVar i _ ->
splitOn
i
(pure Nothing)
(pure . Just $ C.CVar i C.undefNode)
C.CCall e es _ -> do
me' <- rCExpression e
case me' of
Nothing -> pure Nothing
Just e' -> do
es' <-
traverse
( fmap
( fromMaybe (C.CConst (C.CIntConst (C.cInteger 0) C.undefNode))
)
. rCExpression
)
es
pure . Just $ C.CCall e' es' C.undefNode
e -> pure Nothing <| pure (Just e)
rCCompoundBlockItem :: C.CCompoundBlockItem C.NodeInfo -> RTree' Lab (Maybe (C.CCompoundBlockItem C.NodeInfo))
rCCompoundBlockItem a = pure Nothing <| pure (Just a)