Many good changes

bin/rtree-c/Main.hs

+{-# LANGUAGE ApplicativeDo #-}
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ImportQualifiedPost #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 import Control.RTree
 
-import Data.Maybe (catMaybes, fromMaybe)
+import Colog
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans
+import Control.Monad.Trans.Maybe
+import Data.Foldable
+import Data.Functor
+import Data.Maybe
 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
+import Options.Applicative
+import System.Directory
+import System.Exit
+import System.FilePath
+
+import Data.Text qualified as Text
+
+-- import System.Process.Typed
+
+import Data.Map.Strict qualified as Map
+import GHC.Stack
+import Language.C (CInitializer (CInitExpr))
+import System.IO
+import System.Process.Typed
+import Text.Pretty.Simple
+import Text.PrettyPrint qualified as P
+import Prelude hiding (log)
 
 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
+main =
+  join
+    . execParser
+    $ info run
+    . fold
+    $ []
+
+process :: (WithLog env (Msg sev) m, MonadIO m) => sev -> Text.Text -> m a -> m a
+process sev p ma = do
+  msg "Started "
+  a <- ma
+  msg "Done "
+  pure a
  where
-  output l = do
-    writeFile "test.c" (P.render (C.pretty l))
+  s = withFrozenCallStack callStack
+  msg t = Colog.logMsg (Msg sev s (t <> p))
+
+run :: (HasCallStack) => Parser (IO ())
+run = do
+  file <- strArgument $ fold [metavar "FILE"]
+
+  validity <- flag False True $ fold [long "validity"]
+
+  pure
+    $ usingLoggerT (cmap fmtMessage logTextStdout)
+    $ do
+      let
+        test f = process D ("test " <> Text.pack f) do
+          err <- liftIO $ runProcess (proc "clang" ["-O0", "test.c"])
+          log D (Text.pack $ show err)
+          pure (err == ExitSuccess)
+
+        output f c = process D ("writing " <> Text.pack f) do
+          let x = P.render (C.pretty (c $> C.undefNode))
+          liftIO $ writeFile f x
+
+        check f _ c = MaybeT do
+          when validity do
+            liftIO $ copyFile file (file <.> "last")
+          output f c
+          t <- test f
+          if t
+            then pure (Just ())
+            else do
+              liftIO $ when validity do
+                copyFile file (file <.> "fail")
+                copyFile (file <.> "last") file
+                exitFailure
+              pure Nothing
 
-  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
+      let bak = file <.> "bak"
+
+      process D "backing up file" do
+        liftIO $ copyFile file bak
+
+      process I "check predicate" do
+        t <- test file
+        unless t do
+          liftIO exitFailure
+
+      c <- process D "parsing file" do
+        parseCFile file
+
+      output file c
+
+      process I "sanity checks" do
+        c' <- parseCFile file
+        unless (void c' == void c) do
+          liftIO do
+            withFile "error.1.hs" WriteMode (`pHPrint` void c)
+            withFile "error.2.hs" WriteMode (`pHPrint` void c')
+          logError "Outputted a different file than i read... Please report original file and error.{1,2}.hs"
+          liftIO exitFailure
+
+        t <- test file
+        unless t do
+          liftIO exitFailure
+
+      l <- runMaybeT (reduceFast (check file) (Map.singleton (C.internalIdent "main") True) (reduceC c))
+
+      case l of
+        Just l' -> do
+          output file l'
+          logInfo "Success"
+        Nothing -> do
+          logError "Unable to produce results"
+          liftIO exitFailure
+ where
+  parseCFile file = do
+    res <- liftIO $ C.parseCFilePre file
+    case res of
+      Right c -> pure c
+      Left err -> do
+        logError (Text.pack (show err))
+        liftIO exitFailure
 
 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
+reduceC :: (MonadReduce Lab m) => C.CTranslUnit -> m C.CTranslUnit
+reduceC (C.CTranslUnit es ni) = do
+  es' <- collect mrCExternalDeclaration es
+  pure $ C.CTranslUnit es' ni
 
-rCExternalDeclaration
-  :: C.CExternalDeclaration C.NodeInfo
-  -> RTree' Lab (Maybe (C.CExternalDeclaration C.NodeInfo))
-rCExternalDeclaration e = case e of
+mrCExternalDeclaration :: (MonadReduce Lab m) => C.CExternalDeclaration C.NodeInfo -> MaybeT m (C.CExternalDeclaration C.NodeInfo)
+mrCExternalDeclaration = \case
   C.CFDefExt fun ->
     split
       (funName fun)
-      (pure Nothing)
-      (Just . C.CFDefExt <$> rCFunctionDef fun)
-  _ -> pure Nothing <| pure (Just e)
+      empty
+      (C.CFDefExt <$> rCFunctionDef fun)
+  C.CDeclExt decl ->
+    C.CDeclExt <$> mrCDeclaration decl
+  a -> error (show a)
  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
+mrCDeclarationItem :: (MonadReduce Lab m) => C.CDeclarationItem C.NodeInfo -> MaybeT m (C.CDeclarationItem C.NodeInfo)
+mrCDeclarationItem = \case
+  C.CDeclarationItem d@(C.CDeclr x _ _ _ _) i e ->
+    split x empty do
+      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' -> 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' C.undefNode
+  pure $ C.CFunDef spc dec cdecls smt' ni
 
-rCStatement :: C.CStatement C.NodeInfo -> RTree' Lab (C.CStatement C.NodeInfo)
+rCStatement :: (MonadReduce Lab m) => C.CStatement C.NodeInfo -> m (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
+  C.CCompound is cbi ni -> do
+    cbi' <- collect mrCCompoundBlockItem cbi
+    pure $ C.CCompound is cbi' ni
+  C.CExpr e ni -> do
+    e' <- runMaybeT $ mlift 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' -> 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)
+      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 ->
+    splitOn i empty (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 -> ejoin 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 -> ejoin e1 e2 \e1' e2' ->
+    pure $ C.CAssign op e1' e2' ni
+  C.CIndex e1 e2 ni -> ejoin e1 e2 \e1' e2' ->
+    pure $ C.CIndex e1' e2' ni
+  C.CMember e i b ni -> do
+    splitOn i empty do
+      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
+  ejoin elhs erhs = mjoin (mrCExpression elhs) (mrCExpression erhs)
+
+mjoin :: (Monad m) => MaybeT m a -> MaybeT m a -> (a -> a -> MaybeT m a) -> MaybeT m a
+mjoin mlhs mrhs fn = MaybeT do
+  lhs <- runMaybeT mlhs
+  case lhs of
+    Nothing -> runMaybeT mrhs
+    Just l -> do
+      rhs <- runMaybeT mrhs
+      case rhs of
+        Nothing -> pure (Just l)
+        Just r -> runMaybeT (fn l r)
+
+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
+
+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)

flake.lock

@@ -21,11 +21,11 @@
     "language-c": {
       "flake": false,
       "locked": {
-        "lastModified": 1701177364,
-        "narHash": "sha256-SwRI8+PNfzfHOjFcn7bvgAylJeUMaFsvlJPm2r3QhTY=",
+        "lastModified": 1702044640,
+        "narHash": "sha256-jCpGlWLH6qnsskMnEOCAnYCKCwknpZv46cq2BmA4/cw=",
         "owner": "kalhauge",
         "repo": "language-c",
-        "rev": "bdbf9f641149f5879dc23eb9e153e573d9355cbd",
+        "rev": "cca7c0b315cb0594071a546587bea79292e0c3d7",
         "type": "github"
       },
       "original": {

flake.nix

@@ -42,7 +42,7 @@
         rtree = hpkgs.rtree;
       };
       devShells = let
-        buildInputs = with hpkgs; [
+        nativeBuildInputs = with hpkgs; [
           cabal-install
           ghcid
           haskell-language-server
@@ -56,7 +56,8 @@
           {
             name = "rtree-shell";
             packages = p: [p.rtree];
-            inherit buildInputs withHoogle;
+            doBenchmark = true;
+            inherit nativeBuildInputs withHoogle;
           };
       };
     });

package.yaml

@@ -13,7 +13,10 @@ dependencies:
   - free
   - data-fix
   - mtl
+  - directory
   - containers
+  - text
+  - pretty-simple
 
 library:
   source-dirs: src
@@ -24,9 +27,15 @@ executables:
     main: Main.hs
     dependencies:
       - rtree
+      - optparse-applicative
       - language-c
       - typed-process
+      - directory
       - pretty
+      - filepath
+      - co-log
+      - time
+      - text
 
 tests:
   rtree-test:

rtree.cabal

@@ -20,8 +20,11 @@ library
       base >=4.9 && <5
     , containers
     , data-fix
+    , directory
     , free
     , mtl
+    , pretty-simple
+    , text
     , transformers
   default-language: Haskell2010
 
@@ -34,13 +37,20 @@ executable rtree-c
   ghc-options: -Wall -fno-warn-incomplete-uni-patterns
   build-depends:
       base >=4.9 && <5
+    , co-log
     , containers
     , data-fix
+    , directory
+    , filepath
     , free
     , language-c
     , mtl
+    , optparse-applicative
     , pretty
+    , pretty-simple
     , rtree
+    , text
+    , time
     , transformers
     , typed-process
   default-language: Haskell2010
@@ -62,8 +72,11 @@ test-suite rtree-test
     , diagrams-core
     , diagrams-lib
     , diagrams-svg
+    , directory
     , free
     , mtl
+    , pretty-simple
     , rtree
+    , text
     , transformers
   default-language: Haskell2010

src/Control/RTree.hs

@@ -3,13 +3,12 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
 
 {- |
@@ -17,139 +16,212 @@ Module: Control.RTree
 -}
 module Control.RTree where
 
-import Control.Applicative (Alternative ((<|>)))
-import Data.Coerce (coerce)
-import Data.Functor.Classes
+import Control.Applicative
+import Control.Monad.Reader
+import Control.Monad.Trans.Maybe
 import qualified Data.List.NonEmpty as NE
+import qualified Data.Map.Strict as Map
+import Data.Maybe
 import Data.Void
+import GHC.IORef
 
-import qualified Data.List as L
-
-import Control.Monad.Reader
-import "free" Control.Monad.Free.Church
-
--- | The base functor for the reduction tree.
-data RTreeF l f
-  = Split (Maybe l) f f
-  deriving (Show, Eq, Functor)
-
-instance (Show l) => Show1 (RTreeF l) where
-  liftShowsPrec = undefined
-
-newtype RTree l i = RTree {rtreeFree :: F (RTreeF l) i}
-  deriving (Functor, Applicative, Monad) via (F (RTreeF l))
-
-instance MonadFree (RTreeF l) (RTree l) where
-  wrap x = RTree (wrap (fmap rtreeFree x))
+class (Monad m) => MonadReduce l m | m -> l where
+  split :: Maybe l -> m i -> m i -> m i
 
 infixr 3 <|
 infixl 3 |>
 
 {-# INLINE (<|) #-}
-(<|) :: (MonadFree (RTreeF l) r) => r i -> r i -> r i
-r1 <| r2 = wrap (Split Nothing r1 r2)
+(<|) :: (MonadReduce l r) => r i -> r i -> r i
+r1 <| r2 = split Nothing 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)
-
-{-# INLINE split #-}
-split :: (MonadFree (RTreeF l) r) => Maybe l -> r i -> r i -> r i
-split l r1 r2 = wrap (Split l r1 r2)
+splitOn :: (MonadReduce l r) => l -> r i -> r i -> r i
+splitOn l = split (Just l)
 
 {-# INLINE (|>) #-}
-(|>) :: (MonadFree (RTreeF l) r) => r i -> r i -> r i
+(|>) :: (MonadReduce 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 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))
+data RTree l i
+  = Split (RTree l i) !(RTree l i)
+  | SplitOn !l (RTree l i) !(RTree l i)
   | Done i
+  deriving (Functor)
 
-extract' :: RTree' l i -> i
-extract' = \case
-  RTree' (Split _ _ v) -> extract' v
+extract :: RTree l i -> i
+extract = \case
+  Split _ rhs -> extract rhs
+  SplitOn _ _ rhs -> extract rhs
   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
+instance Applicative (RTree l) where
   pure = Done
   (<*>) = ap
 
-instance Monad (RTree' l) where
+instance Monad (RTree l) where
   ma >>= f = case ma of
     Done i -> f i
-    RTree' r ->
-      RTree'
-        (fmap (>>= f) r)
+    Split lhs rhs ->
+      Split (lhs >>= f) (rhs >>= f)
+    SplitOn l lhs rhs ->
+      SplitOn l (lhs >>= f) (rhs >>= f)
 
-instance MonadFree (RTreeF l) (RTree' l) where
-  wrap = RTree'
-  {-# INLINE wrap #-}
+instance MonadReduce l (RTree l) where
+  split = \case
+    Just n -> SplitOn n
+    Nothing -> Split
 
--- | Reduce an input using a monad.
-reduce'
+reduce
   :: forall m l i
    . (Alternative m)
   => (i -> m ())
-  -> RTree' l i
+  -> RTree l i
   -> m i
-reduce' p = checkgo
+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
+    (Split lhs rhs) ->
+      (checkgo lhs Control.Applicative.<|> go rhs)
+    (SplitOn _ lhs rhs) ->
+      (checkgo lhs Control.Applicative.<|> go rhs)
+  checkgo rt = p (extract rt) *> go rt
+{-# SPECIALIZE reduce :: (i -> MaybeT IO ()) -> RTree l i -> MaybeT IO i #-}
+
+type Valuation l = Map.Map l Bool
+
+extractL :: (Ord l) => Valuation l -> RTree l i -> i
+extractL v = \case
+  Split _ rhs -> extractL v rhs
+  SplitOn l lhs rhs -> case Map.lookup l v of
+    Just False -> extractL v lhs
+    _ -> extractL v rhs
+  Done i -> i
+
+reduceL
+  :: forall m l i
+   . (Alternative m, Ord l)
+  => (Valuation l -> i -> m ())
+  -> Valuation l
+  -> RTree l i
+  -> m i
+reduceL p = checkgo
+ where
+  checkgo v r = p v (extractL v r) *> go v r
+  go v = \case
+    Done i -> pure i
+    SplitOn l lhs rhs -> case Map.lookup l v of
+      Just True -> checkgo v rhs
+      Just False -> checkgo v lhs
+      Nothing -> checkgo (Map.insert l False v) lhs <|> go (Map.insert l True v) rhs
+    Split lhs rhs -> (checkgo v lhs <|> go v rhs)
+{-# INLINE reduceL #-}
+
+data ReState l = ReState ![Bool] !(Valuation l)
+
+newtype ReReduce l i = ReReduce {runReReduce :: IORef (ReState l) -> IO i}
+  deriving (Functor, Applicative, Monad) via (ReaderT (IORef (ReState l)) IO)
+
+instance (Ord l) => MonadReduce l (ReReduce l) where
+  split ml r1 r2 = ReReduce \ref -> do
+    test <- case ml of
+      Nothing -> do
+        atomicModifyIORef'
+          ref
+          ( \case
+              ReState (a : as) v -> (ReState as v, a)
+              ReState [] v -> (ReState [] v, False)
+          )
+      Just l -> do
+        atomicModifyIORef'
+          ref
+          ( \case
+              ReState as v@(Map.lookup l -> Just x) -> (ReState as v, not x)
+              ReState (a : as) v -> (ReState as (Map.insert l (not a) v), a)
+              ReState [] v -> (ReState [] (Map.insert l True v), False)
+          )
+    if test
+      then runReReduce r1 ref
+      else runReReduce r2 ref
+
+reduceFast
+  :: forall m l i
+   . (MonadIO m, Ord l)
+  => (Valuation l -> i -> MaybeT m ())
+  -> Valuation l
+  -> ReReduce l i
+  -> MaybeT m i
+reduceFast p v (ReReduce ext) = MaybeT $ go []
+ where
+  go pth = do
+    ref <- liftIO $ newIORef (ReState pth v)
+    i <- liftIO $ ext ref
+    ReState r v' <- liftIO $ readIORef ref
+    case r of
+      [] -> do
+        t <- isJust <$> runMaybeT (p v' i)
+        if t
+          then go (pth <> [True])
+          else go (pth <> [False])
+      _
+        | null pth ->
+            pure Nothing
+        | otherwise ->
+            pure (Just i)
+{-# INLINE reduceFast #-}
+
+-- Combinators
+
+type MRTree l = MaybeT (RTree l)
+
+instance (MonadReduce l m) => MonadReduce l (MaybeT m) where
+  split m (MaybeT lhs) (MaybeT rhs) = MaybeT (split m lhs rhs)
+
+-- | Given a list of item try to remove each of them the list.
+collect :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> m [b]
+collect fn = fmap catMaybes . traverse (runMaybeT . fn)
+{-# INLINE collect #-}
+
+collectNonEmpty' :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> MaybeT m [b]
+collectNonEmpty' fn as =
+  NE.toList <$> collectNonEmpty fn as
+{-# INLINE collectNonEmpty' #-}
+
+collectNonEmpty :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> MaybeT m (NE.NonEmpty b)
+collectNonEmpty fn as = do
+  as' <- lift . fmap catMaybes . traverse (runMaybeT . fn) $ as
+  MaybeT . pure $ NE.nonEmpty as'
+{-# INLINE collectNonEmpty #-}
+
+-- newtype LTree l i = LTree {runLTree :: Valuation l -> Maybe (RTree l i)}
+--   deriving (Functor)
+--
+-- instance Applicative (LTree l) where
+--   pure i = LTree{runLTree = \_ -> Just $ Done i}
+--   (<*>) = ap
+--
+-- instance Monad (LTree l) where
+--   LTree ma >>= f = LTree \l ->
+--     case ma l of
+--       Done i -> f i
+--       Split l lhs rhs ->
+
+-- 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 MonadFree (RTreeF l) (RTree' l) where
+--   wrap = RTree'
+--   {-# INLINE wrap #-}
+
+-- | Reduce an input using a monad.
 
 -- newtype I l i = I ([(l, Bool)] -> RTreeI l i)
 --

test/data/simple1.c

@@ -2,5 +2,6 @@ extern int printf (const char *, ...);
 
 int main (void)
 {
+  printf("hello");
   return 0;
 }