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
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module ReduceC where
import Control.Monad.Reduce
import Control.Applicative
import Control.Monad.Trans
import Control.Monad.Trans.Maybe
import Data.Functor
import Data.Maybe
import qualified Language.C as C
type Lab = C.Ident
reduceC :: (MonadReduce Lab m) => C.CTranslUnit -> m C.CTranslUnit
reduceC (C.CTranslUnit es ni) = do
es' <- collect mrCExternalDeclaration es
pure $ C.CTranslUnit es' ni
mrCExternalDeclaration :: (MonadReduce Lab m) => C.CExternalDeclaration C.NodeInfo -> MaybeT m (C.CExternalDeclaration C.NodeInfo)
mrCExternalDeclaration = \case
C.CFDefExt fun -> do
givenWith (funName fun)
C.CFDefExt <$> rCFunctionDef fun
C.CDeclExt decl ->
C.CDeclExt <$> mrCDeclaration decl
a -> error (show a)
where
funName (C.CFunDef _ (C.CDeclr x _ _ _ _) _ _ _) =
x
mrCDeclarationItem :: (MonadReduce Lab m) => C.CDeclarationItem C.NodeInfo -> MaybeT m (C.CDeclarationItem C.NodeInfo)
mrCDeclarationItem = \case
C.CDeclarationItem d@(C.CDeclr x _ _ _ _) i e -> do
givenWith x
i' <- mtry $ munder i mrCInitializer
e' <- mtry $ munder e mrCExpression
pure (C.CDeclarationItem d i' e')
a -> error (show a)
mrCInitializer :: (MonadReduce Lab m) => C.CInitializer C.NodeInfo -> MaybeT m (C.CInitializer C.NodeInfo)
mrCInitializer = \case
C.CInitExpr e ni -> mrCExpression e <&> \e' -> C.CInitExpr e' ni
C.CInitList (C.CInitializerList items) ni -> do
collectNonEmpty' rmCInitializerListItem items <&> \items' ->
C.CInitList (C.CInitializerList items') ni
where
rmCInitializerListItem (pds, is) = do
pds' <- lift $ collect rmCPartDesignator pds
is' <- mrCInitializer is
pure (pds', is')
rmCPartDesignator :: (MonadReduce Lab m) => C.CPartDesignator C.NodeInfo -> m (C.CPartDesignator C.NodeInfo)
rmCPartDesignator = \case
a -> error (show a)
mrCDeclaration :: (MonadReduce Lab m) => C.CDeclaration C.NodeInfo -> MaybeT m (C.CDeclaration C.NodeInfo)
mrCDeclaration = \case
C.CDecl spc decl ni -> do
decl' <- lift $ collect mrCDeclarationItem decl
case decl' of
[] -> empty
decl'' -> pure $ C.CDecl spc decl'' ni
a -> error (show a)
rCFunctionDef :: (MonadReduce Lab m) => C.CFunctionDef C.NodeInfo -> m (C.CFunctionDef C.NodeInfo)
rCFunctionDef (C.CFunDef spc dec cdecls smt ni) = do
smt' <- rCStatement smt
pure $ C.CFunDef spc dec cdecls smt' ni
rCStatement :: (MonadReduce Lab m) => C.CStatement C.NodeInfo -> m (C.CStatement C.NodeInfo)
rCStatement = \case
C.CCompound is cbi ni -> do
cbi' <- collect mrCCompoundBlockItem cbi
pure $ C.CCompound is cbi' ni
C.CExpr e ni -> do
e' <- runMaybeT $ munder e mrCExpression
pure $ C.CExpr e' ni
C.CIf e s els ni -> do
e' <- runMaybeT $ mrCExpression e
s' <- rCStatement s
els' <- case els of
Just els' -> do
pure Nothing <| Just <$> rCStatement els'
Nothing -> pure Nothing
case (e', els') of
(Nothing, Nothing) -> pure s'
(Just e'', Nothing) -> pure $ C.CIf e'' s' Nothing ni
(Nothing, Just x) -> pure $ C.CIf zeroExp s' (Just x) ni
(Just e'', Just x) -> pure $ C.CIf e'' s' (Just x) ni
C.CFor e1 e2 e3 s ni -> do
rCStatement s <| do
e1' <- rCForInit e1
e2' <- runMaybeT $ munder e2 mrCExpression
e3' <- runMaybeT $ munder e3 mrCExpression
s' <- rCStatement s
pure $ C.CFor e1' e2' e3' s' ni
C.CReturn e ni -> do
e' <- case e of
Nothing -> pure Nothing
Just e' -> Just <$> zrCExpression e'
pure $ C.CReturn e' ni
C.CBreak ni -> pure (C.CBreak ni)
C.CCont ni -> pure (C.CCont ni)
C.CLabel i s [] ni ->
-- todo fix attrs
splitOn i (rCStatement s) do
s' <- rCStatement s
pure $ C.CLabel i s' [] ni
C.CGoto i ni ->
-- todo fix attrs
splitOn i (pure $ C.CExpr Nothing ni) do
pure $ C.CGoto i ni
a -> error (show a)
where
rCForInit = \case
C.CForDecl decl -> do
m <- runMaybeT $ mrCDeclaration decl
pure $ case m of
Nothing -> C.CForInitializing Nothing
Just d' -> C.CForDecl d'
C.CForInitializing n -> do
C.CForInitializing <$> runMaybeT (munder n mrCExpression)
orZero :: Maybe (C.CExpression C.NodeInfo) -> C.CExpression C.NodeInfo
orZero = fromMaybe zeroExp
zeroExp :: C.CExpression C.NodeInfo
zeroExp = C.CConst (C.CIntConst (C.cInteger 0) C.undefNode)
zrCExpression :: (MonadReduce Lab m) => C.CExpression C.NodeInfo -> m (C.CExpression C.NodeInfo)
zrCExpression e = orZero <$> runMaybeT (mrCExpression e)
mrCExpression :: (MonadReduce Lab m) => C.CExpression C.NodeInfo -> MaybeT m (C.CExpression C.NodeInfo)
mrCExpression = \case
C.CVar i ni -> do
givenThat i
pure $ C.CVar i ni
C.CCall e es ni -> do
e' <- mrCExpression e
es' <- lift $ traverse zrCExpression es
pure $ C.CCall e' es' ni
C.CCond ec et ef ni -> do
ec' <- mrCExpression ec
ef' <- mrCExpression ef
et' <- mtry $ munder et mrCExpression
pure $ C.CCond ec' et' ef' ni
C.CBinary o elhs erhs ni -> onBothExpr elhs erhs \lhs rhs ->
pure $ C.CBinary o lhs rhs ni
C.CUnary o elhs ni -> do
lhs <- mrCExpression elhs
pure $ C.CUnary o lhs ni
C.CConst c -> do
-- TODO fix
pure $ C.CConst c
C.CCast cd e ni -> do
-- TODO fix
cd' <- mrCDeclaration cd
e' <- mrCExpression e
pure $ C.CCast cd' e' ni
C.CAssign op e1 e2 ni -> onBothExpr e1 e2 \e1' e2' ->
pure $ C.CAssign op e1' e2' ni
C.CIndex e1 e2 ni -> onBothExpr e1 e2 \e1' e2' ->
pure $ C.CIndex e1' e2' ni
C.CMember e i b ni -> do
givenThat i
e' <- mrCExpression e
pure $ C.CMember e' i b ni
C.CComma items ni -> do
C.CComma <$> collectNonEmpty' mrCExpression items <*> pure ni
e -> error (show e)
where
onBothExpr elhs erhs = onBoth (mrCExpression elhs) (mrCExpression erhs)
mrCCompoundBlockItem
:: (MonadReduce Lab m)
=> C.CCompoundBlockItem C.NodeInfo
-> MaybeT m (C.CCompoundBlockItem C.NodeInfo)
mrCCompoundBlockItem = \case
C.CBlockStmt s -> empty <| lift (C.CBlockStmt <$> rCStatement s)
C.CBlockDecl d -> C.CBlockDecl <$> mrCDeclaration d
a -> error (show a)
mtry :: (Functor m) => MaybeT m a -> MaybeT m (Maybe a)
mtry (MaybeT mt) = MaybeT (Just <$> mt)
mlift :: (Applicative m) => Maybe a -> MaybeT m a
mlift a = MaybeT (pure a)
munder :: (Monad m) => Maybe a -> (a -> MaybeT m b) -> MaybeT m b
munder a mf = mlift a >>= mf