diff --git a/flake.lock b/flake.lock
index 4511fea6298812ad362e88ecdb38403dcc45b95f..df4c0e197201cac7815a661a39efe1f0f52b006d 100644
--- a/flake.lock
+++ b/flake.lock
@@ -46,7 +46,7 @@
"dirtyRev": "979d17cf356e3a336dac8820c676ec813668222c-dirty",
"dirtyShortRev": "979d17c-dirty",
"lastModified": 1708504824,
- "narHash": "sha256-xr0mfkl3yzwGcI+oDIi168tB/ERzehI1qO4W5bfji0s=",
+ "narHash": "sha256-4B1Tb847DHviKPsOLbKwjCUsrDCegXeKtDO7FTHgxts=",
"type": "git",
"url": "file:///Users/chrg/Develop/repos/hspec-glitter"
},
diff --git a/rtree-c/package.yaml b/rtree-c/package.yaml
index 9b4cfa28f18a716fa6222cf5e62f591babfc7b1e..41b1531366a781a2fd25dc59e27359407ade0539 100644
--- a/rtree-c/package.yaml
+++ b/rtree-c/package.yaml
@@ -50,3 +50,4 @@ tests:
- directory
- filepath
- typed-process
+ - text
diff --git a/rtree-c/rtree-c.cabal b/rtree-c/rtree-c.cabal
index 72531846565992aa5b65cbe66705f3a1a03e3e67..e7b721695b53c28904bbd07164bf1fb506acd53a 100644
--- a/rtree-c/rtree-c.cabal
+++ b/rtree-c/rtree-c.cabal
@@ -80,6 +80,7 @@ test-suite rtree-c-test
, pretty-simple
, rtree
, rtree-c
+ , text
, transformers
, typed-process
, vector
diff --git a/rtree-c/src/ReduceC.hs b/rtree-c/src/ReduceC.hs
index cfaebdf3cc80576b92c4c9511ec562d1bedaadc4..7703d295767db9a3da13feb4cec7bc63c643e5d3 100644
--- a/rtree-c/src/ReduceC.hs
+++ b/rtree-c/src/ReduceC.hs
@@ -5,35 +5,167 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module ReduceC where
+import Control.Monad.Reader
import Control.Monad.Reduce
+import Data.Data
+import Data.Foldable
+import qualified Data.Map.Strict as Map
import qualified Language.C as C
data Context = Context
+ { keepMain :: !Bool
+ , typeDefs :: !(Map.Map C.Ident [C.CDeclarationSpecifier C.NodeInfo])
+ }
+
+defaultReduceC :: (CReducible a, MonadReduce String m) => a -> m a
+defaultReduceC a = runReaderT (reduceC a) defaultContext
+
+addTypeDefs :: [C.Ident] -> [C.CDeclarationSpecifier C.NodeInfo] -> Context -> Context
+addTypeDefs ids cs Context{..} =
+ Context
+ { typeDefs =
+ foldl' (\a i -> Map.insert i cs a) typeDefs ids
+ , ..
+ }
+
+defaultContext :: Context
+defaultContext =
+ Context
+ { keepMain = True
+ , typeDefs = Map.empty
+ }
class CReducible a where
- reduceC :: (MonadReduce String m) => a -> m a
+ reduceC :: (MonadReduce String m) => a -> ReaderT Context m a
instance CReducible C.CTranslUnit where
reduceC (C.CTranslUnit es ni) = do
- es' <- rList es
- -- es' <- collect reduceCExternalDeclaration es
+ es' <- reduceDeclarations es
pure $ C.CTranslUnit es' ni
where
- rList (a : as) = rList as <| ((a :) <$> rList as)
- rList [] = pure []
+ reduceDeclarations = \case
+ [] -> pure []
+ r : rest -> reduceCExternalDeclaration r (reduceDeclarations rest)
+
+ reduceCExternalDeclaration r cont = do
+ shouldKeepMain <- asks 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
+ 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
+ split
+ ("inline typedefs " <> show ids)
+ (local (addTypeDefs ids rst) cont)
+ ((r :) <$> cont)
+ a -> error (show a)
+ _r -> error (show r)
+
+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
+
+inlineTypeDefs :: forall d m. (Data d, 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
+ res <- asks (Map.lookup idx . typeDefs)
+ case res of
+ Just args -> pure args
+ Nothing -> pure [a]
+ a -> pure [a]
+ pure (fold res')
+ Nothing ->
+ gmapM inlineTypeDefs r
+
+-- instance CReducible C.CExtDecl where
+-- reduceC (C.CFunDef spc dec cdecls smt ni) = do
+-- pure $ C.CFunDef spc dec cdecls smt ni
+
+identifiers :: forall a. (Data a) => a -> [C.Ident]
+identifiers d = case cast d of
+ Just l -> [l]
+ Nothing -> concat $ gmapQ identifiers d
--- reduceCExternalDeclaration = \case
--- C.CFDefExt fun -> do
--- C.CFDefExt <$> reduce @C.CFunctionDef fun
--- C.CDeclExt decl ->
--- C.CDeclExt <$> reduce @C.CDeclaration decl
--- [] -> error (show a)
+functionName :: C.CFunctionDef C.NodeInfo -> Maybe C.Ident
+functionName = \case
+ C.CFunDef _ (C.CDeclr ix _ _ _ _) _ _ _ -> ix
+
+isMain :: C.CFunctionDef C.NodeInfo -> Bool
+isMain (C.CFunDef _ (C.CDeclr (Just i) _ _ _ _) _ _ _) =
+ C.identToString i == "main"
+isMain _ow = False
+
+-- instance CReducible C.CDeclaration where
+-- reduce = \case
+-- C.CDecl spc@(C.CStorageSpec (C.CTypedef _) : rst) decl ni -> do
+-- decl' <-
+-- decl & collectNonEmpty' \case
+-- C.CDeclarationItem d Nothing Nothing -> do
+-- let (x, _) = cDeclaratorIdentifiers d
+-- case x of
+-- Just x' ->
+-- splitOn
+-- (Val.is x')
+-- ( do
+-- modify (Map.insert x' (Type rst))
+-- mzero
+-- )
+-- (pure $ C.CDeclarationItem d Nothing Nothing)
+-- Nothing ->
+-- pure $ C.CDeclarationItem d Nothing Nothing
+-- a -> error (show a)
+-- pure (C.CDecl spc decl' ni)
+-- C.CDecl spc@[C.CTypeSpec (C.CTypeDef i ni')] decl ni -> do
+-- x <- gets (Map.lookup i)
+-- case x of
+-- Just (Type rst) -> do
+-- decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers rst) decl
+-- pure $ C.CDecl rst decl' ni
+-- Nothing -> do
+-- decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers spc) decl
+-- pure $ C.CDecl spc decl' ni
+-- C.CDecl spc decl ni -> do
+-- decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers spc) decl
+-- pure $ C.CDecl spc decl' ni
+-- a -> error (show a)
+-- where
+-- reduceCDeclarationItem rq' = \case
+-- C.CDeclarationItem d i e -> do
+-- let (fn, reqs) = cDeclaratorIdentifiers d
+-- case fn of
+-- Just fn' ->
+-- conditionalGivenThat (rq' <> reqs) (Val.is fn')
+-- Nothing ->
+-- mapM_ (givenThat . Val.is) (rq' <> reqs)
+--
+-- i' <- optional do
+-- liftMaybe i >>= reduce @C.CInitializer
+-- e' <- optional do
+-- liftMaybe e >>= reduce @C.CExpression
+--
+-- pure (C.CDeclarationItem d i' e')
+-- a -> error (show a)
-- import Control.Monad.Reduce
--
diff --git a/rtree-c/test/cases/typedef.c b/rtree-c/test/cases/typedef.c
new file mode 100644
index 0000000000000000000000000000000000000000..c52771a3562daf1818c4651c20cea87cd942f7e4
--- /dev/null
+++ b/rtree-c/test/cases/typedef.c
@@ -0,0 +1,10 @@
+// Test typdefs
+typedef int uint64;
+
+void f(uint64 a) {
+}
+
+int main () {
+ uint64 x = 1;
+ return x;
+}
diff --git a/rtree-c/test/expected/main/reduction/r0.c b/rtree-c/test/expected/main/reduction/r.c
similarity index 100%
rename from rtree-c/test/expected/main/reduction/r0.c
rename to rtree-c/test/expected/main/reduction/r.c
diff --git a/rtree-c/test/expected/main/reduction/r1.c b/rtree-c/test/expected/main/reduction/r1.c
deleted file mode 100644
index 8b137891791fe96927ad78e64b0aad7bded08bdc..0000000000000000000000000000000000000000
--- a/rtree-c/test/expected/main/reduction/r1.c
+++ /dev/null
@@ -1 +0,0 @@
-
diff --git a/rtree-c/test/expected/typedef/main.c b/rtree-c/test/expected/typedef/main.c
new file mode 100644
index 0000000000000000000000000000000000000000..2d12abfdb9cc226bafde9fb5149242644c4495a5
--- /dev/null
+++ b/rtree-c/test/expected/typedef/main.c
@@ -0,0 +1,9 @@
+typedef int uint64;
+void f(uint64 a)
+{
+}
+int main()
+{
+ uint64 x = 1;
+ return x;
+}
diff --git a/rtree-c/test/expected/typedef/reduction/r00.c b/rtree-c/test/expected/typedef/reduction/r00.c
new file mode 100644
index 0000000000000000000000000000000000000000..2d12abfdb9cc226bafde9fb5149242644c4495a5
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r00.c
@@ -0,0 +1,9 @@
+typedef int uint64;
+void f(uint64 a)
+{
+}
+int main()
+{
+ uint64 x = 1;
+ return x;
+}
diff --git a/rtree-c/test/expected/typedef/reduction/r01.c b/rtree-c/test/expected/typedef/reduction/r01.c
new file mode 100644
index 0000000000000000000000000000000000000000..e187d4389678c2fe0beb909748d5068576881ad6
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r01.c
@@ -0,0 +1,6 @@
+typedef int uint64;
+int main()
+{
+ uint64 x = 1;
+ return x;
+}
diff --git a/rtree-c/test/expected/typedef/reduction/r10.c b/rtree-c/test/expected/typedef/reduction/r10.c
new file mode 100644
index 0000000000000000000000000000000000000000..3ec3f43dc2f6d9812a949c37909b202f4e869600
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r10.c
@@ -0,0 +1,8 @@
+void f(int a)
+{
+}
+int main()
+{
+ int x = 1;
+ return x;
+}
diff --git a/rtree-c/test/expected/typedef/reduction/r11.c b/rtree-c/test/expected/typedef/reduction/r11.c
new file mode 100644
index 0000000000000000000000000000000000000000..2eb183391c1758706c3c6b3eb3d4f15461b17699
--- /dev/null
+++ b/rtree-c/test/expected/typedef/reduction/r11.c
@@ -0,0 +1,5 @@
+int main()
+{
+ int x = 1;
+ return x;
+}
diff --git a/rtree-c/test/src/ReduceCSpec.hs b/rtree-c/test/src/ReduceCSpec.hs
index 0375b6757602d635bedda21465d7d5bc5c242b16..00c2ba06d9e96f5959aa97a07991d54668f3997b 100644
--- a/rtree-c/test/src/ReduceCSpec.hs
+++ b/rtree-c/test/src/ReduceCSpec.hs
@@ -9,6 +9,9 @@ import System.Directory
import System.FilePath
import Test.Hspec
+import qualified Data.Text.Lazy as LazyText
+import qualified Data.Text.Lazy.Encoding as LazyText
+
import Test.Hspec.Glitter
import qualified Language.C as C
@@ -42,13 +45,14 @@ spec = do
describe "reduction" do
it "should extract itself" do
- extract (reduceC c) `shouldBe` c
+ extract (defaultReduceC c) `shouldBe` c
onGlitterWith
- (expected </> "reduction")
+ (expected </> "reduction/")
( \a () -> do
+ removeDirectoryRecursive a
createDirectoryIfMissing True a
- forM_ (take 20 $ iinputs (reduceC c)) \(i, c') -> do
+ forM_ (take 20 $ iinputs (defaultReduceC c)) \(i, c') -> do
let rfile = expected </> "reduction" </> "r" <> debugShow i <.> "c"
render rfile c'
)
@@ -58,9 +62,14 @@ spec = do
validate :: FilePath -> IO ()
validate fp = do
- ec <- runProcess (proc "clang" ["-o", "/dev/null", fp])
+ (ec, res) <- readProcessStderr (proc "clang" ["-o", "/dev/null", fp])
case ec of
- ExitFailure _ -> fail ("could not validate " <> show fp)
+ ExitFailure _ ->
+ expectationFailure $
+ "could not validate "
+ <> show fp
+ <> "\n"
+ <> LazyText.unpack (LazyText.decodeUtf8 res)
ExitSuccess -> pure ()
render :: FilePath -> C.CTranslUnit -> IO ()