Work in progress

.gitignore

@@ -25,3 +25,7 @@ cabal.project.local~
 .DS_Store
 
 result
+
+a.out
+rtree-c
+test.c

bin/rtree-c/Main.hs

+{-# 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)

flake.lock

@@ -21,11 +21,11 @@
     "language-c": {
       "flake": false,
       "locked": {
-        "lastModified": 1664454938,
-        "narHash": "sha256-GDjXcq0oYNDGSIWO6kkIgF13RMwykDpUyAQAWRYEOUc=",
+        "lastModified": 1701177364,
+        "narHash": "sha256-SwRI8+PNfzfHOjFcn7bvgAylJeUMaFsvlJPm2r3QhTY=",
         "owner": "kalhauge",
         "repo": "language-c",
-        "rev": "0b2f7bf94789b09bbf1e7a1ab80b62f99e1e92f7",
+        "rev": "bdbf9f641149f5879dc23eb9e153e573d9355cbd",
         "type": "github"
       },
       "original": {

flake.nix

@@ -2,63 +2,62 @@
   inputs = {
     nixpkgs.url = github:nixos/nixpkgs/nixpkgs-unstable;
     flake-utils.url = github:numtide/flake-utils;
-    language-c = { url = github:kalhauge/language-c; flake = false; };
+    language-c = {
+      url = github:kalhauge/language-c;
+      flake = false;
+    };
   };
-  outputs =
-    { self
-    , nixpkgs
-    , flake-utils
-    , ...
-    }@inputs:
-    let
-      packages = final: p: {
-        "rtree" = p.callCabal2nixWithOptions "rtree" "${self}" "" { };
-        "language-c" =
-          final.haskell.lib.overrideCabal
-            (p.callCabal2nixWithOptions "language-c" inputs.language-c "" { })
-            {
-              doCheck = false;
-            };
-      };
-      overlays = final: prev: {
-        haskellPackages = prev.haskellPackages.extend (p: _: packages final p);
-      };
-    in
+  outputs = {
+    self,
+    nixpkgs,
+    flake-utils,
+    ...
+  } @ inputs: let
+    packages = final: p: {
+      "rtree" = p.callCabal2nixWithOptions "rtree" "${self}" "" {};
+      "language-c" =
+        final.haskell.lib.overrideCabal
+        (p.callCabal2nixWithOptions "language-c" inputs.language-c "" {}) {
+          doCheck = false;
+        };
+    };
+    overlays = final: prev: {
+      haskellPackages = prev.haskellPackages.extend (p: _: packages final p);
+    };
+  in
     {
       overlays.default = overlays;
-    } //
-    flake-utils.lib.eachDefaultSystem
-      (system:
-      let
-        hpkgs = (import nixpkgs {
+    }
+    // flake-utils.lib.eachDefaultSystem
+    (system: let
+      hpkgs =
+        (import nixpkgs {
           inherit system;
-          overlays = [ overlays ];
-        }).haskellPackages;
-      in
-      rec {
-        packages = {
-          default = hpkgs.rtree;
-          rtree = hpkgs.rtree;
-        };
-        devShells =
-          let
-            buildInputs = with hpkgs; [
-              cabal-install
-              ghcid
-              haskell-language-server
-              hpack
-              fourmolu
-            ];
-            withHoogle = true;
-          in
+          overlays = [overlays];
+        })
+        .haskellPackages;
+    in rec {
+      packages = {
+        default = hpkgs.rtree;
+        rtree = hpkgs.rtree;
+      };
+      devShells = let
+        buildInputs = with hpkgs; [
+          cabal-install
+          ghcid
+          haskell-language-server
+          hpack
+          fourmolu
+        ];
+        withHoogle = true;
+      in {
+        default =
+          hpkgs.shellFor
           {
-            default = hpkgs.shellFor
-              {
-                name = "rtree-shell";
-                packages = p:
-                  [ p.rtree ];
-                inherit buildInputs withHoogle;
-              };
+            name = "rtree-shell";
+            packages = p: [p.rtree];
+            inherit buildInputs withHoogle;
           };
-      });
+      };
+    });
 }

package.yaml

@@ -5,7 +5,7 @@ name: rtree
 # category: categories
 # extra-source-files: []
 
-ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
+ghc-options: -Wall -fno-warn-incomplete-uni-patterns 
 
 dependencies:
   - base >= 4.9 && < 5
@@ -13,11 +13,21 @@ dependencies:
   - free
   - data-fix
   - mtl
-  - language-c
+  - containers
 
 library:
   source-dirs: src
 
+executables:
+  rtree-c: 
+    source-dirs: bin/rtree-c
+    main: Main.hs
+    dependencies:
+      - rtree
+      - language-c
+      - typed-process
+      - pretty
+
 tests:
   rtree-test:
     source-dirs: test/src

rtree.cabal

@@ -15,14 +15,34 @@ library
       Paths_rtree
   hs-source-dirs:
       src
-  ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns
   build-depends:
       base >=4.9 && <5
+    , containers
+    , data-fix
+    , free
+    , mtl
+    , transformers
+  default-language: Haskell2010
+
+executable rtree-c
+  main-is: Main.hs
+  other-modules:
+      Paths_rtree
+  hs-source-dirs:
+      bin/rtree-c
+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns
+  build-depends:
+      base >=4.9 && <5
+    , containers
     , data-fix
     , free
     , language-c
     , mtl
+    , pretty
+    , rtree
     , transformers
+    , typed-process
   default-language: Haskell2010
 
 test-suite rtree-test
@@ -32,9 +52,10 @@ test-suite rtree-test
       Paths_rtree
   hs-source-dirs:
       test/src
-  ghc-options: -Wall -fno-warn-incomplete-uni-patterns -Werror
+  ghc-options: -Wall -fno-warn-incomplete-uni-patterns
   build-depends:
       base >=4.9 && <5
+    , containers
     , data-fix
     , diagrams
     , diagrams-contrib
@@ -42,7 +63,6 @@ test-suite rtree-test
     , diagrams-lib
     , diagrams-svg
     , free
-    , language-c
     , mtl
     , rtree
     , transformers

src/Control/RTree.hs

@@ -2,11 +2,13 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE ViewPatterns #-}
 
@@ -16,61 +18,191 @@ Module: Control.RTree
 module Control.RTree where
 
 import Control.Applicative (Alternative ((<|>)))
-import Data.Functor
+import Data.Coerce (coerce)
 import Data.Functor.Classes
 import qualified Data.List.NonEmpty as NE
+import Data.Void
 
-import Data.Coerce (coerce)
-import "free" Control.Monad.Free
+import qualified Data.List as L
+
+import Control.Monad.Reader
+import "free" Control.Monad.Free.Church
 
--- | The reduction tree
-data RTreeF f
-  = f :<| f
-  | Lab String f f
+-- | The base functor for the reduction tree.
+data RTreeF l f
+  = Split (Maybe l) f f
   deriving (Show, Eq, Functor)
 
-instance Show1 RTreeF where
+instance (Show l) => Show1 (RTreeF l) where
   liftShowsPrec = undefined
 
-newtype RTree i = RTree {rtreeFree :: Free RTreeF i}
-  deriving (Show)
-  deriving (Functor, Applicative, Monad) via (Free RTreeF)
+newtype RTree l i = RTree {rtreeFree :: F (RTreeF l) i}
+  deriving (Functor, Applicative, Monad) via (F (RTreeF l))
 
-instance MonadFree RTreeF RTree where
-  wrap x = RTree (Free (fmap rtreeFree x))
+instance MonadFree (RTreeF l) (RTree l) where
+  wrap x = RTree (wrap (fmap rtreeFree x))
 
 infixr 3 <|
 infixl 3 |>
 
-(<|) :: (MonadFree RTreeF r) => r i -> r i -> r i
-r1 <| r2 = wrap (r1 :<| r2)
+{-# INLINE (<|) #-}
+(<|) :: (MonadFree (RTreeF l) r) => r i -> r i -> r i
+r1 <| r2 = wrap (Split Nothing r1 r2)
 
-lab :: (MonadFree RTreeF r) => String -> r i -> r i -> r i
-lab l r1 r2 = wrap (Lab l r1 r2)
+{-# INLINE splitOn #-}
+splitOn :: (MonadFree (RTreeF l) r) => l -> r i -> r i -> r i
+splitOn l r1 r2 = wrap (Split (Just l) r1 r2)
 
-(|>) :: (MonadFree RTreeF r) => r i -> r i -> r i
-r1 |> r2 = wrap (r2 :<| r1)
+{-# INLINE split #-}
+split :: (MonadFree (RTreeF l) r) => Maybe l -> r i -> r i -> r i
+split l r1 r2 = wrap (Split l r1 r2)
 
-foldR :: (RTreeF a -> a) -> RTree a -> a
+{-# INLINE (|>) #-}
+(|>) :: (MonadFree (RTreeF l) r) => r i -> r i -> r i
+r1 |> r2 = r2 <| r1
+
+{-# INLINE foldR #-}
+foldR :: (RTreeF l a -> a) -> RTree l a -> a
 foldR fn = coerce $ iter fn
 
+foldRM :: (Monad m) => (RTreeF l (m a) -> m a) -> RTree l a -> m a
+foldRM fn = coerce $ iterM fn
+
 -- | Extract the input from the reducer.
-extract :: RTree i -> i
-extract = foldR \case
-  (_ :<| e) -> e
-  Lab _ _ e -> e
+extract :: RTree l i -> i
+extract = foldR \(Split _ _ e) -> e
+
+-- | Remove all labels from a RTree by expanding all choices.
+flatten :: forall i l. (Eq l) => RTree l i -> Maybe (RTree Void i)
+flatten t = foldR go (fmap (const . Just . pure) t) []
+ where
+  go (Split ml lhs rhs) lst =
+    case ml of
+      Just l -> case l `L.lookup` lst of
+        Nothing -> do
+          join' (lhs $ (l, False) : lst) (rhs $ (l, True) : lst)
+        Just True ->
+          join' (lhs lst) (rhs lst)
+        Just False ->
+          Nothing
+      Nothing -> join' (lhs lst) (rhs lst)
+
+  join' mlhs mrhs = do
+    case (mlhs, mrhs) of
+      (Just lhs', Just rhs') -> pure (lhs' <| rhs')
+      _ -> mlhs <|> mrhs
+
+-- | Reduce an input using a monad.
+reduce
+  :: forall m i
+   . (Alternative m)
+  => (i -> m ())
+  -> RTree Void i
+  -> m i
+reduce p t = do
+  let (mi, i') = foldR go $ fmap (\i -> (pure i, i)) t
+  p i' *> mi
+ where
+  go :: RTreeF l (m i, i) -> (m i, i)
+  go (Split _ (lhs, le) (rhs, re)) =
+    ((p le *> lhs) <|> rhs, re)
+{-# INLINE reduce #-}
+
+data RTree' l i
+  = RTree' (RTreeF l (RTree' l i))
+  | Done i
+
+extract' :: RTree' l i -> i
+extract' = \case
+  RTree' (Split _ _ v) -> extract' v
+  Done v -> v
+
+instance Functor (RTree' l) where
+  fmap f (Done i) = Done (f i)
+  fmap f (RTree' r) = RTree' (fmap (fmap f) r)
+
+instance Applicative (RTree' l) where
+  pure = Done
+  (<*>) = ap
+
+instance Monad (RTree' l) where
+  ma >>= f = case ma of
+    Done i -> f i
+    RTree' r ->
+      RTree'
+        (fmap (>>= f) r)
+
+instance MonadFree (RTreeF l) (RTree' l) where
+  wrap = RTree'
+  {-# INLINE wrap #-}
 
 -- | Reduce an input using a monad.
-reduce :: (Alternative m) => (i -> m ()) -> RTree i -> m i
-reduce fn =
-  ( foldR \case
-      lhs :<| rhs -> lhs <|> rhs
-      Lab _ lhs rhs -> lhs <|> rhs
-  )
-    . fmap (\i -> fn i $> i)
+reduce'
+  :: forall m l i
+   . (Alternative m)
+  => (i -> m ())
+  -> RTree' l i
+  -> m i
+reduce' p = checkgo
+ where
+  go = \case
+    (Done i) -> pure i
+    (RTree' (Split _ lhs rhs)) ->
+      (checkgo lhs <|> go rhs)
+  checkgo rt = p (extract' rt) *> go rt
+
+-- newtype I l i = I ([(l, Bool)] -> RTreeI l i)
+--
+-- data RTreeI l i
+--   = RTreeI (RTreeF l (I l i))
+--   | DoneI !i
+
+-- -- This is not a great defintions, as the i does not depend on
+-- -- the current i, but instead on the final I.
+-- data RTreeIO j i = RTreeIO ((j -> IO Bool) -> IO i) j
+--
+-- extractIO :: RTreeIO j i -> j
+-- extractIO (RTreeIO _ i) = i
+
+-- instance Functor (RTreeIO j) where
+--   fmap f (RTreeIO mf i) = RTreeIO (\h -> f <$> mf (h . f)) (f i)
+--
+-- instance Applicative (RTreeIO j) where
+--   pure i = RTreeIO (\_ -> pure i) i
+--   (<*>) = ap
+--
+-- -- RTreeIO f fi <*> RTreeIO a ai = RTreeIO (f <*> a) (fi ai)
+--
+-- instance Monad (RTreeIO j) where
+--   RTreeIO (ma :: ((a -> IO Bool) -> IO a)) a >>= (f :: (a -> RTreeIO b)) =
+--     RTreeIO undefined (extractIO $ f a)
+--
+-- instance MonadFree (RTreeF Void) (RTreeIO j) where
+--   wrap (Split Nothing (RTreeIO lhs le) (RTreeIO rhs re)) =
+--     RTreeIO
+--       ( \p ->
+--           p le >>= \case
+--             True -> lhs p
+--             False -> rhs p
+--       )
+--       re
+--   wrap (Split (Just x) _ _) = absurd x
+
+-- reduceIO
+--   :: forall i
+--    . (i -> IO Bool)
+--   -> RTreeIO j i
+--   -> IO (Maybe i)
+-- reduceIO p (RTreeIO rt i) = runMaybeT do
+--   let (mi, i') = foldR go $ fmap (\i -> (pure i, i)) t
+--   p i' *> mi
+--  where
+--   go :: RTreeF l (IO i, i) -> (IO i, i)
+--   go (Split _ (lhs, le) (rhs, re)) =
+--     ((p le *> lhs) <|> rhs, re)
 
 -- | Split the world on a fact. False it does not happen, and True it does happen.
-given :: RTree Bool
+given :: RTree Void Bool
 given = pure False <| pure True
 
 {- | A reducer should extract itself
@@ -78,11 +210,11 @@ given = pure False <| pure True
  extract . red = id
 @
 -}
-lawReduceId :: (Eq i) => (i -> RTree i) -> i -> Bool
+lawReduceId :: (Eq i) => (i -> RTree l i) -> i -> Bool
 lawReduceId red i = extract (red i) == i
 
 -- | Reducing a list one element at a time.
-rList :: [a] -> RTree [a]
+rList :: [a] -> RTree l [a]
 rList = \case
   [] -> pure []
   a : as -> rList as <| (a :) <$> rList as
@@ -90,7 +222,7 @@ rList = \case
 {- | Binary reduction on the list assumming suffixes all contain eachother:
 @[] < [c] < [b, c] < [a,b,c]@
 -}
-rSuffixList :: [a] -> RTree [a]
+rSuffixList :: [a] -> RTree l [a]
 rSuffixList as = do
   res <- exponentialSearch (NE.tails as)
   case res of
@@ -100,7 +232,7 @@ rSuffixList as = do
 {- | Given a progression of inputs that are progressively larger, pick the smallest using
 binary search.
 -}
-binarySearch :: NE.NonEmpty i -> RTree i
+binarySearch :: NE.NonEmpty i -> RTree l i
 binarySearch = \case
   a NE.:| [] -> pure a
   d -> binarySearch l <| binarySearch f
@@ -110,7 +242,7 @@ binarySearch = \case
 {- | Given a progression of inputs that are progressively larger, pick the smallest using
 binary search.
 -}
-exponentialSearch :: NE.NonEmpty i -> RTree i
+exponentialSearch :: NE.NonEmpty i -> RTree l i
 exponentialSearch = go 1
  where
   go n = \case
@@ -126,15 +258,15 @@ nonEmptyOr msg ls = case NE.nonEmpty ls of
   Nothing -> error msg
 
 -- | Given a list of orderd options,  the
-linearSearch :: NE.NonEmpty i -> RTree i
+linearSearch :: NE.NonEmpty i -> RTree l i
 linearSearch = foldr1 (<|) . fmap pure
 
 -- | Given a list of orderd options,  the
-linearSearch' :: [i] -> RTree (Maybe i)
+linearSearch' :: [i] -> RTree l (Maybe i)
 linearSearch' is = linearSearch (NE.fromList $ fmap Just is ++ [Nothing])
 
 -- | Given
-ddmin :: [i] -> RTree [i]
+ddmin :: [i] -> RTree l [i]
 ddmin = \case
   [] -> pure []
   [a] -> pure [a]

test/data/.gitignore

+file2.c

test/data/simple1.c

+extern int printf (const char *, ...);
+
+int main (void)
+{
+    return 0;
+}