Add labels

rtree/.hspec

 --failure-report .hspec-failures
 --rerun
 --rerun-all-on-success
---fail-fast

rtree/rtree.cabal

@@ -13,7 +13,6 @@ library
       Control.Monad.IRTree
       Control.Monad.Reduce
       Control.Monad.RTree
-      Control.RTree
       Data.RPath
       Data.Valuation
   other-modules:

rtree/src/Control/Monad/IRTree.hs

 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -7,11 +9,13 @@ module Control.Monad.IRTree (
   -- * IRTree
   IRTree,
   extract,
+  -- probe,
   reduce,
   reduceExp,
 
   -- * IRTreeT
   IRTreeT,
+  -- probeT,
   extractT,
   reduceT,
   reduceExpT,
@@ -21,52 +25,63 @@ module Control.Monad.IRTree (
   module Data.RPath,
 ) where
 
+import Control.Monad.RWS.Strict
 import Control.Monad.Reader
 import Control.Monad.Reduce
-import Control.Monad.State
 import Data.Bits
 import Data.Foldable
+import Data.Functor
 import Data.Functor.Identity
 import Data.RPath
 import qualified Data.Sequence as Seq
 
-type IRTree = IRTreeT Identity
+type IRTree l = IRTreeT l Identity
 
-newtype IRTreeT m i = IRTreeT (RPath -> Int -> m (i, Int))
+newtype IRTreeT l m i = IRTreeT (RWST RPath (Endo [l]) Int m i)
   deriving
     (Functor, Applicative, Monad)
-    via (ReaderT RPath (StateT Int m))
+    via (RWST RPath (Endo [l]) Int m)
 
-instance (Monad m) => MonadReduce (IRTreeT m) where
-  check = IRTreeT \rp i -> do
-    pure (indexChoice rp i, i + 1)
+instance (Monad m) => MonadReduce l (IRTreeT l m) where
+  check l = IRTreeT . RWST $ \rp i -> do
+    pure (indexChoice rp i, i + 1, Endo (l :))
 
-extract :: IRTree i -> i
+extract :: IRTree l i -> i
 extract t = runIdentity $ extractT t
 {-# INLINE extract #-}
 
-extractT :: (Functor m) => IRTreeT m i -> m i
-extractT (IRTreeT m) = fmap fst (m "" 0)
+extractT :: (Functor m) => IRTreeT l m i -> m i
+extractT (IRTreeT m) = fmap (\(i, _, _) -> i) (runRWST m "" 0)
 {-# INLINE extractT #-}
 
+-- probe :: IRTree l i -> RPath -> (i, [(Bool, l)])
+-- probe t pth = runIdentity $ probeT t pth
+-- {-# INLINE probe #-}
+
+probeT :: (Functor m) => IRTreeT l m i -> RPath -> m (i, [(Bool, l)])
+probeT (IRTreeT m) pth =
+  runRWST m pth 0 <&> \(i, _, l) ->
+    (i, zip (toChoiceList pth) (appEndo l []))
+{-# INLINE probeT #-}
+
 reduce
   :: (Monad m)
-  => (i -> m Bool)
-  -> IRTree i
+  => ([(Bool, l)] -> i -> m Bool)
+  -> IRTree l i
   -> m (Maybe i)
 reduce = reduceT (pure . runIdentity)
 {-# INLINE reduce #-}
 
 -- | Interpreted reduction with an m base monad
 reduceT
-  :: (Monad m)
+  :: (Monad m, Functor t)
   => (forall a. t a -> m a)
-  -> (i -> m Bool)
-  -> IRTreeT t i
+  -> ([(Bool, l)] -> i -> m Bool)
+  -> IRTreeT l t i
   -> m (Maybe i)
-reduceT lift_ p (IRTreeT m) = do
-  (i, _) <- lift_ (m "" 0)
-  t <- p i
+reduceT lift_ p rt = do
+  (i, l) <- lift_ (probeT rt "")
+  t <- p l i
   if t
     then Just <$> go Seq.empty
     else pure Nothing
@@ -74,32 +89,33 @@ reduceT lift_ p (IRTreeT m) = do
   go pth = do
     -- Try to run the true branch.
     let pth' = fromChoiceList (toList (pth Seq.|> True))
-    (i, x) <- lift_ (m pth' 0)
-    t <- p i
-    if x >= numberOfChoices pth'
-      then go (pth Seq.|> t)
+    (i, l) <- lift_ $ probeT rt pth'
+    if length l >= numberOfChoices pth'
+      then do
+        t <- p l i
+        go (pth Seq.|> t)
       else pure i
 {-# INLINE reduceT #-}
 
 reduceExp
   :: (Monad m)
-  => (i -> m Bool)
-  -> IRTree i
+  => ([(Bool, l)] -> i -> m Bool)
+  -> IRTree l i
   -> m (Maybe i)
 reduceExp = reduceExpT (pure . runIdentity)
 {-# INLINE reduceExp #-}
 
 -- | Interpreted reduction with an m base monad, and running in expoential mode.
 reduceExpT
-  :: (Monad m)
+  :: (Monad m, Functor t)
   => (forall a. t a -> m a)
   -- ^ a lift of monad m into t (normally @id@ or @lift@)
-  -> (i -> m Bool)
-  -> IRTreeT t i
+  -> ([(Bool, l)] -> i -> m Bool)
+  -> IRTreeT l t i
   -> m (Maybe i)
-reduceExpT lift_ p (IRTreeT m) = do
-  (i, _) <- lift_ (m "" 0)
-  t <- p i
+reduceExpT lift_ p rt = do
+  (i, l) <- lift_ (probeT rt "")
+  t <- p l i
   if t
     then Just <$> go 0 Seq.empty
     else pure Nothing
@@ -108,10 +124,10 @@ reduceExpT lift_ p (IRTreeT m) = do
     let depth = shiftL 1 n
     let sq' = sq <> Seq.replicate depth True
     let pth' = fromChoiceList (toList sq')
-    (i, x) <- lift_ (m pth' 0)
-    t <- p i
-    if x >= numberOfChoices pth' - depth + 1
-      then
+    (i, l) <- lift_ (probeT rt pth')
+    if length l >= numberOfChoices pth' - depth + 1
+      then do
+        t <- p l i
         if t
           then go (n + 1) sq'
           else case n of

rtree/src/Control/Monad/RTree.hs

@@ -45,53 +45,61 @@ import Data.RPath
 import qualified Data.Sequence as Seq
 
 -- | The simple RTree
-data RTree i
+data RTree l i
   = Done !i
-  | Split ~(RTree i) !(RTree i)
+  | Split !l ~(RTree l i) !(RTree l i)
   deriving (Functor, Foldable)
 
-instance Applicative RTree where
+instance Applicative (RTree l) where
   pure = Done
   (<*>) = ap
 
-instance Monad RTree where
+instance Monad (RTree l) where
   ma >>= f = case ma of
     Done i -> f i
-    Split lhs rhs -> Split (lhs >>= f) (rhs >>= f)
+    Split ctx lhs rhs -> Split ctx (lhs >>= f) (rhs >>= f)
 
-instance MonadReduce RTree where
+instance MonadReduce l (RTree l) where
   split = Split
 
-instance FoldableWithIndex RPath RTree where
+instance FoldableWithIndex RPath (RTree l) where
   ifoldMap f =
     Seq.empty & fix \rec rs -> \case
       Done i -> f (fromChoiceList (toList rs)) i
-      Split lhs rhs -> rec (rs Seq.|> True) lhs <> rec (rs Seq.|> False) rhs
+      Split _ lhs rhs -> rec (rs Seq.|> True) lhs <> rec (rs Seq.|> False) rhs
 
 -- | Extract the top value from the RTree.
-extract :: RTree i -> i
+extract :: RTree l i -> i
 extract = \case
-  Split _ rhs -> extract rhs
+  Split _ _ rhs -> extract rhs
   Done i -> i
 {-# INLINE extract #-}
 
 -- | A list of inputs, A simple wrapper around @toList@
-inputs :: RTree i -> [i]
+inputs :: RTree l i -> [i]
 inputs = toList
 
 -- | A list of indexed inputs, A simple wrapper around @itoList@
-iinputs :: RTree i -> [(RPath, i)]
+iinputs :: RTree l i -> [(RPath, i)]
 iinputs = itoList
 
 -- | For debugging purposes
-drawRTree :: (i -> String) -> RTree i -> String
-drawRTree pp = concat . go
+drawRTree :: (l -> ShowS) -> (i -> ShowS) -> RTree l i -> String
+drawRTree ppl ppi = concat . go id
  where
-  go = \case
-    Done i -> map (\a -> " " <> a <> "\n") (lines $ pp i)
-    Split lhs rhs ->
-      let (rh : rhs') = go rhs
-          (lh : lhs') = go lhs
+  go x = \case
+    Done i ->
+      map
+        (\a -> " " <> a <> "\n")
+        ( lines
+            . ppi i
+            . showString "\n"
+            . x
+            $ ""
+        )
+    Split ctx2 lhs rhs ->
+      let (rh : rhs') = go x rhs
+          (lh : lhs') = go (ppl ctx2) lhs
        in fold
             [ ["┳━" <> rh]
             , map ("┃ " <>) rhs'
@@ -103,7 +111,7 @@ drawRTree pp = concat . go
 reduce
   :: (Monad m)
   => (i -> m Bool)
-  -> RTree i
+  -> RTree l i
   -> m (Maybe i)
 reduce p = runMaybeT . checkgo
  where
@@ -112,55 +120,54 @@ reduce p = runMaybeT . checkgo
     guard t *> go r
   go = \case
     Done i -> pure i
-    Split lhs rhs -> checkgo lhs <|> go rhs
+    Split _ lhs rhs -> checkgo lhs <|> go rhs
 {-# INLINE reduce #-}
 
 -- | An RTreeT Node
-data RTreeN m i
+data RTreeN l m i
   = DoneN !i
-  | SplitN !(RTreeT m i) !(RTreeT m i)
+  | SplitN !l !(RTreeT l m i) !(RTreeT l m i)
   deriving (Functor, Foldable)
 
-newtype RTreeT m i = RTreeT {unRTreeT :: m (RTreeN m i)}
+newtype RTreeT l m i = RTreeT {unRTreeT :: m (RTreeN l m i)}
   deriving (Functor, Foldable)
 
-instance (Monad m) => Applicative (RTreeT m) where
+instance (Monad m) => Applicative (RTreeT l m) where
   pure = RTreeT . pure . DoneN
   (<*>) = ap
 
-instance (Monad m) => Monad (RTreeT m) where
+instance (Monad m) => Monad (RTreeT l m) where
   RTreeT ma >>= f = RTreeT $ do
     ma >>= \case
       DoneN i -> unRTreeT (f i)
-      SplitN lhs rhs -> pure $ SplitN (lhs >>= f) (rhs >>= f)
+      SplitN ctx lhs rhs -> pure $ SplitN ctx (lhs >>= f) (rhs >>= f)
 
-instance (Monad m) => MonadReduce (RTreeT m) where
-  split lhs rhs = RTreeT (pure $ SplitN lhs rhs)
+instance (Monad m) => MonadReduce l (RTreeT l m) where
+  split l lhs rhs = RTreeT (pure $ SplitN l lhs rhs)
 
 -- | Extract a value from an @RTreeT@
-extractT :: (Monad m) => RTreeT m b -> m b
+extractT :: (Monad m) => RTreeT l m b -> m b
 extractT (RTreeT m) = m >>= extractN
 {-# INLINE extractT #-}
 
-extractN :: (Monad m) => RTreeN m b -> m b
+extractN :: (Monad m) => RTreeN l m b -> m b
 extractN = \case
   DoneN i -> pure i
-  SplitN _ rhs -> extractT rhs
+  SplitN _ _ rhs -> extractT rhs
 {-# INLINE extractN #-}
 
-flattenT :: RTreeT Identity i -> RTree i
+flattenT :: RTreeT l Identity i -> RTree l i
 flattenT (RTreeT (Identity t)) = case t of
   DoneN i -> Done i
-  SplitN lhs rhs -> Split (flattenT lhs) (flattenT rhs)
+  SplitN ctx lhs rhs -> Split ctx (flattenT lhs) (flattenT rhs)
 
 -- | Reduction in @RTreeT@
 reduceT
-  :: forall i m n
-   . (Monad m, MonadPlus n)
+  :: (Monad m, MonadPlus n)
   => (forall a. m a -> n a)
   -- ^ A function to lift m into n
   -> (i -> n Bool)
-  -> RTreeT m i
+  -> RTreeT l m i
   -> n i
 reduceT lift_ p = checkgo
  where
@@ -171,5 +178,5 @@ reduceT lift_ p = checkgo
     go r'
   go = \case
     DoneN i -> pure i
-    SplitN lhs rhs -> checkgo lhs <|> (lift_ (unRTreeT rhs) >>= go)
+    SplitN _ lhs rhs -> checkgo lhs <|> (lift_ (unRTreeT rhs) >>= go)
 {-# INLINE reduceT #-}

rtree/src/Control/Monad/Reduce.hs

@@ -3,10 +3,13 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 {- |
@@ -40,6 +43,8 @@ import Control.Monad.State
 import Control.Monad.Trans.Maybe
 import qualified Data.List.NonEmpty as NE
 import Data.Maybe
+import GHC.Exception (CallStack, prettyCallStack)
+import GHC.Stack (callStack, withFrozenCallStack)
 
 -- {- | A reducer should extract itself
 -- @
@@ -50,58 +55,70 @@ import Data.Maybe
 -- lawReduceId red i = extract (red i) == i
 
 -- | The Monad Reduce class.
-class (Monad m) => MonadReduce m where
+class (Monad m) => MonadReduce l m | m -> l where
   {-# MINIMAL (split | check) #-}
 
-  split :: m i -> m i -> m i
-  split r1 r2 =
-    check >>= \case
+  split :: l -> m i -> m i -> m i
+  split l r1 r2 =
+    check l >>= \case
       True -> r1
       False -> r2
   {-# INLINE split #-}
 
   -- | Check if the predicate is true.
-  check :: m Bool
-  check = split (pure True) (pure False)
+  check :: l -> m Bool
+  check l = split l (pure True) (pure False)
   {-# INLINE check #-}
 
 -- | Infix split.
-(<|) :: (MonadReduce m) => m i -> m i -> m i
-(<|) = split
+(<|) :: (MonadReduce l m, IsCallStack l) => m i -> m i -> m i
+(<|) = split (fromCallStack callStack)
 {-# INLINE (<|) #-}
 
 infixr 3 <|
 
 -- | Infix split, to the right.
-(|>) :: (MonadReduce m) => m i -> m i -> m i
-r1 |> r2 = r2 <| r1
+(|>) :: (MonadReduce l m, IsCallStack l) => m i -> m i -> m i
+r1 |> r2 = withFrozenCallStack (r2 <| r1)
 {-# INLINE (|>) #-}
 
 infixl 3 |>
 
-type MonadReducePlus m = (MonadReduce m, MonadPlus m)
+class IsCallStack l where
+  fromCallStack :: CallStack -> l
 
-instance (MonadReduce m) => MonadReduce (MaybeT m) where
-  split (MaybeT lhs) (MaybeT rhs) = MaybeT (split lhs rhs)
+instance IsCallStack () where
+  fromCallStack = const ()
+
+instance IsCallStack CallStack where
+  fromCallStack = id
+
+instance IsCallStack String where
+  fromCallStack = prettyCallStack
+
+type MonadReducePlus l m = (MonadReduce l m, MonadPlus m)
+
+instance (MonadReduce l m) => MonadReduce l (MaybeT m) where
+  split l (MaybeT lhs) (MaybeT rhs) = MaybeT (split l lhs rhs)
 
 -- | Continues if the fact is true.
-given :: (MonadReducePlus m) => m ()
-given = split mzero (pure ())
+given :: (MonadReducePlus l m) => l -> m ()
+given l = split l mzero (pure ())
 {-# INLINE given #-}
 
 -- | Given a list of item try to remove each of them from the list.
-collect :: (MonadReduce m) => (a -> MaybeT m b) -> [a] -> m [b]
+collect :: (MonadReduce l m) => (a -> MaybeT m b) -> [a] -> m [b]
 collect fn = fmap catMaybes . traverse (runMaybeT . fn)
 {-# INLINE collect #-}
 
 -- | Given a list of item try to remove each of them, but keep atleast one.
-collectNonEmpty' :: (MonadReducePlus m) => (a -> m b) -> [a] -> m [b]
+collectNonEmpty' :: (MonadReducePlus l m) => (a -> m b) -> [a] -> m [b]
 collectNonEmpty' fn as =
   NE.toList <$> collectNonEmpty fn as
 {-# INLINE collectNonEmpty' #-}
 
 -- | Given a list of item try to remove each of them, but keep atleast one.
-collectNonEmpty :: (MonadReducePlus m) => (a -> m b) -> [a] -> m (NE.NonEmpty b)
+collectNonEmpty :: (MonadReducePlus l m) => (a -> m b) -> [a] -> m (NE.NonEmpty b)
 collectNonEmpty fn as = do
   as' <- fmap catMaybes . traverse (optional . fn) $ as
   maybe mzero pure $ NE.nonEmpty as'
@@ -124,10 +141,10 @@ onBoth mlhs mrhs fn =
         Nothing -> pure lhs
         Just rhs -> fn lhs rhs
 
-instance (MonadReduce m) => MonadReduce (StateT s m) where
-  check = StateT (\s -> split (pure (True, s)) (pure (False, s)))
+instance (MonadReduce l m) => MonadReduce l (StateT s m) where
+  check l = StateT (\s -> (,s) <$> check l)
   {-# INLINE check #-}
 
-instance (MonadReduce m) => MonadReduce (ReaderT r m) where
-  check = ReaderT (\_ -> split (pure True) (pure False))
+instance (MonadReduce l m) => MonadReduce l (ReaderT r m) where
+  check l = ReaderT (\_ -> check l)
   {-# INLINE check #-}

rtree/src/Data/RPath.hs

@@ -26,6 +26,9 @@ Is isomorphic to a list of choices.
 newtype RPath = RPath {rPathAsVector :: VU.Vector Bool}
   deriving (Eq, Ord)
 
+{- | Convert an RPath into a predicate, which will find the element which
+the rpath points to.
+-}
 toPredicate :: RPath -> IO (i -> IO Bool)
 toPredicate rp = do
   idx <- newIORef (-1)
@@ -33,6 +36,7 @@ toPredicate rp = do
     idx' <- atomicModifyIORef idx (\n -> (n + 1, n))
     pure $ indexChoice rp idx'
 
+-- | Like @toPredicate@, but with debugging information
 toPredicateDebug :: (Show i) => RPath -> IO (i -> IO Bool)
 toPredicateDebug rp = do
   idx <- newIORef (-1)
@@ -51,6 +55,7 @@ indexChoice (RPath v) idx
   | idx < 0 = True
   | otherwise = fromMaybe False (v VU.!? idx)
 
+-- | Get the number of choices in the RPath.
 numberOfChoices :: RPath -> Int
 numberOfChoices (RPath v) = VU.length v
 

rtree/test/expected/double-let-expr

-┳━┳━┳━┳━┳━┳━ x := 1; y := 2; x + y
-┃ ┃ ┃ ┃ ┃ ┗━ x := 1; y := 2; x
-┃ ┃ ┃ ┃ ┗━┳━ x := 1; y := 2; y
-┃ ┃ ┃ ┃   ┗━ ⊥
-┃ ┃ ┃ ┗━┳━┳━ x := 1; x + 2
-┃ ┃ ┃   ┃ ┗━ x := 1; x
-┃ ┃ ┃   ┗━┳━ x := 1; 2
-┃ ┃ ┃     ┗━ ⊥
-┃ ┃ ┗━ ⊥
-┃ ┗━┳━┳━┳━┳━ y := 2; 1 + y
-┃   ┃ ┃ ┃ ┗━ y := 2; 1
-┃   ┃ ┃ ┗━┳━ y := 2; y
-┃   ┃ ┃   ┗━ ⊥
-┃   ┃ ┗━┳━┳━┳━ 1 + 2
-┃   ┃   ┃ ┃ ┗━ 3
-┃   ┃   ┃ ┗━ 1
-┃   ┃   ┗━┳━ 2
-┃   ┃     ┗━ ⊥
-┃   ┗━ ⊥
-┗━ ⊥
+┳━┳━┳━┳━ x := 1; y := 2; x + y
+┃ ┃ ┃ ┗━ x := 1; y := 2; y
+┃ ┃ ┃    choose right
+┃ ┃ ┗━ x := 1; y := 2; x
+┃ ┃    choose left
+┃ ┗━┳━┳━ x := 1; x + 2
+┃   ┃ ┃  inline "y"
+┃   ┃ ┗━ x := 1; 2
+┃   ┃    choose right
+┃   ┗━ x := 1; x
+┃      choose left
+┗━┳━┳━┳━ y := 2; 1 + y
+  ┃ ┃ ┃  inline "x"
+  ┃ ┃ ┗━ y := 2; y
+  ┃ ┃    choose right
+  ┃ ┗━ y := 2; 1
+  ┃    choose left
+  ┗━┳━┳━┳━ 1 + 2
+    ┃ ┃ ┃  inline "y"
+    ┃ ┃ ┗━ 3
+    ┃ ┃    compute 1 + 2
+    ┃ ┗━ 2
+    ┃    choose right
+    ┗━ 1
+       choose left

rtree/test/expected/double-let-expr-red

 1: x := 1; y := 2; x + y
-0: -
+initial
 1: y := 2; 1 + y
-0: -
+inline "x"
 1: 1 + 2
-0: 2
+inline "y"
 0: 1
+choose left
+0: 2
+choose right
 0: 3
-1: 1 + 2
+compute 1 + 2

rtree/test/expected/double-let-expr-red-exp

 1: x := 1; y := 2; x + y
-0: -
+initial
 1: y := 2; 1 + y
-0: -
-0: -
+inline "x"
+0: 1
+choose left
 1: 1 + 2
-0: -
-0: 2
+inline "y"
+0: 1
+choose left
 0: 1
+choose left
+0: 2
+choose right
 0: 3
-1: 1 + 2
+compute 1 + 2

rtree/test/expected/double-overloading-let-expr

-┳━┳━┳━┳━┳━┳━ x := 1; x := 2; x + x
-┃ ┃ ┃ ┃ ┃ ┗━ x := 1; x := 2; x
-┃ ┃ ┃ ┃ ┗━┳━ x := 1; x := 2; x
-┃ ┃ ┃ ┃   ┗━ ⊥
-┃ ┃ ┃ ┗━┳━┳━┳━ x := 1; 2 + 2
-┃ ┃ ┃   ┃ ┃ ┗━ x := 1; 4
-┃ ┃ ┃   ┃ ┗━ x := 1; 2
-┃ ┃ ┃   ┗━┳━ x := 1; 2
-┃ ┃ ┃     ┗━ ⊥
-┃ ┃ ┗━ ⊥
-┃ ┗━┳━┳━┳━┳━ x := 2; x + x
-┃   ┃ ┃ ┃ ┗━ x := 2; x
-┃   ┃ ┃ ┗━┳━ x := 2; x
-┃   ┃ ┃   ┗━ ⊥
-┃   ┃ ┗━┳━┳━┳━ 2 + 2
-┃   ┃   ┃ ┃ ┗━ 4
-┃   ┃   ┃ ┗━ 2
-┃   ┃   ┗━┳━ 2
-┃   ┃     ┗━ ⊥
-┃   ┗━ ⊥
-┗━ ⊥
+┳━┳━┳━┳━ x := 1; x := 2; x + x
+┃ ┃ ┃ ┗━ x := 1; x := 2; x
+┃ ┃ ┃    choose right
+┃ ┃ ┗━ x := 1; x := 2; x
+┃ ┃    choose left
+┃ ┗━┳━┳━┳━ x := 1; 2 + 2
+┃   ┃ ┃ ┃  inline "x"
+┃   ┃ ┃ ┗━ x := 1; 4
+┃   ┃ ┃    compute 2 + 2
+┃   ┃ ┗━ x := 1; 2
+┃   ┃    choose right
+┃   ┗━ x := 1; 2
+┃      choose left
+┗━┳━┳━┳━ x := 2; x + x
+  ┃ ┃ ┃  inline "x"
+  ┃ ┃ ┗━ x := 2; x
+  ┃ ┃    choose right
+  ┃ ┗━ x := 2; x
+  ┃    choose left
+  ┗━┳━┳━┳━ 2 + 2
+    ┃ ┃ ┃  inline "x"
+    ┃ ┃ ┗━ 4
+    ┃ ┃    compute 2 + 2
+    ┃ ┗━ 2
+    ┃    choose right
+    ┗━ 2
+       choose left

rtree/test/expected/double-overloading-let-expr-red

 1: x := 1; x := 2; x + x
-0: -
+initial
 1: x := 2; x + x
-0: -
+inline "x"
 1: 2 + 2
+inline "x"
 0: 2
+choose left
 0: 2
+choose right
 0: 4
-1: 2 + 2
+compute 2 + 2

rtree/test/expected/double-overloading-let-expr-red-exp

 1: x := 1; x := 2; x + x
-0: -
+initial
 1: x := 2; x + x
-0: -
-0: -
+inline "x"
+0: 2
+choose left
 1: 2 + 2
-0: -
+inline "x"
+0: 2
+choose left
 0: 2
+choose left
 0: 2
+choose right
 0: 4
-1: 2 + 2
+compute 2 + 2

rtree/test/expected/small-let-expr

-┳━┳━┳━┳━ x := 1; 2 + x
-┃ ┃ ┃ ┗━ x := 1; 2
-┃ ┃ ┗━┳━ x := 1; x
-┃ ┃   ┗━ ⊥
-┃ ┗━┳━┳━┳━ 2 + 1
-┃   ┃ ┃ ┗━ 3
-┃   ┃ ┗━ 2
-┃   ┗━┳━ 1
-┃     ┗━ ⊥
-┗━ ⊥
+┳━┳━┳━ x := 1; 2 + x
+┃ ┃ ┗━ x := 1; x
+┃ ┃    choose right
+┃ ┗━ x := 1; 2
+┃    choose left
+┗━┳━┳━┳━ 2 + 1
+  ┃ ┃ ┃  inline "x"
+  ┃ ┃ ┗━ 3
+  ┃ ┃    compute 2 + 1
+  ┃ ┗━ 1
+  ┃    choose right
+  ┗━ 2
+     choose left

rtree/test/expected/small-let-expr-red

 1: x := 1; 2 + x
-0: -
+initial
 1: 2 + 1
-0: 1
+inline "x"
 0: 2
+choose left
+0: 1
+choose right
 0: 3
-1: 2 + 1
+compute 2 + 1

rtree/test/expected/small-let-expr-red-exp

 1: x := 1; 2 + x
-0: -
+initial
 1: 2 + 1
-0: -
-0: 1
+inline "x"
+0: 2
+choose left
 0: 2
+choose left
+0: 1
+choose right
 0: 3
-1: 2 + 1
+compute 2 + 1

rtree/test/expected/small-opr-expr

 ┳━┳━┳━ 1 + 2
 ┃ ┃ ┗━ 3
-┃ ┗━ 1
-┗━┳━ 2
-  ┗━ ⊥
+┃ ┃    compute 1 + 2
+┃ ┗━ 2
+┃    choose right
+┗━ 1
+   choose left

rtree/test/expected/small-opr-expr-red

 1: 1 + 2
-0: 2
+initial
 0: 1
+choose left
+0: 2
+choose right
 0: 3
-1: 1 + 2
+compute 1 + 2

rtree/test/expected/small-opr-expr-red-exp

 1: 1 + 2
-0: 2
+initial
 0: 1
+choose left
+0: 2
+choose right
 0: 3
-1: 1 + 2
+compute 1 + 2

rtree/test/src/Control/Monad/IRTreeSpec.hs

@@ -5,11 +5,11 @@ module Control.Monad.IRTreeSpec where
 import Control.Monad.IRTree
 import qualified Control.Monad.IRTree as IRTree
 import qualified Control.Monad.RTree as RTree
-import Control.Monad.State
-import Control.Monad.Trans.Maybe
+import Control.Monad.Writer.Strict
 import Data.Bool
 import Data.Expr as Expr
-import Data.IORef (modifyIORef', newIORef, readIORef)
+import Data.List.NonEmpty (nonEmpty)
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import Test.Hspec
 import Test.Hspec.GitGolden
@@ -29,46 +29,51 @@ spec = describe "examples" do
     Let "x" (Cnt 1) (Let "x" (Cnt 2) (Opr (Var "x") (Var "x")))
  where
   handle str e = describe (str <> " (" <> prettyExprS 0 e ")") do
-    let me = evalStateT (runMaybeT $ Expr.rExpr e) Map.empty
+    let me = runReaderT (Expr.rExpr e) Map.empty
 
     it "should extract" do
-      IRTree.extract me `shouldBe` Just e
+      IRTree.extract me `shouldBe` e
 
-    let re = evalStateT (runMaybeT $ Expr.rExpr e) Map.empty
+    let re = runReaderT (Expr.rExpr e) Map.empty
 
-    let predicate = maybe False (contains isOpr)
+    let
+      predicate :: Expr -> IO Bool
+      predicate = pure . contains isOpr
 
-    rex <- RTree.reduce (pure . predicate) re
+    rex <- runIO $ RTree.reduce predicate re
 
     it "should find an opr" do
-      ref <- newIORef ""
-
-      let test i = do
-            let x = predicate i
-            modifyIORef' ref (\t -> t <> bool "0" "1" x <> ": " <> maybe "-" (flip (prettyExprS 0) "") i <> "\n")
-            pure x
-
-      mex <- IRTree.reduce test me
+      (mex, result) <- runWriterT (IRTree.reduce (debugPredicate showString (prettyExprS 0) predicate) me)
       rex `shouldBe` mex
-
-      result <- readIORef ref
-      pure $ golden ("test/expected/" <> str <> "-red") result
+      pure $ golden ("test/expected/" <> str <> "-red") (appEndo result "")
 
     it "should find an opr exponentially" do
-      ref <- newIORef ""
-
-      let test i = do
-            let x = predicate i
-            modifyIORef' ref (\t -> t <> bool "0" "1" x <> ": " <> maybe "-" (flip (prettyExprS 0) "") i <> "\n")
-            pure x
-
-      mex <- IRTree.reduceExp test me
+      (mex, result) <- runWriterT (IRTree.reduceExp (debugPredicate showString (prettyExprS 0) predicate) me)
       rex `shouldBe` mex
-
-      result <- readIORef ref
-      pure $ golden ("test/expected/" <> str <> "-red-exp") result
+      pure $ golden ("test/expected/" <> str <> "-red-exp") (appEndo result "")
 
     it "should reduce like iinputs" do
       forM_ (RTree.iinputs re) \(ii, e') -> do
         p <- toPredicate ii
-        IRTree.reduce p me `shouldReturn` Just e'
+        IRTree.reduce (const p) me `shouldReturn` Just e'
+
+debugPredicate
+  :: (Monad m)
+  => (l -> ShowS)
+  -> (i -> ShowS)
+  -> (i -> m Bool)
+  -> [(Bool, l)]
+  -> i
+  -> WriterT (Endo String) m Bool
+debugPredicate ppl ppi predicate lst i = do
+  x <- lift (predicate i)
+  tell . Endo $
+    showString (bool "0" "1" x)
+      . showString ": "
+      . ppi i
+      . showString "\n"
+      . case nonEmpty lst of
+        Nothing -> showString "initial\n"
+        Just lst' -> ppl (snd $ NE.last lst') . showString "\n"
+
+  pure x

rtree/test/src/Control/Monad/RTreeSpec.hs

 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -8,8 +7,7 @@ module Control.Monad.RTreeSpec where
 
 import Control.Monad.Identity (Identity (runIdentity))
 import Control.Monad.RTree
-import Control.Monad.State
-import Control.Monad.Trans.Maybe
+import Control.Monad.Reader
 import Data.Expr as Expr
 import Data.Foldable
 import Data.Functor
@@ -21,11 +19,11 @@ import Test.Hspec.GitGolden
 shouldBeString :: String -> String -> Pretty.Expectation
 shouldBeString = Pretty.shouldBe
 
-rBool :: (MonadReduce m) => m Bool
-rBool = split (pure False) (pure True)
+rBool :: (MonadReduce () m) => m Bool
+rBool = split () (pure False) (pure True)
 
-rList :: (MonadReduce m) => [a] -> m [a]
-rList = collect (given $>)
+rList :: (MonadReduce () m) => [Int] -> m [Int]
+rList = collect (given () $>)
 
 spec :: Spec
 spec = do
@@ -40,11 +38,11 @@ rtreeTSpec = describe "RTreeT" do
       equiv (rList [1, 2, 3 :: Int]) extract (runIdentity . extractT)
 
     it "should input like RTree" do
-      equiv (rList [1, 2, 3 :: Int]) inputs (toList :: RTreeT Identity [Int] -> [[Int]])
+      equiv (rList [1, 2, 3 :: Int]) inputs (toList :: RTreeT () Identity [Int] -> [[Int]])
 
 equiv
-  :: (Show b, MonadReduce x, MonadReduce y, Eq b)
-  => (forall m. (MonadReduce m) => m a)
+  :: (Show b, MonadReduce l x, MonadReduce l y, Eq b)
+  => (forall m. (MonadReduce l m) => m a)
   -> (x a -> b)
   -> (y a -> b)
   -> IO ()
@@ -85,7 +83,7 @@ rtreeSpec = describe "RTree" do
     it "should pretty print it's tree" do
       golden
         "test/expected/rlist-drawrtree"
-        (drawRTree show (rList [1, 2, 3 :: Int]))
+        (drawRTree (\() -> id) shows (rList [1, 2, 3 :: Int]))
 
 examplesSpec :: Spec
 examplesSpec = describe "example" do
@@ -102,17 +100,17 @@ examplesSpec = describe "example" do
     Let "x" (Cnt 1) (Let "x" (Cnt 2) (Opr (Var "x") (Var "x")))
  where
   handle str e = describe (str <> " (" <> prettyExprS 0 e ")") do
-    let me = runMaybeT $ Expr.rExpr e
+    let me = Expr.rExpr e
     it "should extract" do
-      extract (runStateT me Map.empty)
-        `shouldBe` (Just e, Map.empty)
+      extract (runReaderT me Map.empty)
+        `shouldBe` e
 
-    let re = evalStateT me Map.empty
+    let re = runReaderT me Map.empty
 
     it "should draw the same" do
       golden
         ("test/expected/" <> str)
-        (drawRTree (maybe "⊥" (flip (prettyExprS 0) "")) re)
+        (drawRTree showString (prettyExprS 0) re)
 
     it "should reduce like iinputs" do
       forM_ (iinputs re) \(ii, e') -> do