WIP accum & writer, but tests fail

essence-of-live-coding/essence-of-live-coding.cabal

@@ -77,11 +77,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

essence-of-live-coding/src/LiveCoding/HandlingState.hs

@@ -17,12 +17,17 @@ module LiveCoding.HandlingState where
 -- base
 import Control.Arrow (returnA, arr, (>>>))
 import Data.Data
+import Data.Foldable (traverse_)
+import Data.Functor (($>))
 
 -- transformers
 import Control.Monad.Trans.Class (MonadTrans(lift))
-import Control.Monad.Trans.State.Strict
-import Data.Foldable (traverse_)
-import Data.Functor (($>))
+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
@@ -42,8 +47,8 @@ import LiveCoding.Cell.Monad
 import LiveCoding.Cell.Monad.Trans
 import LiveCoding.LiveProgram
 import LiveCoding.LiveProgram.Monad.Trans
-import Control.Monad.Trans.Writer.Strict
-import Control.Monad.Trans.Accum
+import LiveCoding.HandlingState.AccumTOrphan
+import Control.Monad.IO.Class
 
 data Handling h where
   Handling
@@ -150,10 +155,17 @@ instance Monad m => Monad (MyHandlingStateT m) where
 --   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)
+  deriving (Functor, Applicative, Monad, MonadIO)
+
 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.
@@ -179,41 +191,48 @@ runHandlingStateC
      (Monad m, Typeable m)
   => Cell (HandlingStateT m) a b
   -> Cell                 m  a b
-runHandlingStateC cell = flip runStateC_ mempty
-  $ hoistCellOutput garbageCollected cell
+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 mempty LiveProgram
-  { liveStep = garbageCollected . liveStep
-  , ..
-  }
+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 action = _ $ listen action
+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 -- TODO we don't need this anymore
   , action       :: m ()
   }
 
-
 register
   :: (Monad m, Algebra sig m)
   => m () -- ^ Destructor
   -> HandlingStateT m Key
 register action = HandlingStateT $ do
   Registry { nHandles = key } <- look
   add $ Registry 1
-  lift $ tell HandlingState
+  tell HandlingState
     { destructors = singleton key Destructor { isRegistered = True, action }
     , registered = [key]
     }
@@ -224,7 +243,7 @@ reregister
   => m ()
   -> Key
   -> HandlingStateT m ()
-reregister action key = HandlingStateT $ lift $ tell HandlingState
+reregister action key = HandlingStateT $ tell HandlingState
   { destructors = singleton key Destructor { isRegistered = True, action }
   , registered = [key]
   }

essence-of-live-coding/test/Handle/LiveProgram.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns #-}
 module Handle.LiveProgram where
 
 -- base
@@ -13,6 +14,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
 
@@ -22,7 +26,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 = Handle
@@ -36,8 +42,8 @@ testHandle = Handle
 
 test = testGroup "Handle.LiveProgram"
   [ testProperty "Trigger destructors in live program" LiveProgramMigration
-    { liveProgram1 = runHandlingState $ liveCell
-        $ handling testHandle >>> arrM (lift . tell . return) >>> constM inspectHandlingState
+    { liveProgram1 = runHandlingState $ liveCell $ hoistCell inspectingHandlingState
+        $ handling testHandle >>> arrM (lift . tell . return)
     , liveProgram2 = runHandlingState mempty
     , input1 = replicate 3 ()
     , input2 = replicate 3 ()
@@ -48,9 +54,11 @@ test = testGroup "Handle.LiveProgram"
     }
   ]
     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