From ad637237edac75aaea6db3d6a800b5db5b6bb4a9 Mon Sep 17 00:00:00 2001
From: Christian Gram Kalhauge <chrg@dtu.dk>
Date: Thu, 22 Feb 2024 08:50:09 +0100
Subject: [PATCH] Add cases
---
flake.lock | 2 +-
rtree-c/src/ReduceC.hs | 274 +++++++++++++-----
rtree-c/test/cases/main.c | 1 -
rtree-c/test/cases/while-loops.c | 6 +
rtree-c/test/expected/main/main.c | 1 -
rtree-c/test/expected/main/reduction/r.c | 1 -
.../test/expected/main/reduction/r.choices | 0
.../typedef/reduction/{r00.c => r000.c} | 0
.../expected/typedef/reduction/r000.choices | 3 +
.../test/expected/typedef/reduction/r001.c | 8 +
.../expected/typedef/reduction/r001.choices | 3 +
.../typedef/reduction/{r01.c => r010.c} | 0
.../expected/typedef/reduction/r010.choices | 3 +
.../test/expected/typedef/reduction/r011.c | 5 +
.../expected/typedef/reduction/r011.choices | 3 +
.../typedef/reduction/{r10.c => r100.c} | 0
.../expected/typedef/reduction/r100.choices | 3 +
.../test/expected/typedef/reduction/r101.c | 7 +
.../expected/typedef/reduction/r101.choices | 3 +
.../typedef/reduction/{r11.c => r110.c} | 0
.../expected/typedef/reduction/r110.choices | 3 +
.../test/expected/typedef/reduction/r111.c | 4 +
.../expected/typedef/reduction/r111.choices | 3 +
rtree-c/test/expected/while-loops/main.c | 8 +
.../test/expected/while-loops/reduction/r00.c | 8 +
.../while-loops/reduction/r00.choices | 2 +
.../test/expected/while-loops/reduction/r01.c | 7 +
.../while-loops/reduction/r01.choices | 2 +
.../test/expected/while-loops/reduction/r1.c | 4 +
.../expected/while-loops/reduction/r1.choices | 1 +
rtree-c/test/src/ReduceCSpec.hs | 74 +++--
rtree/src/Control/Monad/RTree.hs | 11 +
32 files changed, 348 insertions(+), 102 deletions(-)
create mode 100644 rtree-c/test/cases/while-loops.c
create mode 100644 rtree-c/test/expected/main/reduction/r.choices
rename rtree-c/test/expected/typedef/reduction/{r00.c => r000.c} (100%)
create mode 100644 rtree-c/test/expected/typedef/reduction/r000.choices
create mode 100644 rtree-c/test/expected/typedef/reduction/r001.c
create mode 100644 rtree-c/test/expected/typedef/reduction/r001.choices
rename rtree-c/test/expected/typedef/reduction/{r01.c => r010.c} (100%)
create mode 100644 rtree-c/test/expected/typedef/reduction/r010.choices
create mode 100644 rtree-c/test/expected/typedef/reduction/r011.c
create mode 100644 rtree-c/test/expected/typedef/reduction/r011.choices
rename rtree-c/test/expected/typedef/reduction/{r10.c => r100.c} (100%)
create mode 100644 rtree-c/test/expected/typedef/reduction/r100.choices
create mode 100644 rtree-c/test/expected/typedef/reduction/r101.c
create mode 100644 rtree-c/test/expected/typedef/reduction/r101.choices
rename rtree-c/test/expected/typedef/reduction/{r11.c => r110.c} (100%)
create mode 100644 rtree-c/test/expected/typedef/reduction/r110.choices
create mode 100644 rtree-c/test/expected/typedef/reduction/r111.c
create mode 100644 rtree-c/test/expected/typedef/reduction/r111.choices
create mode 100644 rtree-c/test/expected/while-loops/main.c
create mode 100644 rtree-c/test/expected/while-loops/reduction/r00.c
create mode 100644 rtree-c/test/expected/while-loops/reduction/r00.choices
create mode 100644 rtree-c/test/expected/while-loops/reduction/r01.c
create mode 100644 rtree-c/test/expected/while-loops/reduction/r01.choices
create mode 100644 rtree-c/test/expected/while-loops/reduction/r1.c
create mode 100644 rtree-c/test/expected/while-loops/reduction/r1.choices
diff --git a/flake.lock b/flake.lock
index df4c0e1..fed1ed9 100644
--- a/flake.lock
+++ b/flake.lock
@@ -46,7 +46,7 @@
"dirtyRev": "979d17cf356e3a336dac8820c676ec813668222c-dirty",
"dirtyShortRev": "979d17c-dirty",
"lastModified": 1708504824,
- "narHash": "sha256-4B1Tb847DHviKPsOLbKwjCUsrDCegXeKtDO7FTHgxts=",
+ "narHash": "sha256-g2sR8z7+KWFT2A09zXqqC5EvH64oSh36XqX5NNJV3rY=",
"type": "git",
"url": "file:///Users/chrg/Develop/repos/hspec-glitter"
},
diff --git a/rtree-c/src/ReduceC.hs b/rtree-c/src/ReduceC.hs
index 7703d29..1190e21 100644
--- a/rtree-c/src/ReduceC.hs
+++ b/rtree-c/src/ReduceC.hs
@@ -15,18 +15,31 @@ module ReduceC where
import Control.Monad.Reader
import Control.Monad.Reduce
+import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
import Data.Data
import Data.Foldable
+import Data.Functor
import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import Data.Vector.Internal.Check (HasCallStack)
import qualified Language.C as C
+import qualified Language.C.Data.Ident as C
data Context = Context
- { keepMain :: !Bool
+ { keywords :: !(Set.Set Keyword)
, typeDefs :: !(Map.Map C.Ident [C.CDeclarationSpecifier C.NodeInfo])
}
-defaultReduceC :: (CReducible a, MonadReduce String m) => a -> m a
-defaultReduceC a = runReaderT (reduceC a) defaultContext
+data Keyword
+ = KeepMain
+ | DoNoops
+ | NoSemantics
+ deriving (Show, Read, Enum, Eq, Ord)
+
+type CM m = (MonadReduce (String, C.Position) m, MonadReader Context m, MonadFail m)
+
+defaultReduceC :: (CReducible a, MonadReduce (String, C.Position) m) => a -> m (Maybe a)
+defaultReduceC a = runMaybeT (runReaderT (reduceC a) defaultContext)
addTypeDefs :: [C.Ident] -> [C.CDeclarationSpecifier C.NodeInfo] -> Context -> Context
addTypeDefs ids cs Context{..} =
@@ -39,60 +52,228 @@ addTypeDefs ids cs Context{..} =
defaultContext :: Context
defaultContext =
Context
- { keepMain = True
+ { keywords = Set.fromList [KeepMain]
, typeDefs = Map.empty
}
+keyword :: (MonadReader Context m) => Keyword -> m Bool
+keyword s = asks (Set.member s . keywords)
+
class CReducible a where
- reduceC :: (MonadReduce String m) => a -> ReaderT Context m a
+ reduceC :: (CM m) => a -> m a
instance CReducible C.CTranslUnit where
reduceC (C.CTranslUnit es ni) = do
- es' <- reduceDeclarations es
+ es' <- foldr reduceCExternalDeclaration (pure []) es
pure $ C.CTranslUnit es' ni
where
- reduceDeclarations = \case
- [] -> pure []
- r : rest -> reduceCExternalDeclaration r (reduceDeclarations rest)
-
reduceCExternalDeclaration r cont = do
- shouldKeepMain <- asks keepMain
+ shouldKeepMain <- keyword KeepMain
case r of
C.CFDefExt fun
| shouldKeepMain && maybe False (("main" ==) . C.identToString) (functionName fun) -> do
r' <- C.CFDefExt <$> reduceC fun
(r' :) <$> cont
| otherwise ->
- split ("remove function " <> show (functionName fun)) cont do
+ split ("remove function " <> maybe "" C.identToString (functionName fun), C.posOf r) cont do
r' <- C.CFDefExt <$> reduceC fun
(r' :) <$> cont
C.CDeclExt result ->
case result of
-- A typedef
- C.CDecl (C.CStorageSpec (C.CTypedef _) : rst) decl _ -> do
- let ids = identifiers decl
+ C.CDecl (C.CStorageSpec (C.CTypedef n) : rst) decl _ -> do
+ let [ids] = identifiers decl
split
- ("inline typedefs " <> show ids)
- (local (addTypeDefs ids rst) cont)
- ((r :) <$> cont)
- a -> error (show a)
- _r -> error (show r)
+ ("inline typedef " <> C.identToString ids, C.posOf r)
+ (local (addTypeDefs [ids] rst) cont)
+ ((r :) <$> local (addTypeDefs [ids] [C.CTypeSpec (C.CTypeDef ids n)]) cont)
+ a -> don'tHandle a
+ _r -> don'tHandle r
+
+prettyIdent :: C.Identifier C.NodeInfo -> [Char]
+prettyIdent (C.Ident s _ a) = s ++ " at " ++ show (C.posOfNode a)
instance CReducible C.CFunDef where
reduceC r = do
C.CFunDef spc dec cdecls smt ni <- inlineTypeDefs r
- pure $ C.CFunDef spc dec cdecls smt ni
+ smt' <- reduceC smt
+ pure $ C.CFunDef spc dec cdecls smt' ni
+
+reduceCCompoundBlockItem
+ :: (CM m)
+ => C.CCompoundBlockItem C.NodeInfo
+ -> m [C.CCompoundBlockItem C.NodeInfo]
+ -> m [C.CCompoundBlockItem C.NodeInfo]
+reduceCCompoundBlockItem r cont = case r of
+ C.CBlockStmt smt -> do
+ split ("remove statement", C.posOf r) cont do
+ smt' <- reduceC smt
+ (C.CBlockStmt smt' :) <$> cont
+ C.CBlockDecl decl -> do
+ case decl of
+ C.CDecl{} -> do
+ (r :) <$> cont
+ d -> don'tHandle d
+ a -> don'tHandle a
+
+instance CReducible (C.CStatement C.NodeInfo) where
+ reduceC smt = case smt of
+ C.CCompound is cbi ni -> do
+ cbi' <- foldr reduceCCompoundBlockItem (pure []) cbi
+ pure $ C.CCompound is cbi' ni
+ C.CWhile e s dow ni -> do
+ e' <- reduceCExprOrZero e
+ s' <- reduceC s
+ pure $ C.CWhile e' s' dow ni
+ C.CExpr me ni -> do
+ case me of
+ Just e ->
+ splitOn DoNoops ("change to noop", C.posOf smt) (pure $ C.CExpr Nothing ni) do
+ e' <- reduceC e
+ pure $ C.CExpr (Just e') ni
+ Nothing ->
+ pure $ C.CExpr Nothing ni
+ C.CReturn me ni ->
+ case me of
+ Just e -> do
+ e' <- reduceCExprOrZero e
+ pure $ C.CReturn (Just e') ni
+ Nothing ->
+ pure $ C.CReturn Nothing ni
+ a -> don'tHandle a
+
+splitIf :: (MonadReduce l m) => Bool -> l -> m a -> m a -> m a
+splitIf True s a b = split s a b
+splitIf False _ _ b = b
+
+splitOn :: (MonadReduce l m, MonadReader Context m) => Keyword -> l -> m a -> m a -> m a
+splitOn k s a b = do
+ con <- keyword k
+ splitIf con s a b
-inlineTypeDefs :: forall d m. (Data d, MonadReader Context m) => d -> m d
+-- C.CCompound is cbi ni -> do
+-- cbi' <- collect (reduce @C.CCompoundBlockItem) cbi
+-- pure $ C.CCompound is cbi' ni
+-- C.CExpr e ni -> do
+-- e' <- optional do
+-- e' <- liftMaybe e
+-- reduce @C.CExpression e'
+-- pure $ C.CExpr e' ni
+-- C.CIf e s els ni -> do
+-- s' <- reduce s
+-- e' <- optional do
+-- reduce @C.CExpression e
+-- els' <- optional do
+-- els' <- liftMaybe els
+-- given >> reduce els'
+-- 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
+-- reduce s <| do
+-- e1' <- reduce @C.CForInit e1
+-- e2' <- optional $ liftMaybe e2 >>= reduce @C.CExpression
+-- e3' <- optional $ liftMaybe e3 >>= reduce @C.CExpression
+-- s' <- reduce s
+-- pure $ C.CFor e1' e2' e3' s' ni
+-- C.CReturn e ni -> do
+-- e' <- traverse (fmap orZero reduce) 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 -> do
+-- -- todo fix attrs
+-- s' <- reduce s
+-- withFallback s' do
+-- givenThat (Val.is i)
+-- pure $ C.CLabel i s' [] ni
+-- C.CGoto i ni ->
+-- withFallback (C.CExpr Nothing ni) do
+-- givenThat (Val.is i)
+-- pure $ C.CGoto i ni
+-- C.CWhile e s dow ni -> do
+-- e' <- orZero (reduce @C.CExpression e)
+-- s' <- reduce s
+-- pure $ C.CWhile e' s' dow ni
+
+zeroExpr :: C.CExpression C.NodeInfo
+zeroExpr = C.CConst (C.CIntConst (C.cInteger 0) C.undefNode)
+
+reduceCExprOrZero :: (CM m) => C.CExpr -> m C.CExpr
+reduceCExprOrZero expr =
+ splitOn NoSemantics ("replace by zero", C.posOf expr) (pure zeroExpr) do
+ reduceC expr
+
+instance CReducible C.CExpr where
+ reduceC expr = case expr of
+ C.CBinary o elhs erhs ni ->
+ splitOn NoSemantics ("reduce to left", C.posOf elhs) (reduceC elhs) do
+ splitOn NoSemantics ("reduce to right", C.posOf erhs) (reduceC erhs) do
+ elhs' <- reduceC elhs
+ erhs' <- reduceC erhs
+ pure $ C.CBinary o elhs' erhs' ni
+ C.CVar i ni -> do
+ pure $ C.CVar i ni
+ C.CConst x -> do
+ pure $ C.CConst x
+ C.CUnary o elhs ni -> do
+ elhs' <- reduceC elhs
+ splitOn NoSemantics ("reduce to operant", C.posOf expr) (pure elhs') do
+ pure $ C.CUnary o elhs' ni
+ a -> error (show a)
+
+-- C.CCall e es ni -> do
+-- e' <- reduce e
+-- es' <- traverse (fmap orZero reduce) es
+-- pure $ C.CCall e' es' ni
+-- C.CCond ec et ef ni -> do
+-- ec' <- reduce ec
+-- ef' <- reduce ef
+-- et' <- optional do
+-- et' <- liftMaybe et
+-- reduce et'
+-- 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 <- reduce 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' <- reduce @C.CDeclaration cd
+-- e' <- reduce 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 -> do
+-- e1' <- reduce e1
+-- e2' <- orZero (reduce e2)
+-- pure $ C.CIndex e1' e2' ni
+-- C.CMember e i b ni -> do
+-- givenThat (Val.is i)
+-- e' <- reduce e
+-- pure $ C.CMember e' i b ni
+-- C.CComma items ni -> do
+-- C.CComma <$> collectNonEmpty' reduce items <*> pure ni
+-- e -> error (show e)
+-- where
+-- onBothExpr elhs erhs = onBoth (reduce elhs) (reduce erhs)
+
+inlineTypeDefs :: forall d m. (Data d, MonadFail m, MonadReader Context m) => d -> m d
inlineTypeDefs r = do
case eqT @d @[C.CDeclarationSpecifier C.NodeInfo] of
Just Refl -> do
res' :: [[C.CDeclarationSpecifier C.NodeInfo]] <- forM r \case
- a@(C.CTypeSpec (C.CTypeDef idx _)) -> do
+ C.CTypeSpec (C.CTypeDef idx _) -> do
res <- asks (Map.lookup idx . typeDefs)
case res of
Just args -> pure args
- Nothing -> pure [a]
+ Nothing -> fail ("could not find typedef:" <> show idx)
a -> pure [a]
pure (fold res')
Nothing ->
@@ -116,6 +297,9 @@ isMain (C.CFunDef _ (C.CDeclr (Just i) _ _ _ _) _ _ _) =
C.identToString i == "main"
isMain _ow = False
+don'tHandle :: (HasCallStack, Functor f, Show (f ())) => f C.NodeInfo -> b
+don'tHandle f = error (show (f $> ()))
+
-- instance CReducible C.CDeclaration where
-- reduce = \case
-- C.CDecl spc@(C.CStorageSpec (C.CTypedef _) : rst) decl ni -> do
@@ -351,50 +535,6 @@ isMain _ow = False
-- n' <- liftMaybe n
-- reduce @C.CExpression n'
--
--- instance CReducible C.CExpression where
--- reduce = \case
--- C.CVar i ni -> do
--- givenThat (Val.is i)
--- pure $ C.CVar i ni
--- C.CCall e es ni -> do
--- e' <- reduce e
--- es' <- traverse (fmap orZero reduce) es
--- pure $ C.CCall e' es' ni
--- C.CCond ec et ef ni -> do
--- ec' <- reduce ec
--- ef' <- reduce ef
--- et' <- optional do
--- et' <- liftMaybe et
--- reduce et'
--- 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 <- reduce 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' <- reduce @C.CDeclaration cd
--- e' <- reduce 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 -> do
--- e1' <- reduce e1
--- e2' <- orZero (reduce e2)
--- pure $ C.CIndex e1' e2' ni
--- C.CMember e i b ni -> do
--- givenThat (Val.is i)
--- e' <- reduce e
--- pure $ C.CMember e' i b ni
--- C.CComma items ni -> do
--- C.CComma <$> collectNonEmpty' reduce items <*> pure ni
--- e -> error (show e)
--- where
--- onBothExpr elhs erhs = onBoth (reduce elhs) (reduce erhs)
--
-- zeroExp :: C.CExpression C.NodeInfo
-- zeroExp = C.CConst (C.CIntConst (C.cInteger 0) C.undefNode)
diff --git a/rtree-c/test/cases/main.c b/rtree-c/test/cases/main.c
index 2cf2d12..fedd7ec 100644
--- a/rtree-c/test/cases/main.c
+++ b/rtree-c/test/cases/main.c
@@ -1,4 +1,3 @@
// A small test of basic reduction. Should not reduce.
int main() {
- return 0;
}
diff --git a/rtree-c/test/cases/while-loops.c b/rtree-c/test/cases/while-loops.c
new file mode 100644
index 0000000..43d2e9e
--- /dev/null
+++ b/rtree-c/test/cases/while-loops.c
@@ -0,0 +1,6 @@
+int main () {
+ int i = 0;
+ while (i < 10) {
+ i ++;
+ }
+}
diff --git a/rtree-c/test/expected/main/main.c b/rtree-c/test/expected/main/main.c
index 905869d..5047a34 100644
--- a/rtree-c/test/expected/main/main.c
+++ b/rtree-c/test/expected/main/main.c
@@ -1,4 +1,3 @@
int main()
{
- return 0;
}
diff --git a/rtree-c/test/expected/main/reduction/r.c b/rtree-c/test/expected/main/reduction/r.c
index 905869d..5047a34 100644
--- a/rtree-c/test/expected/main/reduction/r.c
+++ b/rtree-c/test/expected/main/reduction/r.c
@@ -1,4 +1,3 @@
int main()
{
- return 0;
}
diff --git a/rtree-c/test/expected/main/reduction/r.choices b/rtree-c/test/expected/main/reduction/r.choices
new file mode 100644
index 0000000..e69de29
diff --git a/rtree-c/test/expected/typedef/reduction/r00.c b/rtree-c/test/expected/typedef/reduction/r000.c
similarity index 100%
rename from rtree-c/test/expected/typedef/reduction/r00.c
rename to rtree-c/test/expected/typedef/reduction/r000.c
diff --git a/rtree-c/test/expected/typedef/reduction/r000.choices b/rtree-c/test/expected/typedef/reduction/r000.choices
new file mode 100644
index 0000000..b281d1c
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r000.choices
@@ -0,0 +1,3 @@
+0 remove statement at ("test/cases/typedef.c": line 9)
+0 remove function f at ("test/cases/typedef.c": line 4)
+0 inline typedef uint64 at ("test/cases/typedef.c": line 2)
diff --git a/rtree-c/test/expected/typedef/reduction/r001.c b/rtree-c/test/expected/typedef/reduction/r001.c
new file mode 100644
index 0000000..b7888ce
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r001.c
@@ -0,0 +1,8 @@
+typedef int uint64;
+void f(uint64 a)
+{
+}
+int main()
+{
+ uint64 x = 1;
+}
diff --git a/rtree-c/test/expected/typedef/reduction/r001.choices b/rtree-c/test/expected/typedef/reduction/r001.choices
new file mode 100644
index 0000000..a44e5d5
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r001.choices
@@ -0,0 +1,3 @@
+1 remove statement at ("test/cases/typedef.c": line 9)
+0 remove function f at ("test/cases/typedef.c": line 4)
+0 inline typedef uint64 at ("test/cases/typedef.c": line 2)
diff --git a/rtree-c/test/expected/typedef/reduction/r01.c b/rtree-c/test/expected/typedef/reduction/r010.c
similarity index 100%
rename from rtree-c/test/expected/typedef/reduction/r01.c
rename to rtree-c/test/expected/typedef/reduction/r010.c
diff --git a/rtree-c/test/expected/typedef/reduction/r010.choices b/rtree-c/test/expected/typedef/reduction/r010.choices
new file mode 100644
index 0000000..dbaeb2c
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r010.choices
@@ -0,0 +1,3 @@
+0 remove statement at ("test/cases/typedef.c": line 9)
+1 remove function f at ("test/cases/typedef.c": line 4)
+0 inline typedef uint64 at ("test/cases/typedef.c": line 2)
diff --git a/rtree-c/test/expected/typedef/reduction/r011.c b/rtree-c/test/expected/typedef/reduction/r011.c
new file mode 100644
index 0000000..1ab8fec
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r011.c
@@ -0,0 +1,5 @@
+typedef int uint64;
+int main()
+{
+ uint64 x = 1;
+}
diff --git a/rtree-c/test/expected/typedef/reduction/r011.choices b/rtree-c/test/expected/typedef/reduction/r011.choices
new file mode 100644
index 0000000..92fc7ae
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r011.choices
@@ -0,0 +1,3 @@
+1 remove statement at ("test/cases/typedef.c": line 9)
+1 remove function f at ("test/cases/typedef.c": line 4)
+0 inline typedef uint64 at ("test/cases/typedef.c": line 2)
diff --git a/rtree-c/test/expected/typedef/reduction/r10.c b/rtree-c/test/expected/typedef/reduction/r100.c
similarity index 100%
rename from rtree-c/test/expected/typedef/reduction/r10.c
rename to rtree-c/test/expected/typedef/reduction/r100.c
diff --git a/rtree-c/test/expected/typedef/reduction/r100.choices b/rtree-c/test/expected/typedef/reduction/r100.choices
new file mode 100644
index 0000000..48c32e1
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r100.choices
@@ -0,0 +1,3 @@
+0 remove statement at ("test/cases/typedef.c": line 9)
+0 remove function f at ("test/cases/typedef.c": line 4)
+1 inline typedef uint64 at ("test/cases/typedef.c": line 2)
diff --git a/rtree-c/test/expected/typedef/reduction/r101.c b/rtree-c/test/expected/typedef/reduction/r101.c
new file mode 100644
index 0000000..975eaa4
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r101.c
@@ -0,0 +1,7 @@
+void f(int a)
+{
+}
+int main()
+{
+ int x = 1;
+}
diff --git a/rtree-c/test/expected/typedef/reduction/r101.choices b/rtree-c/test/expected/typedef/reduction/r101.choices
new file mode 100644
index 0000000..76ba083
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r101.choices
@@ -0,0 +1,3 @@
+1 remove statement at ("test/cases/typedef.c": line 9)
+0 remove function f at ("test/cases/typedef.c": line 4)
+1 inline typedef uint64 at ("test/cases/typedef.c": line 2)
diff --git a/rtree-c/test/expected/typedef/reduction/r11.c b/rtree-c/test/expected/typedef/reduction/r110.c
similarity index 100%
rename from rtree-c/test/expected/typedef/reduction/r11.c
rename to rtree-c/test/expected/typedef/reduction/r110.c
diff --git a/rtree-c/test/expected/typedef/reduction/r110.choices b/rtree-c/test/expected/typedef/reduction/r110.choices
new file mode 100644
index 0000000..e70ee97
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r110.choices
@@ -0,0 +1,3 @@
+0 remove statement at ("test/cases/typedef.c": line 9)
+1 remove function f at ("test/cases/typedef.c": line 4)
+1 inline typedef uint64 at ("test/cases/typedef.c": line 2)
diff --git a/rtree-c/test/expected/typedef/reduction/r111.c b/rtree-c/test/expected/typedef/reduction/r111.c
new file mode 100644
index 0000000..a382e8e
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r111.c
@@ -0,0 +1,4 @@
+int main()
+{
+ int x = 1;
+}
diff --git a/rtree-c/test/expected/typedef/reduction/r111.choices b/rtree-c/test/expected/typedef/reduction/r111.choices
new file mode 100644
index 0000000..bceac89
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r111.choices
@@ -0,0 +1,3 @@
+1 remove statement at ("test/cases/typedef.c": line 9)
+1 remove function f at ("test/cases/typedef.c": line 4)
+1 inline typedef uint64 at ("test/cases/typedef.c": line 2)
diff --git a/rtree-c/test/expected/while-loops/main.c b/rtree-c/test/expected/while-loops/main.c
new file mode 100644
index 0000000..cf4c537
--- /dev/null
+++ b/rtree-c/test/expected/while-loops/main.c
@@ -0,0 +1,8 @@
+int main()
+{
+ int i = 0;
+ while (i < 10)
+ {
+ i++;
+ }
+}
diff --git a/rtree-c/test/expected/while-loops/reduction/r00.c b/rtree-c/test/expected/while-loops/reduction/r00.c
new file mode 100644
index 0000000..cf4c537
--- /dev/null
+++ b/rtree-c/test/expected/while-loops/reduction/r00.c
@@ -0,0 +1,8 @@
+int main()
+{
+ int i = 0;
+ while (i < 10)
+ {
+ i++;
+ }
+}
diff --git a/rtree-c/test/expected/while-loops/reduction/r00.choices b/rtree-c/test/expected/while-loops/reduction/r00.choices
new file mode 100644
index 0000000..4fee46c
--- /dev/null
+++ b/rtree-c/test/expected/while-loops/reduction/r00.choices
@@ -0,0 +1,2 @@
+0 remove statement at ("test/cases/while-loops.c": line 4)
+0 remove statement at ("test/cases/while-loops.c": line 3)
diff --git a/rtree-c/test/expected/while-loops/reduction/r01.c b/rtree-c/test/expected/while-loops/reduction/r01.c
new file mode 100644
index 0000000..714143b
--- /dev/null
+++ b/rtree-c/test/expected/while-loops/reduction/r01.c
@@ -0,0 +1,7 @@
+int main()
+{
+ int i = 0;
+ while (i < 10)
+ {
+ }
+}
diff --git a/rtree-c/test/expected/while-loops/reduction/r01.choices b/rtree-c/test/expected/while-loops/reduction/r01.choices
new file mode 100644
index 0000000..69ec6af
--- /dev/null
+++ b/rtree-c/test/expected/while-loops/reduction/r01.choices
@@ -0,0 +1,2 @@
+1 remove statement at ("test/cases/while-loops.c": line 4)
+0 remove statement at ("test/cases/while-loops.c": line 3)
diff --git a/rtree-c/test/expected/while-loops/reduction/r1.c b/rtree-c/test/expected/while-loops/reduction/r1.c
new file mode 100644
index 0000000..28c5719
--- /dev/null
+++ b/rtree-c/test/expected/while-loops/reduction/r1.c
@@ -0,0 +1,4 @@
+int main()
+{
+ int i = 0;
+}
diff --git a/rtree-c/test/expected/while-loops/reduction/r1.choices b/rtree-c/test/expected/while-loops/reduction/r1.choices
new file mode 100644
index 0000000..efbb594
--- /dev/null
+++ b/rtree-c/test/expected/while-loops/reduction/r1.choices
@@ -0,0 +1 @@
+1 remove statement at ("test/cases/while-loops.c": line 3)
diff --git a/rtree-c/test/src/ReduceCSpec.hs b/rtree-c/test/src/ReduceCSpec.hs
index 00c2ba0..f447df9 100644
--- a/rtree-c/test/src/ReduceCSpec.hs
+++ b/rtree-c/test/src/ReduceCSpec.hs
@@ -17,11 +17,13 @@ import Test.Hspec.Glitter
import qualified Language.C as C
import qualified Text.PrettyPrint as P
-import Control.Monad.RTree (extract, iinputs)
+import Control.Monad.RTree (extract, iinputs, probe)
+import Data.Bool
import Data.Functor
import Data.RPath
import qualified Language.C.System.GCC as C
import ReduceC
+import System.Directory.Internal.Prelude (tryIOError)
import System.Process.Typed
spec :: Spec
@@ -31,45 +33,55 @@ spec = do
forM_ cases \cname -> do
let cfrom = "test/cases" </> cname
- c <- runIO $ parse cfrom
-
- let expected = "test/expected" </> dropExtensions cname
- onGlitterWith (expected </> "main.c") (\fp () -> render fp c) do
- 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)
- Right c' -> c' $> () `shouldBe` c $> ()
-
- describe "reduction" do
- it "should extract itself" do
- extract (defaultReduceC c) `shouldBe` c
-
- onGlitterWith
- (expected </> "reduction/")
- ( \a () -> do
- removeDirectoryRecursive a
- createDirectoryIfMissing True a
- forM_ (take 20 $ iinputs (defaultReduceC c)) \(i, c') -> do
- let rfile = expected </> "reduction" </> "r" <> debugShow i <.> "c"
- render rfile c'
- )
- do
- it "should validate all reductions" . mapM_ $ \a -> do
- validate a
+ describe cfrom do
+ c <- runIO $ parse cfrom
+
+ let expected = "test/expected" </> dropExtensions cname
+ onGlitterWith (expected </> "main.c") (\fp () -> render fp c) do
+ 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)
+ Right c' -> c' $> () `shouldBe` c $> ()
+
+ describe "reduction" do
+ it "should extract itself" do
+ fmap ($> ()) (extract $ defaultReduceC c) `shouldBe` Just (c $> ())
+
+ onGlitterWith
+ (expected </> "reduction/")
+ ( \a () -> do
+ _ <- tryIOError (removeDirectoryRecursive a)
+ createDirectoryIfMissing True a
+ forM_ (iinputs (defaultReduceC c)) \(i, c') -> do
+ let rfile = expected </> "reduction" </> "r" <> debugShow i <.> "c"
+ maybe (writeFile rfile "") (render rfile) c'
+ let cofile = expected </> "reduction" </> "r" <> debugShow i <.> "choices"
+ writeFile
+ cofile
+ ( unlines
+ . map (\(choice, (reason, pos)) -> bool "0" "1" choice <> " " <> reason <> " at " <> show pos)
+ . snd
+ $ probe (defaultReduceC c) i
+ )
+ )
+ do
+ it "should validate all reductions" . mapM_ $ \a -> do
+ when (takeExtension a == ".c") do
+ validate a
validate :: FilePath -> IO ()
validate fp = do
- (ec, res) <- readProcessStderr (proc "clang" ["-o", "/dev/null", fp])
+ (ec, _, stderr) <- readProcess (proc "clang" ["-o", "/dev/null", fp])
case ec of
ExitFailure _ ->
expectationFailure $
"could not validate "
<> show fp
<> "\n"
- <> LazyText.unpack (LazyText.decodeUtf8 res)
+ <> LazyText.unpack (LazyText.decodeUtf8 stderr)
ExitSuccess -> pure ()
render :: FilePath -> C.CTranslUnit -> IO ()
diff --git a/rtree/src/Control/Monad/RTree.hs b/rtree/src/Control/Monad/RTree.hs
index 728b8db..f93cec6 100644
--- a/rtree/src/Control/Monad/RTree.hs
+++ b/rtree/src/Control/Monad/RTree.hs
@@ -17,6 +17,7 @@ module Control.Monad.RTree (
extract,
inputs,
iinputs,
+ probe,
reduce,
drawRTree,
@@ -83,6 +84,16 @@ inputs = toList
iinputs :: RTree l i -> [(RPath, i)]
iinputs = itoList
+probe :: RTree l i -> RPath -> (i, [(Bool, l)])
+probe tree pth = go 0 id tree
+ where
+ go idx res = \case
+ Done i -> (i, res [])
+ Split l rhs lhs ->
+ let b = pth `indexChoice` idx
+ in go (idx + 1) (((b, l) :) . res) (if b then rhs else lhs)
+{-# INLINE probe #-}
+
-- | For debugging purposes
drawRTree :: (l -> ShowS) -> (i -> ShowS) -> RTree l i -> String
drawRTree ppl ppi = concat . go id
--
GitLab