From 973c2255deb32b404a9109a4452d525aea3efc95 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Mon, 21 Jun 2021 17:26:52 +0200
Subject: [PATCH 01/11] WIP add HandlingState tests

---
 .../essence-of-live-coding.cabal              |  1 +
 essence-of-live-coding/test/Handle.hs         |  1 +
 essence-of-live-coding/test/HandlingState.hs  | 72 +++++++++++++++++++
 essence-of-live-coding/test/Main.hs           |  2 +
 4 files changed, 76 insertions(+)
 create mode 100644 essence-of-live-coding/test/HandlingState.hs

diff --git a/essence-of-live-coding/essence-of-live-coding.cabal b/essence-of-live-coding/essence-of-live-coding.cabal
index de0bd7e7..3dc81ac4 100644
--- a/essence-of-live-coding/essence-of-live-coding.cabal
+++ b/essence-of-live-coding/essence-of-live-coding.cabal
@@ -105,6 +105,7 @@ test-suite test
     , Feedback
     , Handle
     , Handle.LiveProgram
+    , HandlingState
     , Monad
     , Monad.Trans
     , RuntimeIO.Launch
diff --git a/essence-of-live-coding/test/Handle.hs b/essence-of-live-coding/test/Handle.hs
index c0383aca..fc505e28 100644
--- a/essence-of-live-coding/test/Handle.hs
+++ b/essence-of-live-coding/test/Handle.hs
@@ -94,6 +94,7 @@ cellWithActionTypelevel action =
     runHandlingStateC $
       handling testTypelevelHandle >>> arrM (<$ lift action)
 
+test :: Test
 test =
   testGroup
     "Handle"
diff --git a/essence-of-live-coding/test/HandlingState.hs b/essence-of-live-coding/test/HandlingState.hs
new file mode 100644
index 00000000..d58bde63
--- /dev/null
+++ b/essence-of-live-coding/test/HandlingState.hs
@@ -0,0 +1,72 @@
+module HandlingState where
+
+-- base
+import Control.Monad.Identity
+
+-- transformers
+import Control.Monad.Trans.Writer.Strict
+
+-- test-framework
+import Test.Framework
+
+-- HUnit
+import Test.HUnit hiding (Test)
+
+-- test-framework-hunit
+import Test.Framework.Providers.HUnit
+
+-- essence-of-live-coding
+import LiveCoding.HandlingState
+import Control.Monad.Trans.Accum
+import Data.IntMap
+
+extractHandlingStateEffect :: HandlingStateT (WriterT [String] Identity) a -> [String]
+extractHandlingStateEffect = runIdentity . execWriterT . runHandlingStateT
+
+test :: Test
+test = testGroup "HandlingState"
+  [ testCase "Registered action doesn't get triggered"
+      $ [] @=? extractHandlingStateEffect (register $ tell ["clean up"])
+  , testCase "Reregistering avoids trigger" $ do
+      let action = do
+            key <- garbageCollected $ register $ tell ["clean up"]
+            reregister (tell ["reregistered"]) key
+      [] @=? extractHandlingStateEffect action
+  , testCase "Not reregistered action gets triggered" $ do
+      let action = do
+            register $ tell ["clean up"]
+            garbageCollected $ return ()
+      ["clean up"] @=? extractHandlingStateEffect action
+  , testCase "Reregistered action gets triggered" $ do
+      let action = do
+            key <- register $ tell ["clean up"]
+            garbageCollected $ reregister (tell ["reregistered clean up"]) key
+            garbageCollected $ return ()
+      ["reregistered clean up"] @=? extractHandlingStateEffect action
+  , testCase "Registering causes the destructor to appear in the state" $ do
+      let (((key, registry), handlingState), log) = runWriter $ runWriterT $ flip runAccumT mempty $ unHandlingStateT $ register $ tell ["clean up"]
+      singleton key ((), ["clean up"]) @=? runWriter . action <$> destructors handlingState
+      [] @=? log
+      [key] @=? registered handlingState
+  , testCase "Reregistering causes the destructor to appear in the state" $ do
+      let (((key, registry), handlingState), log) = runWriter $ runWriterT $ flip runAccumT mempty $ unHandlingStateT $ do
+            key <- register $ tell ["clean up"]
+            reregister (tell ["clean up"]) key
+            return key
+      singleton key ((), ["clean up"]) @=? runWriter . action <$> destructors handlingState
+      [] @=? log
+      [key] @=? registered handlingState
+  , testCase "Garbage collection leaves registered destructors in place and unregisters them" $ do
+      let (((key, registry), handlingState), log) = runWriter $ runWriterT $ flip runAccumT mempty $ unHandlingStateT $ garbageCollected $ register $ tell ["clean up"]
+      singleton key ((), ["clean up"]) @=? runWriter . action <$> destructors handlingState
+      [] @=? log
+      [] @=? registered handlingState
+  , testCase "Garbage collection leaves reregistered destructors in place and unregisters them" $ do
+      let (((key, registry), handlingState), log) = runWriter $ runWriterT $ flip runAccumT mempty $ unHandlingStateT $ garbageCollected $ do
+            key <- register $ tell ["clean up"]
+            reregister (tell ["reregister clean up"]) key
+            return key
+      singleton key ((), ["reregister clean up"]) @=? runWriter . action <$> destructors handlingState
+      [] @=? log
+      [] @=? registered handlingState
+  ]
diff --git a/essence-of-live-coding/test/Main.hs b/essence-of-live-coding/test/Main.hs
index 2a8e0656..27540518 100644
--- a/essence-of-live-coding/test/Main.hs
+++ b/essence-of-live-coding/test/Main.hs
@@ -20,6 +20,7 @@ import Test.QuickCheck
 import qualified Cell
 import qualified Feedback
 import qualified Handle
+import qualified HandlingState
 import qualified Migrate.NoMigration
 import qualified Monad
 import qualified Monad.Trans
@@ -133,6 +134,7 @@ tests =
           ]
       , Cell.test
       , Handle.test
+    , HandlingState.test
       , Migrate.NoMigration.test
       , Monad.test
       , Feedback.test

From 19fccabb32e7446403551b8c0b09f5c9fce6af2b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Thu, 30 Dec 2021 21:43:20 +0100
Subject: [PATCH 02/11] FIXUP leave out

---
 essence-of-live-coding/test/HandlingState.hs | 26 --------------------
 1 file changed, 26 deletions(-)

diff --git a/essence-of-live-coding/test/HandlingState.hs b/essence-of-live-coding/test/HandlingState.hs
index d58bde63..6a752d22 100644
--- a/essence-of-live-coding/test/HandlingState.hs
+++ b/essence-of-live-coding/test/HandlingState.hs
@@ -43,30 +43,4 @@ test = testGroup "HandlingState"
             garbageCollected $ reregister (tell ["reregistered clean up"]) key
             garbageCollected $ return ()
       ["reregistered clean up"] @=? extractHandlingStateEffect action
-  , testCase "Registering causes the destructor to appear in the state" $ do
-      let (((key, registry), handlingState), log) = runWriter $ runWriterT $ flip runAccumT mempty $ unHandlingStateT $ register $ tell ["clean up"]
-      singleton key ((), ["clean up"]) @=? runWriter . action <$> destructors handlingState
-      [] @=? log
-      [key] @=? registered handlingState
-  , testCase "Reregistering causes the destructor to appear in the state" $ do
-      let (((key, registry), handlingState), log) = runWriter $ runWriterT $ flip runAccumT mempty $ unHandlingStateT $ do
-            key <- register $ tell ["clean up"]
-            reregister (tell ["clean up"]) key
-            return key
-      singleton key ((), ["clean up"]) @=? runWriter . action <$> destructors handlingState
-      [] @=? log
-      [key] @=? registered handlingState
-  , testCase "Garbage collection leaves registered destructors in place and unregisters them" $ do
-      let (((key, registry), handlingState), log) = runWriter $ runWriterT $ flip runAccumT mempty $ unHandlingStateT $ garbageCollected $ register $ tell ["clean up"]
-      singleton key ((), ["clean up"]) @=? runWriter . action <$> destructors handlingState
-      [] @=? log
-      [] @=? registered handlingState
-  , testCase "Garbage collection leaves reregistered destructors in place and unregisters them" $ do
-      let (((key, registry), handlingState), log) = runWriter $ runWriterT $ flip runAccumT mempty $ unHandlingStateT $ garbageCollected $ do
-            key <- register $ tell ["clean up"]
-            reregister (tell ["reregister clean up"]) key
-            return key
-      singleton key ((), ["reregister clean up"]) @=? runWriter . action <$> destructors handlingState
-      [] @=? log
-      [] @=? registered handlingState
   ]

From 167cd60c89f9ee892bd1a577b24207da385b7587 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Tue, 1 Jun 2021 12:32:39 +0200
Subject: [PATCH 03/11] WIP custom monad

---
 .../src/LiveCoding/HandlingState.hs           | 44 ++++++++++++++++++-
 1 file changed, 43 insertions(+), 1 deletion(-)

diff --git a/essence-of-live-coding/src/LiveCoding/HandlingState.hs b/essence-of-live-coding/src/LiveCoding/HandlingState.hs
index b7a0fa56..57bd2e38 100644
--- a/essence-of-live-coding/src/LiveCoding/HandlingState.hs
+++ b/essence-of-live-coding/src/LiveCoding/HandlingState.hs
@@ -1,8 +1,13 @@
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
-
+{-# LANGUAGE UndecidableInstances #-}
 module LiveCoding.HandlingState where
 
 -- base
@@ -24,6 +29,7 @@ import LiveCoding.Cell.Monad
 import LiveCoding.Cell.Monad.Trans
 import LiveCoding.LiveProgram
 import LiveCoding.LiveProgram.Monad.Trans
+import qualified Data.IntSet as IntSet
 
 data Handling h = Handling
   { key :: Key
@@ -45,6 +51,42 @@ data HandlingState m = HandlingState
 -}
 type HandlingStateT m = StateT (HandlingState m) m
 
+instance Semigroup (HandlingState m) where
+  handlingState1 <> handlingState2 = HandlingState
+    { nHandles = nHandles handlingState1 `max` nHandles handlingState2
+    , destructors = destructors handlingState1 <> destructors handlingState2
+    }
+
+data MyHandlingState m a = MyHandlingState
+  { handlingState :: HandlingState m
+  , registered :: [Key]
+  , value :: a
+  }
+  deriving Functor
+
+newtype MyHandlingStateT m a = MyHandlingStateT
+  { unMyHandlingStateT :: m (MyHandlingState m a) }
+  deriving Functor
+
+instance Monad m => Monad (MyHandlingStateT m) where
+  return a = MyHandlingStateT $ return MyHandlingState
+    { handlingState = initHandlingState
+    , registered = []
+    , value = a
+    }
+  action >>= continuation = MyHandlingStateT $ do
+    firstState <- unMyHandlingStateT action
+    continuationState <- unMyHandlingStateT $ continuation $ value firstState
+    let registeredLater = registered continuationState
+        handlingStateEarlier = handlingState firstState <> handlingState continuationState
+        handlingStateLater = handlingStateEarlier
+          { destructors = destructors handlingStateEarlier `restrictKeys` IntSet.fromList registeredLater }
+    return MyHandlingState
+      { handlingState = handlingStateLater
+      , registered = registeredLater
+      , value = value continuationState
+      }
+
 initHandlingState :: HandlingState m
 initHandlingState =
   HandlingState

From 587c9e3853445b6222fe9ad1179a2a70bd4da074 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Tue, 1 Jun 2021 16:35:36 +0200
Subject: [PATCH 04/11] WIP accum & writer

---
 .../essence-of-live-coding.cabal              |   2 +
 .../src/LiveCoding/HandlingState.hs           | 232 ++++++++++--------
 .../test/Handle/LiveProgram.hs                |  16 +-
 3 files changed, 139 insertions(+), 111 deletions(-)

diff --git a/essence-of-live-coding/essence-of-live-coding.cabal b/essence-of-live-coding/essence-of-live-coding.cabal
index 3dc81ac4..b640c718 100644
--- a/essence-of-live-coding/essence-of-live-coding.cabal
+++ b/essence-of-live-coding/essence-of-live-coding.cabal
@@ -79,11 +79,13 @@ library
     , LiveCoding.Preliminary.LiveProgram.HotCodeSwap
     , LiveCoding.Preliminary.LiveProgram.LiveProgram2
     , LiveCoding.Preliminary.LiveProgram.LiveProgramPreliminary
+    , LiveCoding.HandlingState.AccumTOrphan
 
   other-extensions:    DeriveDataTypeable
   build-depends:
       base >= 4.11 && < 5
     , transformers >= 0.5
+    , mtl >= 2.2
     , containers >= 0.6
     , syb >= 0.7
     , vector-sized >= 1.2
diff --git a/essence-of-live-coding/src/LiveCoding/HandlingState.hs b/essence-of-live-coding/src/LiveCoding/HandlingState.hs
index 57bd2e38..8271816d 100644
--- a/essence-of-live-coding/src/LiveCoding/HandlingState.hs
+++ b/essence-of-live-coding/src/LiveCoding/HandlingState.hs
@@ -1,27 +1,39 @@
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
 module LiveCoding.HandlingState where
 
 -- base
 import Control.Arrow (arr, returnA, (>>>))
+import Control.Monad.IO.Class
 import Data.Data
+import Data.Foldable (traverse_)
+import Data.Functor (($>))
+import qualified Data.List as List
 
 -- transformers
+import Control.Monad.Trans.Accum
 import Control.Monad.Trans.Class (MonadTrans (lift))
-import Control.Monad.Trans.State.Strict
-import Data.Foldable (traverse_)
+import Control.Monad.Trans.Writer.Strict ( WriterT(runWriterT) )
+import Control.Monad.Trans.Accum
+    ( add, look, runAccumT, AccumT(..) )
+
+-- mtl
+import Control.Monad.Writer.Class
 
 -- containers
 import Data.IntMap
 import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
 
 -- essence-of-live-coding
 import LiveCoding.Cell
@@ -29,7 +41,7 @@ import LiveCoding.Cell.Monad
 import LiveCoding.Cell.Monad.Trans
 import LiveCoding.LiveProgram
 import LiveCoding.LiveProgram.Monad.Trans
-import qualified Data.IntSet as IntSet
+import LiveCoding.HandlingState.AccumTOrphan
 
 data Handling h = Handling
   { key :: Key
@@ -40,39 +52,38 @@ type Destructors m = IntMap (Destructor m)
 
 -- | Hold a map of registered handle keys and destructors
 data HandlingState m = HandlingState
-  { nHandles :: Key
-  , destructors :: Destructors m
+  { destructors :: Destructors m
+  , registered :: [Key] -- TODO Make it an intset?
   }
   deriving (Data)
 
-{- | In this monad, handles can be registered,
-   and their destructors automatically executed.
-   It is basically a monad in which handles are automatically garbage collected.
--}
-type HandlingStateT m = StateT (HandlingState m) m
-
 instance Semigroup (HandlingState m) where
   handlingState1 <> handlingState2 = HandlingState
-    { nHandles = nHandles handlingState1 `max` nHandles handlingState2
-    , destructors = destructors handlingState1 <> destructors handlingState2
+    { destructors = destructors handlingState1 <> destructors handlingState2
+    , registered = registered handlingState1 `List.union` registered handlingState2
     }
 
-data MyHandlingState m a = MyHandlingState
-  { handlingState :: HandlingState m
-  , registered :: [Key]
-  , value :: a
+instance Monoid (HandlingState m) where
+  mempty = HandlingState
+    { destructors = IntMap.empty
+    , registered = []
+    }
+
+newtype Registry = Registry
+  { nHandles :: Key
   }
-  deriving Functor
 
-newtype MyHandlingStateT m a = MyHandlingStateT
-  { unMyHandlingStateT :: m (MyHandlingState m a) }
-  deriving Functor
+instance Semigroup Registry where
+  registry1 <> registry2 = Registry $ nHandles registry1 + nHandles registry2
+
+instance Monoid Registry where
+  mempty = Registry 0
 
+{-
 instance Monad m => Monad (MyHandlingStateT m) where
   return a = MyHandlingStateT $ return MyHandlingState
-    { handlingState = initHandlingState
+    { handlingState = mempty
     , registered = []
-    , value = a
     }
   action >>= continuation = MyHandlingStateT $ do
     firstState <- unMyHandlingStateT action
@@ -84,25 +95,33 @@ instance Monad m => Monad (MyHandlingStateT m) where
     return MyHandlingState
       { handlingState = handlingStateLater
       , registered = registeredLater
-      , value = value continuationState
       }
+-}
 
-initHandlingState :: HandlingState m
-initHandlingState =
-  HandlingState
-    { nHandles = 0
-    , destructors = IntMap.empty
-    }
+-- | In this monad, handles can be registered,
+--   and their destructors automatically executed.
+--   It is basically a monad in which handles are automatically garbage collected.
+newtype HandlingStateT m a = HandlingStateT
+  { unHandlingStateT :: AccumT Registry (WriterT (HandlingState m) m) a }
+  deriving (Functor, Applicative, Monad, MonadIO)
 
-{- | Handle the 'HandlingStateT' effect _without_ garbage collection.
-   Apply this to your main loop after calling 'foreground'.
-   Since there is no garbage collection, don't use this function for live coding.
--}
-runHandlingStateT ::
-  Monad m =>
-  HandlingStateT m a ->
-  m a
-runHandlingStateT = flip evalStateT initHandlingState
+instance MonadTrans HandlingStateT where
+  lift = HandlingStateT . lift . lift
+
+
+instance Monad m => MonadWriter (HandlingState m) (HandlingStateT m) where
+  writer = HandlingStateT . writer
+  listen = HandlingStateT . listen . unHandlingStateT
+  pass = HandlingStateT . pass . unHandlingStateT
+
+-- | Handle the 'HandlingStateT' effect _without_ garbage collection.
+--   Apply this to your main loop after calling 'foreground'.
+--   Since there is no garbage collection, don't use this function for live coding.
+runHandlingStateT
+  :: Monad m
+  => HandlingStateT m a
+  -> m a
+runHandlingStateT = fmap fst . runWriterT . fmap fst . flip runAccumT mempty . unHandlingStateT
 
 {- | Apply this to your main live cell before passing it to the runtime.
 
@@ -115,80 +134,78 @@ On every step, it does:
 3. Destroy all still unregistered handles
    (i.e. those that were removed in the last tick)
 -}
-runHandlingStateC ::
-  forall m a b.
-  (Monad m, Typeable m) =>
-  Cell (HandlingStateT m) a b ->
-  Cell m a b
-runHandlingStateC cell =
-  flip runStateC_ initHandlingState $
-    hoistCellOutput garbageCollected cell
+runHandlingStateC
+  :: forall m a b .
+     (Monad m, Typeable m)
+  => Cell (HandlingStateT m) a b
+  -> Cell                 m  a b
+runHandlingStateC = hoistCell $ runHandlingStateT . garbageCollected
+-- runHandlingStateC cell = flip runStateC_ mempty
+--   $ hoistCellOutput garbageCollected cell
 
 -- | Like 'runHandlingStateC', but for whole live programs.
-runHandlingState ::
-  (Monad m, Typeable m) =>
-  LiveProgram (HandlingStateT m) ->
-  LiveProgram m
-runHandlingState LiveProgram {..} =
-  flip
-    runStateL
-    initHandlingState
-    LiveProgram
-      { liveStep = garbageCollected . liveStep
-      , ..
-      }
-
-garbageCollected ::
-  Monad m =>
-  HandlingStateT m a ->
-  HandlingStateT m a
-garbageCollected action = unregisterAll >> action <* destroyUnregistered
+runHandlingState
+  :: (Monad m, Typeable m)
+  => LiveProgram (HandlingStateT m)
+  -> LiveProgram                 m
+runHandlingState = hoistLiveProgram $ runHandlingStateT . garbageCollected
+-- runHandlingState LiveProgram { .. } = flip runStateL mempty LiveProgram
+--   { liveStep = garbageCollected . liveStep
+--   , ..
+--   }
+
+-- Now I need mtl
+garbageCollected
+  :: Monad m
+  => HandlingStateT m a
+  -> HandlingStateT m a
+garbageCollected actionHS = pass $ do
+  (a, HandlingState { .. }) <- listen actionHS
+  let registeredKeys = IntSet.fromList registered
+      registeredConstructors = restrictKeys destructors registeredKeys
+      unregisteredConstructors = withoutKeys destructors registeredKeys
+  lift $ traverse_ action unregisteredConstructors
+  return (a, const HandlingState { destructors = registeredConstructors, registered = [] })
+-- garbageCollected action = unregisterAll >> action <* destroyUnregistered
 
 data Destructor m = Destructor
-  { isRegistered :: Bool
-  , action :: m ()
+  { isRegistered :: Bool -- TODO we don't need this anymore
+  , action       :: m ()
   }
 
-register ::
-  Monad m =>
-  -- | Destructor
-  m () ->
-  HandlingStateT m Key
-register destructor = do
-  HandlingState {..} <- get
-  let key = nHandles + 1
-  put
-    HandlingState
-      { nHandles = key
-      , destructors = insertDestructor destructor key destructors
-      }
+register
+  :: Monad m
+  => m () -- ^ Destructor
+  -> HandlingStateT m Key
+register action = HandlingStateT $ do
+  Registry { nHandles = key } <- look
+  add $ Registry 1
+  tell HandlingState
+    { destructors = singleton key Destructor { isRegistered = True, action }
+    , registered = [key]
+    }
   return key
 
-reregister ::
-  Monad m =>
-  m () ->
-  Key ->
-  HandlingStateT m ()
-reregister action key = do
-  HandlingState {..} <- get
-  put HandlingState {destructors = insertDestructor action key destructors, ..}
-
-insertDestructor ::
-  m () ->
-  Key ->
-  Destructors m ->
-  Destructors m
-insertDestructor action key destructors =
-  let destructor = Destructor {isRegistered = True, ..}
-   in insert key destructor destructors
-
-unregisterAll ::
-  Monad m =>
-  HandlingStateT m ()
-unregisterAll = do
-  HandlingState {..} <- get
-  let newDestructors = IntMap.map (\destructor -> destructor {isRegistered = False}) destructors
-  put HandlingState {destructors = newDestructors, ..}
+reregister
+  :: Monad m
+  => m ()
+  -> Key
+  -> HandlingStateT m ()
+reregister action key = HandlingStateT $ tell HandlingState
+  { destructors = singleton key Destructor { isRegistered = True, action }
+  , registered = [key]
+  }
+
+  -- Doesn't work as a single action
+{-
+unregisterAll
+  :: Monad m
+  => HandlingStateT m ()
+unregisterAll = _ {- do
+  HandlingState { .. } <- get
+  let newDestructors = IntMap.map (\destructor -> destructor { isRegistered = False }) destructors
+  put HandlingState { destructors = newDestructors, .. }
+-}
 
 destroyUnregistered ::
   Monad m =>
@@ -198,7 +215,8 @@ destroyUnregistered = do
   let
     (registered, unregistered) = partition isRegistered destructors
   traverse_ (lift . action) unregistered
-  put HandlingState {destructors = registered, ..}
+  put HandlingState { destructors = registered, .. }
+-}
 
 -- * 'Data' instances
 dataTypeDestructor :: DataType
diff --git a/essence-of-live-coding/test/Handle/LiveProgram.hs b/essence-of-live-coding/test/Handle/LiveProgram.hs
index 8e58286e..38d7bae3 100644
--- a/essence-of-live-coding/test/Handle/LiveProgram.hs
+++ b/essence-of-live-coding/test/Handle/LiveProgram.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module Handle.LiveProgram where
 
@@ -14,6 +15,9 @@ import Control.Monad.Trans.RWS.Strict (RWS, tell)
 import qualified Control.Monad.Trans.RWS.Strict as RWS
 import Control.Monad.Trans.State.Strict
 
+-- mtl
+import Control.Monad.Writer (listen)
+
 -- test-framework
 import Test.Framework
 
@@ -23,7 +27,9 @@ import Test.Framework.Providers.QuickCheck2
 -- essence-of-live-coding
 import LiveCoding
 import LiveCoding.Handle
+import LiveCoding.HandlingState
 import Util.LiveProgramMigration
+import Control.Monad.Trans.Accum
 
 testHandle :: Handle (RWS () [String] Int) String
 testHandle =
@@ -44,8 +50,8 @@ test =
         LiveProgramMigration
           { liveProgram1 =
               runHandlingState $
-                liveCell $
-                  handling testHandle >>> arrM (lift . tell . return) >>> constM inspectHandlingState
+                liveCell $ hoistCell inspectingHandlingState $
+                  handling testHandle >>> arrM (lift . tell . return)
           , liveProgram2 = runHandlingState mempty
           , input1 = replicate 3 ()
           , input2 = replicate 3 ()
@@ -57,10 +63,12 @@ test =
           }
     ]
   where
-    inspectHandlingState = do
-      HandlingState {..} <- get
+    inspectingHandlingState action = do
+      (a, HandlingState { .. }) <- listen action
+        Registry {..} <- HandlingStateT look
       lift $
         tell
           [ "Handles: " ++ show nHandles
           , "Destructors: " ++ unwords (show . second isRegistered <$> IntMap.toList destructors)
           ]
+        return a

From 04838da108cffbdbb9cfd6b045712dd64c32c032 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Fri, 31 Dec 2021 15:37:30 +0100
Subject: [PATCH 05/11] WIP writer & accum to state

---
 .../essence-of-live-coding.cabal              |   1 +
 .../src/LiveCoding/Cell/Monad/Trans.hs        |  17 +++
 .../src/LiveCoding/HandlingState.hs           | 114 ++++++++++++++++--
 .../test/Handle/LiveProgram.hs                |  55 ++++-----
 essence-of-live-coding/test/HandlingState.hs  |  34 +++++-
 5 files changed, 181 insertions(+), 40 deletions(-)

diff --git a/essence-of-live-coding/essence-of-live-coding.cabal b/essence-of-live-coding/essence-of-live-coding.cabal
index b640c718..0369729a 100644
--- a/essence-of-live-coding/essence-of-live-coding.cabal
+++ b/essence-of-live-coding/essence-of-live-coding.cabal
@@ -92,6 +92,7 @@ library
     , foreign-store >= 0.2
     , time >= 1.9
     , mmorph >= 1.1
+    , has-transformers
   hs-source-dirs:      src
   default-language:    Haskell2010
   default-extensions: StrictData
diff --git a/essence-of-live-coding/src/LiveCoding/Cell/Monad/Trans.hs b/essence-of-live-coding/src/LiveCoding/Cell/Monad/Trans.hs
index bcf081f7..b06cbe6e 100644
--- a/essence-of-live-coding/src/LiveCoding/Cell/Monad/Trans.hs
+++ b/essence-of-live-coding/src/LiveCoding/Cell/Monad/Trans.hs
@@ -52,6 +52,23 @@ data State stateT stateInternal = State
   }
   deriving (Data, Eq, Show)
 
+-- runAccumC
+--   :: (Data accumT, Monad m)
+--   => Cell (AccumT accumT m) a  b
+--   -- ^ A cell with an accum state effect
+--   -> accumT
+--   -- ^ The initial state
+--   -> Cell                m  a (b, accumT)
+--   -- ^ The cell, returning its current state
+-- runAccumC cell stateT = _
+
+-- | The internal state of a cell to which 'runAccumC' or 'runAccumL' has been applied.
+data Accum accumT accumInternal = Accum
+  { accumT :: accumT
+  , accumInternal :: accumInternal
+  }
+  deriving (Data, Eq, Show)
+
 -- | Supply a 'ReaderT' environment before running the cell
 runReaderC ::
   r ->
diff --git a/essence-of-live-coding/src/LiveCoding/HandlingState.hs b/essence-of-live-coding/src/LiveCoding/HandlingState.hs
index 8271816d..8c08f9ab 100644
--- a/essence-of-live-coding/src/LiveCoding/HandlingState.hs
+++ b/essence-of-live-coding/src/LiveCoding/HandlingState.hs
@@ -10,10 +10,14 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeApplications #-}
+
 module LiveCoding.HandlingState where
 
 -- base
-import Control.Arrow (arr, returnA, (>>>))
+import Control.Arrow (arr, returnA, (>>>), second)
 import Control.Monad.IO.Class
 import Data.Data
 import Data.Foldable (traverse_)
@@ -23,7 +27,7 @@ import qualified Data.List as List
 -- transformers
 import Control.Monad.Trans.Accum
 import Control.Monad.Trans.Class (MonadTrans (lift))
-import Control.Monad.Trans.Writer.Strict ( WriterT(runWriterT) )
+import Control.Monad.Trans.Writer.Strict ( WriterT(runWriterT, WriterT), mapWriter, mapWriterT )
 import Control.Monad.Trans.Accum
     ( add, look, runAccumT, AccumT(..) )
 
@@ -41,6 +45,11 @@ import LiveCoding.Cell.Monad
 import LiveCoding.Cell.Monad.Trans
 import LiveCoding.LiveProgram
 import LiveCoding.LiveProgram.Monad.Trans
+import LiveCoding.HandlingState.AccumTOrphan
+import Control.Monad.Trans.State.Strict (StateT (StateT), runStateT, evalStateT, modify, get, put)
+import Control.Monad.Morph (hoist, MFunctor)
+import Control.Monad.Trans.Has
+
 import LiveCoding.HandlingState.AccumTOrphan
 
 data Handling h = Handling
@@ -69,9 +78,20 @@ instance Monoid (HandlingState m) where
     , registered = []
     }
 
+-- FIXME see whether this gets easier with lenses
+hoistHandlingState ::
+  (forall x . m x -> n x) ->
+  HandlingState m ->
+  HandlingState n
+hoistHandlingState morph HandlingState { .. } = HandlingState
+  { destructors = (\Destructor { .. } -> Destructor { action = morph action, .. }) <$> destructors
+  , ..
+  }
+
 newtype Registry = Registry
   { nHandles :: Key
   }
+  deriving Data
 
 instance Semigroup Registry where
   registry1 <> registry2 = Registry $ nHandles registry1 + nHandles registry2
@@ -108,12 +128,51 @@ newtype HandlingStateT m a = HandlingStateT
 instance MonadTrans HandlingStateT where
   lift = HandlingStateT . lift . lift
 
+instance MFunctor HandlingStateT where
+  hoist morph
+    = HandlingStateT
+    . hoist (mapWriterT $ morph . fmap (second $ hoistHandlingState morph))
+    . unHandlingStateT
 
 instance Monad m => MonadWriter (HandlingState m) (HandlingStateT m) where
   writer = HandlingStateT . writer
   listen = HandlingStateT . listen . unHandlingStateT
   pass = HandlingStateT . pass . unHandlingStateT
 
+writerToState :: (Semigroup w, Has (StateT w) m, Monad m) => WriterT w m a -> m a
+writerToState (WriterT action) = do
+  (a, w) <- action
+  liftH $ modify (<> w)
+  return a
+
+accumToState :: (Monad m, Semigroup w, Has (StateT w) m) => AccumT w m a -> m a
+accumToState (AccumT action) = do
+  w <- liftH get
+  (a, w') <- action w
+  liftH $ put $ w <> w'
+  return a
+-- accumToState :: (Functor m, Semigroup w) => AccumT w m a -> StateT w m a
+-- accumToState (AccumT action) = StateT $ \w -> second (w <>) <$> action w
+
+-- FIXME rewrite with lenses
+zoomStateL :: Functor m => StateT s m a -> StateT (s, s') m a
+zoomStateL (StateT action) = StateT $ \(s, s') -> second (, s') <$> action s
+zoomStateR :: Functor m => StateT s m a -> StateT (s', s) m a
+zoomStateR (StateT action) = StateT $ \(s', s) -> second (s', ) <$> action s
+
+-- FIXME Rename. To SimpleHandlingState? Or maybe a newtype?
+-- Also this might be the right place for the division between one m and two
+type HandlingStateStateT m a = AccumT Registry (StateT (HandlingState m) m) a
+
+handlingStateWriterToState :: Monad m => HandlingStateT m a -> HandlingStateStateT m a
+handlingStateWriterToState = unHandlingStateT >>> hoist (hoist lift >>> writerToState)
+
+runHandlingStateStateT :: Monad m => HandlingStateStateT m a -> m a
+runHandlingStateStateT
+  = flip evalStateT mempty
+  . fmap fst
+  . flip runAccumT mempty
+
 -- | Handle the 'HandlingStateT' effect _without_ garbage collection.
 --   Apply this to your main loop after calling 'foreground'.
 --   Since there is no garbage collection, don't use this function for live coding.
@@ -121,7 +180,9 @@ runHandlingStateT
   :: Monad m
   => HandlingStateT m a
   -> m a
-runHandlingStateT = fmap fst . runWriterT . fmap fst . flip runAccumT mempty . unHandlingStateT
+runHandlingStateT
+  = runHandlingStateStateT
+  . handlingStateWriterToState
 
 {- | Apply this to your main live cell before passing it to the runtime.
 
@@ -139,7 +200,11 @@ runHandlingStateC
      (Monad m, Typeable m)
   => Cell (HandlingStateT m) a b
   -> Cell                 m  a b
-runHandlingStateC = hoistCell $ runHandlingStateT . garbageCollected
+-- runHandlingStateC = hoistCell $ runHandlingStateStateT . garbageCollected . handlingStateWriterToState
+runHandlingStateC
+  = flip runStateC_ mempty
+  . flip runStateC_ mempty
+  . hoistCell (accumToState . hoist (hoist (lift @(StateT Registry))) . garbageCollected . handlingStateWriterToState)
 -- runHandlingStateC cell = flip runStateC_ mempty
 --   $ hoistCellOutput garbageCollected cell
 
@@ -148,17 +213,27 @@ runHandlingState
   :: (Monad m, Typeable m)
   => LiveProgram (HandlingStateT m)
   -> LiveProgram                 m
-runHandlingState = hoistLiveProgram $ runHandlingStateT . garbageCollected
+-- runHandlingState = hoistLiveProgram $ runHandlingStateStateT . garbageCollected . handlingStateWriterToState
 -- runHandlingState LiveProgram { .. } = flip runStateL mempty LiveProgram
 --   { liveStep = garbageCollected . liveStep
 --   , ..
 --   }
+runHandlingState LiveProgram { .. } = flip runStateL mempty $ flip runStateL mempty $ LiveProgram
+  { liveStep = accumToState . hoist (hoist (lift @(StateT Registry))) . garbageCollected . handlingStateWriterToState . liveStep
+  -- { liveStep = garbageCollected . handlingStateWriterToState . liveStep
+  , ..
+  }
 
--- Now I need mtl
+
+-- This could simply be an action in the monad
+-- Now I need mtl -- nonsense
 garbageCollected
   :: Monad m
-  => HandlingStateT m a
-  -> HandlingStateT m a
+  -- => HandlingStateT m a
+  -- -> HandlingStateT m a
+  => HandlingStateStateT m a
+  -> HandlingStateStateT m a
+{-
 garbageCollected actionHS = pass $ do
   (a, HandlingState { .. }) <- listen actionHS
   let registeredKeys = IntSet.fromList registered
@@ -167,6 +242,29 @@ garbageCollected actionHS = pass $ do
   lift $ traverse_ action unregisteredConstructors
   return (a, const HandlingState { destructors = registeredConstructors, registered = [] })
 -- garbageCollected action = unregisterAll >> action <* destroyUnregistered
+garbageCollected actionHS
+  = HandlingStateT
+  $ AccumT
+  $ \registry
+  -> WriterT
+  $ do
+    (aAndRegistry, HandlingState { .. }) <- runWriterT $ flip runAccumT registry $ unHandlingStateT actionHS
+    let registeredKeys = IntSet.fromList registered
+        registeredConstructors = restrictKeys destructors registeredKeys
+        unregisteredConstructors = withoutKeys destructors registeredKeys
+    traverse_ action unregisteredConstructors
+    return (aAndRegistry, HandlingState { destructors = registeredConstructors, registered = [] })
+-}
+garbageCollected actionHS = do
+  a <- actionHS
+  HandlingState { .. } <- liftH get
+  let registeredKeys = IntSet.fromList registered
+      registeredConstructors = restrictKeys destructors registeredKeys
+      unregisteredConstructors = withoutKeys destructors registeredKeys
+  lift $ lift $ traverse_ action unregisteredConstructors
+  liftH $ put HandlingState { destructors = registeredConstructors, registered = [] }
+  return a
+
 
 data Destructor m = Destructor
   { isRegistered :: Bool -- TODO we don't need this anymore
diff --git a/essence-of-live-coding/test/Handle/LiveProgram.hs b/essence-of-live-coding/test/Handle/LiveProgram.hs
index 38d7bae3..2a2e9410 100644
--- a/essence-of-live-coding/test/Handle/LiveProgram.hs
+++ b/essence-of-live-coding/test/Handle/LiveProgram.hs
@@ -31,7 +31,9 @@ import LiveCoding.HandlingState
 import Util.LiveProgramMigration
 import Control.Monad.Trans.Accum
 
-testHandle :: Handle (RWS () [String] Int) String
+type TestMonad = RWS () [String] Int
+
+testHandle :: Handle TestMonad String
 testHandle =
   Handle
     { create = do
@@ -42,33 +44,26 @@ testHandle =
     , destroy = const $ tell ["Destroyed handle"]
     }
 
-test =
-  testGroup
-    "Handle.LiveProgram"
-    [ testProperty
-        "Trigger destructors in live program"
-        LiveProgramMigration
-          { liveProgram1 =
-              runHandlingState $
-                liveCell $ hoistCell inspectingHandlingState $
-                  handling testHandle >>> arrM (lift . tell . return)
-          , liveProgram2 = runHandlingState mempty
-          , input1 = replicate 3 ()
-          , input2 = replicate 3 ()
-          , output1 =
-              ["Creating Handle #0", "Handle #0", "Handles: 1", "Destructors: (1,True)"]
-                : replicate 2 ["Handle #0", "Handles: 1", "Destructors: (1,True)"]
-          , output2 = [["Destroyed handle"], [], []]
-          , initialState = 0
-          }
+test = testGroup "Handle.LiveProgram"
+  [ testProperty "Trigger destructors in live program" LiveProgramMigration
+    { liveProgram1 = runHandlingState $ liveCell $ hoistCell inspectingHandlingState
+        $ handling testHandle >>> arrM (lift . tell . return)
+    , liveProgram2 = runHandlingState mempty
+    , input1 = replicate 3 ()
+    , input2 = replicate 3 ()
+    , output1 = ["Creating Handle #0", "Handle #0", "Handles: 1", "Destructors: (1,True)"]
+        : replicate 2 ["Handle #0", "Handles: 1", "Destructors: (1,True)"]
+    , output2 = [["Destroyed handle"], [], []]
+    , initialState = 0
+    }
+  ]
+
+inspectingHandlingState :: HandlingStateT TestMonad a -> HandlingStateT TestMonad a
+inspectingHandlingState action = do
+  (a, HandlingState { .. }) <- listen action
+  Registry { .. } <- HandlingStateT look
+  lift $ tell
+    [ "Handles: " ++ show nHandles
+    , "Destructors: " ++ unwords (show . second isRegistered <$> IntMap.toList destructors)
     ]
-  where
-    inspectingHandlingState action = do
-      (a, HandlingState { .. }) <- listen action
-        Registry {..} <- HandlingStateT look
-      lift $
-        tell
-          [ "Handles: " ++ show nHandles
-          , "Destructors: " ++ unwords (show . second isRegistered <$> IntMap.toList destructors)
-          ]
-        return a
+  return a
diff --git a/essence-of-live-coding/test/HandlingState.hs b/essence-of-live-coding/test/HandlingState.hs
index 6a752d22..ea855d0a 100644
--- a/essence-of-live-coding/test/HandlingState.hs
+++ b/essence-of-live-coding/test/HandlingState.hs
@@ -25,6 +25,9 @@ extractHandlingStateEffect = runIdentity . execWriterT . runHandlingStateT
 
 test :: Test
 test = testGroup "HandlingState"
+    []
+{-
+  [ testGroup "HandlingStateT"
   [ testCase "Registered action doesn't get triggered"
       $ [] @=? extractHandlingStateEffect (register $ tell ["clean up"])
   , testCase "Reregistering avoids trigger" $ do
@@ -42,5 +45,32 @@ test = testGroup "HandlingState"
             key <- register $ tell ["clean up"]
             garbageCollected $ reregister (tell ["reregistered clean up"]) key
             garbageCollected $ return ()
-      ["reregistered clean up"] @=? extractHandlingStateEffect action
-  ]
+      ["reregistered clean up"] @=? extractHandlingStateEffect action]
+  , testGroup "HandlingState" [ testCase "Registering causes the destructor to appear in the state" $ do
+      let (((key, registry), handlingState), log) = runWriter $ runWriterT $ flip runAccumT mempty $ unHandlingStateT $ register $ tell ["clean up"]
+      singleton key ((), ["clean up"]) @=? runWriter . action <$> destructors handlingState
+      [] @=? log
+      [key] @=? registered handlingState
+  , testCase "Reregistering causes the destructor to appear in the state" $ do
+      let (((key, registry), handlingState), log) = runWriter $ runWriterT $ flip runAccumT mempty $ unHandlingStateT $ do
+            key <- register $ tell ["clean up"]
+            reregister (tell ["clean up"]) key
+            return key
+      singleton key ((), ["clean up"]) @=? runWriter . action <$> destructors handlingState
+      [] @=? log
+      [key] @=? registered handlingState
+  , testCase "Garbage collection leaves registered destructors in place and unregisters them" $ do
+      let (((key, registry), handlingState), log) = runWriter $ runWriterT $ flip runAccumT mempty $ unHandlingStateT $ garbageCollected $ register $ tell ["clean up"]
+      singleton key ((), ["clean up"]) @=? runWriter . action <$> destructors handlingState
+      [] @=? log
+      [] @=? registered handlingState
+  , testCase "Garbage collection leaves reregistered destructors in place and unregisters them" $ do
+      let (((key, registry), handlingState), log) = runWriter $ runWriterT $ flip runAccumT mempty $ unHandlingStateT $ garbageCollected $ do
+            key <- register $ tell ["clean up"]
+            reregister (tell ["reregister clean up"]) key
+            return key
+      singleton key ((), ["reregister clean up"]) @=? runWriter . action <$> destructors handlingState
+      [] @=? log
+      [] @=? registered handlingState
+  ]]
+-}

From 48bdadb9c2c0223cea9d1dd605fc0d676e244ba7 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Mon, 21 Jun 2021 17:26:29 +0200
Subject: [PATCH 06/11] REWORD probably a fix?

---
 essence-of-live-coding/src/LiveCoding/HandlingState.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/essence-of-live-coding/src/LiveCoding/HandlingState.hs b/essence-of-live-coding/src/LiveCoding/HandlingState.hs
index 8c08f9ab..8fe55f94 100644
--- a/essence-of-live-coding/src/LiveCoding/HandlingState.hs
+++ b/essence-of-live-coding/src/LiveCoding/HandlingState.hs
@@ -68,7 +68,7 @@ data HandlingState m = HandlingState
 
 instance Semigroup (HandlingState m) where
   handlingState1 <> handlingState2 = HandlingState
-    { destructors = destructors handlingState1 <> destructors handlingState2
+    { destructors = destructors handlingState2 <> destructors handlingState1
     , registered = registered handlingState1 `List.union` registered handlingState2
     }
 

From 46e0e02d6f43237c3ceaa831fb8ee917358fad4f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Fri, 7 Jan 2022 12:32:24 +0100
Subject: [PATCH 07/11] CHERRY change & changeInit

---
 .../src/LiveCoding/Cell/Util.hs               |  9 +++++++++
 essence-of-live-coding/test/Cell/Util.hs      | 20 +++++++++++++++++++
 2 files changed, 29 insertions(+)

diff --git a/essence-of-live-coding/src/LiveCoding/Cell/Util.hs b/essence-of-live-coding/src/LiveCoding/Cell/Util.hs
index 4ceabd9c..afc27c61 100644
--- a/essence-of-live-coding/src/LiveCoding/Cell/Util.hs
+++ b/essence-of-live-coding/src/LiveCoding/Cell/Util.hs
@@ -131,6 +131,15 @@ edge = proc b -> do
   bLast <- delay False -< b
   returnA -< b && not bLast
 
+changeInit :: (Monad m, Data a, Eq a) => a -> Cell m a (Maybe a)
+changeInit a0 = proc a -> do
+  aLast <- delay a0 -< a
+  returnA -< guard (a /= aLast) >> Just a
+
+change :: (Monad m, Data a, Eq a) => Cell m a (Maybe a)
+change = arr Just >>> changeInit Nothing >>> arr join
+
+
 -- * Debugging utilities
 
 -- | Print the current UTC time, prepended with the first 8 characters of the given message.
diff --git a/essence-of-live-coding/test/Cell/Util.hs b/essence-of-live-coding/test/Cell/Util.hs
index ad5bfbf9..c89c1afc 100644
--- a/essence-of-live-coding/test/Cell/Util.hs
+++ b/essence-of-live-coding/test/Cell/Util.hs
@@ -95,6 +95,26 @@ test =
           counterexample labelString $
             catMaybes inputs === catMaybes outputs
               .||. bufferNotEmpty
+  , testGroup "change"
+    [ testProperty "changeInit detects change" CellSimulation
+      { cell = changeInit (0 :: Int)
+      , input = [0, 1, 1, 2]
+      , output = [Nothing, Just 1, Nothing, Just 2]
+      }
+    , testProperty "changeInit detects change on first tick" CellSimulation
+      { cell = changeInit (0 :: Int)
+      , input = [1, 1, 1, 2]
+      , output = [Just 1, Nothing, Nothing, Just 2]
+      }
+    , testProperty "change detects change" CellSimulation
+      { cell = change
+      , input = [0 :: Int, 1, 1, 2]
+      , output = [Nothing, Just 1, Nothing, Just 2]
+      }
+    , testProperty "onChange acts on change" CellMigrationSimulation
+      { cell1 = onChange (0 :: Int) $ \p p' a -> return [p, p', a]
+      }
+    ]
     , testProperty "delay a >>> changes >>> hold a == delay a" $
         \(inputs :: [Int]) (startValue :: Int) ->
           fst (runIdentity $ steps (delay startValue) inputs)

From a26b5dd34e3178f318c871f116a262b96a7dd01c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Fri, 7 Jan 2022 12:33:35 +0100
Subject: [PATCH 08/11] AMEND test monad morphisms

---
 .../essence-of-live-coding.cabal              |  1 +
 essence-of-live-coding/test/HandlingState.hs  | 53 +++++++++++++++++--
 2 files changed, 51 insertions(+), 3 deletions(-)

diff --git a/essence-of-live-coding/essence-of-live-coding.cabal b/essence-of-live-coding/essence-of-live-coding.cabal
index 0369729a..9d1afbac 100644
--- a/essence-of-live-coding/essence-of-live-coding.cabal
+++ b/essence-of-live-coding/essence-of-live-coding.cabal
@@ -123,6 +123,7 @@ test-suite test
     , transformers >= 0.5
     , containers >= 0.6
     , mtl >= 2.2
+    , mmorph >= 1.1
     , essence-of-live-coding
     , test-framework >= 0.8
     , test-framework-quickcheck2 >= 0.3
diff --git a/essence-of-live-coding/test/HandlingState.hs b/essence-of-live-coding/test/HandlingState.hs
index ea855d0a..98f9533b 100644
--- a/essence-of-live-coding/test/HandlingState.hs
+++ b/essence-of-live-coding/test/HandlingState.hs
@@ -1,10 +1,20 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module HandlingState where
 
 -- base
 import Control.Monad.Identity
 
+-- containers
+import Data.IntMap
+
 -- transformers
+import Control.Monad.Trans.Accum
 import Control.Monad.Trans.Writer.Strict
+import Control.Monad.Trans.State.Strict
+
+-- mmorph
+import Control.Monad.Morph
 
 -- test-framework
 import Test.Framework
@@ -15,17 +25,54 @@ import Test.HUnit hiding (Test)
 -- test-framework-hunit
 import Test.Framework.Providers.HUnit
 
+-- test-framework-quickcheck2
+import Test.Framework.Providers.QuickCheck2
+
+-- QuickCheck
+import Test.QuickCheck
+
 -- essence-of-live-coding
 import LiveCoding.HandlingState
-import Control.Monad.Trans.Accum
-import Data.IntMap
 
 extractHandlingStateEffect :: HandlingStateT (WriterT [String] Identity) a -> [String]
 extractHandlingStateEffect = runIdentity . execWriterT . runHandlingStateT
 
+runAccumDirectly :: Monoid w => Accum w a -> (a, w)
+runAccumDirectly = flip runAccum mempty
+
+runAccumViaState :: Monoid w => Accum w a -> (a, w)
+runAccumViaState = flip runState mempty . accumToState . hoist lift
+
+runWriterViaState :: Monoid w => Writer w a -> (a, w)
+runWriterViaState = flip runState mempty . writerToState . hoist lift
+
 test :: Test
 test = testGroup "HandlingState"
-    []
+  [ testGroup "Monad morphisms"
+    [ testGroup "AccumT -> StateT"
+      [ testProperty "Combinations of add are preserved"
+          $ \(values :: [[Int]]) ->
+            let action = mapM_ add values
+                lhs = runAccumViaState action
+                rhs = runAccumDirectly action
+            in lhs === rhs
+      , testCase "A combination of add and look is preserved"
+          $ let action = do
+                  add [1]
+                  log1 <- look
+                  add [2]
+                  log12 <- look
+                  add [3]
+            in runAccumDirectly action @=? runAccumViaState action
+      ]
+    , testGroup "WriterT -> StateT"
+      [ testProperty "Combinations of tell are preserved"
+          $ \(values :: [[Int]]) ->
+            let action = mapM_ tell values
+            in runWriter action === runWriterViaState action
+      ]
+    ]
+  ]
 {-
   [ testGroup "HandlingStateT"
   [ testCase "Registered action doesn't get triggered"

From 1e8bf02eb6682d3265a5e0e6568ac67b5c7db358 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Fri, 24 Mar 2023 11:14:17 +0100
Subject: [PATCH 09/11] Upgrade mtl dependency

---
 essence-of-live-coding/essence-of-live-coding.cabal    | 2 +-
 essence-of-live-coding/src/LiveCoding/HandlingState.hs | 2 --
 2 files changed, 1 insertion(+), 3 deletions(-)

diff --git a/essence-of-live-coding/essence-of-live-coding.cabal b/essence-of-live-coding/essence-of-live-coding.cabal
index 9d1afbac..c0c07bb7 100644
--- a/essence-of-live-coding/essence-of-live-coding.cabal
+++ b/essence-of-live-coding/essence-of-live-coding.cabal
@@ -85,7 +85,7 @@ library
   build-depends:
       base >= 4.11 && < 5
     , transformers >= 0.5
-    , mtl >= 2.2
+    , mtl >= 2.3
     , containers >= 0.6
     , syb >= 0.7
     , vector-sized >= 1.2
diff --git a/essence-of-live-coding/src/LiveCoding/HandlingState.hs b/essence-of-live-coding/src/LiveCoding/HandlingState.hs
index 8fe55f94..da0153fd 100644
--- a/essence-of-live-coding/src/LiveCoding/HandlingState.hs
+++ b/essence-of-live-coding/src/LiveCoding/HandlingState.hs
@@ -50,8 +50,6 @@ import Control.Monad.Trans.State.Strict (StateT (StateT), runStateT, evalStateT,
 import Control.Monad.Morph (hoist, MFunctor)
 import Control.Monad.Trans.Has
 
-import LiveCoding.HandlingState.AccumTOrphan
-
 data Handling h = Handling
   { key :: Key
   , handle :: h

From 2beeca16c2437ee0e9aafd29b896dd5607195ddb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Fri, 24 Mar 2023 11:14:39 +0100
Subject: [PATCH 10/11] WIP ideas for correct garbage collection

---
 .../src/LiveCoding/HandlingState.hs              | 16 ++++++++++++++++
 1 file changed, 16 insertions(+)

diff --git a/essence-of-live-coding/src/LiveCoding/HandlingState.hs b/essence-of-live-coding/src/LiveCoding/HandlingState.hs
index da0153fd..c9a9bc25 100644
--- a/essence-of-live-coding/src/LiveCoding/HandlingState.hs
+++ b/essence-of-live-coding/src/LiveCoding/HandlingState.hs
@@ -263,6 +263,22 @@ garbageCollected actionHS = do
   liftH $ put HandlingState { destructors = registeredConstructors, registered = [] }
   return a
 
+garbageCollected' action = do
+  unregisterAll
+  a <- action
+  collectGarbage
+  return a
+
+unregisterAll :: HandlingStateStateT m ()
+unregisterAll = modify $ \handlingState -> handlingState { registered = [] }
+
+collectGarbage :: HandlingStateStateT m ()
+collectGarbage = do
+  HandlingState { .. } <- liftH get
+  let registeredKeys = IntSet.fromList registered
+      registeredConstructors = restrictKeys destructors registeredKeys
+      unregisteredConstructors = withoutKeys destructors registeredKeys
+  lift $ lift $ traverse_ action unregisteredConstructors
 
 data Destructor m = Destructor
   { isRegistered :: Bool -- TODO we don't need this anymore

From 957bfe7b1b4e2dca59ce9b57529214e777a48c5f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Manuel=20B=C3=A4renz?= <programming@manuelbaerenz.de>
Date: Tue, 11 Jul 2023 11:12:45 +0200
Subject: [PATCH 11/11] Add AccumTOrphan

---
 .../src/LiveCoding/HandlingState/AccumTOrphan.hs               | 3 +++
 1 file changed, 3 insertions(+)
 create mode 100644 essence-of-live-coding/src/LiveCoding/HandlingState/AccumTOrphan.hs

diff --git a/essence-of-live-coding/src/LiveCoding/HandlingState/AccumTOrphan.hs b/essence-of-live-coding/src/LiveCoding/HandlingState/AccumTOrphan.hs
new file mode 100644
index 00000000..07cd5207
--- /dev/null
+++ b/essence-of-live-coding/src/LiveCoding/HandlingState/AccumTOrphan.hs
@@ -0,0 +1,3 @@
+module LiveCoding.HandlingState.AccumTOrphan where
+
+