Improve the code

bin/rtree-c/Main.hs

@@ -114,7 +114,7 @@ run = do
         unless t do
           liftIO exitFailure
 
-      l <- runMaybeT (reduceFast (check file) (Map.singleton (C.internalIdent "main") True) (reduceC c))
+      l <- runMaybeT (reduceIO (check file) (Map.singleton (C.internalIdent "main") True) (reduceC c))
 
       case l of
         Just l' -> do

src/Control/RTree.hs

@@ -82,10 +82,8 @@ reduce p = checkgo
  where
   go = \case
     (Done i) -> pure i
-    (Split lhs rhs) ->
-      (checkgo lhs Control.Applicative.<|> go rhs)
-    (SplitOn _ lhs rhs) ->
-      (checkgo lhs Control.Applicative.<|> go rhs)
+    (Split lhs rhs) -> (checkgo lhs <|> go rhs)
+    (SplitOn _ lhs rhs) -> (checkgo lhs <|> go rhs)
   checkgo rt = p (extract rt) *> go rt
 {-# SPECIALIZE reduce :: (i -> MaybeT IO ()) -> RTree l i -> MaybeT IO i #-}
 
@@ -120,11 +118,14 @@ reduceL p = checkgo
 
 data ReState l = ReState ![Bool] !(Valuation l)
 
-newtype ReReduce l i = ReReduce {runReReduce :: IORef (ReState l) -> IO i}
+{- | A faster version of the RTree which simply reruns the reducer program instead
+of building a tree.
+-}
+newtype IORTree l i = IORTree {runIORTree :: 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
+instance (Ord l) => MonadReduce l (IORTree l) where
+  split ml r1 r2 = IORTree \ref -> do
     test <- case ml of
       Nothing -> do
         atomicModifyIORef'
@@ -142,17 +143,17 @@ instance (Ord l) => MonadReduce l (ReReduce l) where
               ReState [] v -> (ReState [] (Map.insert l True v), False)
           )
     if test
-      then runReReduce r1 ref
-      else runReReduce r2 ref
+      then runIORTree r1 ref
+      else runIORTree r2 ref
 
-reduceFast
+reduceIO
   :: forall m l i
    . (MonadIO m, Ord l)
   => (Valuation l -> i -> MaybeT m ())
   -> Valuation l
-  -> ReReduce l i
+  -> IORTree l i
   -> MaybeT m i
-reduceFast p v (ReReduce ext) = MaybeT $ go []
+reduceIO p v (IORTree ext) = MaybeT $ go []
  where
   go pth = do
     ref <- liftIO $ newIORef (ReState pth v)
@@ -169,7 +170,7 @@ reduceFast p v (ReReduce ext) = MaybeT $ go []
             pure Nothing
         | otherwise ->
             pure (Just i)
-{-# INLINE reduceFast #-}
+{-# INLINE reduceIO #-}
 
 -- Combinators
 
@@ -194,85 +195,6 @@ collectNonEmpty fn as = do
   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)
---
--- 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 Void Bool
 given = pure False <| pure True