essence-of-live-coding 0.2.5 → 0.2.6

raw patch · 26 files changed

+671/−265 lines, 26 filesdep +HUnitdep +mmorphdep +test-framework-hunitPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: HUnit, mmorph, test-framework-hunit

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• essence-of-live-coding.cabal +9/−3
• src/LiveCoding.hs +9/−0
• src/LiveCoding/Bind.lhs +1/−1
• src/LiveCoding/Cell/NonBlocking.hs +1/−0
• src/LiveCoding/Cell/Resample.hs +1/−1
• src/LiveCoding/Cell/Util.hs +81/−6
• src/LiveCoding/Cell/Util/Internal.hs +7/−0
• src/LiveCoding/CellExcept.lhs +33/−15
• src/LiveCoding/Exceptions.lhs +10/−0
• src/LiveCoding/Exceptions/Finite.lhs +24/−0
• src/LiveCoding/Forever.lhs +5/−4
• src/LiveCoding/GHCi.hs +20/−11
• src/LiveCoding/Handle.hs +93/−186
• src/LiveCoding/HandlingState.hs +181/−0
• src/LiveCoding/LiveProgram/Except.hs +8/−4
• src/LiveCoding/Preliminary/CellExcept.lhs +5/−5
• src/LiveCoding/Preliminary/CellExcept/Applicative.lhs +3/−3
• src/LiveCoding/Preliminary/CellExcept/Monad.lhs +5/−5
• src/LiveCoding/Preliminary/CellExcept/Newtype.lhs +6/−6
• src/LiveCoding/RuntimeIO/Launch.hs +6/−4
• test/Cell/Util.hs +21/−0
• test/Handle.hs +91/−7
• test/Handle/LiveProgram.hs +7/−4
• test/Main.hs +2/−0
• test/RuntimeIO/Launch.hs +37/−0

@@ -1,5 +1,10 @@ # Revision history for essence-of-live-coding +## 0.2.6++* Add `changes`+* Add support for GHC 9.0.2+ ## 0.2.5  * Refactored GHCi support

@@ -1,5 +1,5 @@ name:                essence-of-live-coding-version:             0.2.5+version:             0.2.6 synopsis: General purpose live coding framework description:   essence-of-live-coding is a general purpose and type safe live coding framework.@@ -30,7 +30,7 @@ source-repository this   type:     git   location: git@github.com:turion/essence-of-live-coding.git-  tag:      v0.2.5+  tag:      v0.2.6   library@@ -56,6 +56,7 @@     , LiveCoding.GHCi     , LiveCoding.Handle     , LiveCoding.Handle.Examples+    , LiveCoding.HandlingState     , LiveCoding.LiveProgram     , LiveCoding.LiveProgram.Except     , LiveCoding.LiveProgram.HotCodeSwap@@ -69,7 +70,8 @@     , LiveCoding.RuntimeIO.Launch    other-modules:-      LiveCoding.Preliminary.CellExcept+      LiveCoding.Cell.Util.Internal+    , LiveCoding.Preliminary.CellExcept     , LiveCoding.Preliminary.CellExcept.Applicative     , LiveCoding.Preliminary.CellExcept.Monad     , LiveCoding.Preliminary.CellExcept.Newtype@@ -86,6 +88,7 @@     , vector-sized >= 1.2     , foreign-store >= 0.2     , time >= 1.9+    , mmorph >= 1.1   hs-source-dirs:      src   default-language:    Haskell2010   default-extensions: StrictData@@ -102,6 +105,7 @@     , Handle.LiveProgram     , Monad     , Monad.Trans+    , RuntimeIO.Launch     , TestData.Foo1     , TestData.Foo2     , Util@@ -117,6 +121,8 @@     , test-framework >= 0.8     , test-framework-quickcheck2 >= 0.3     , QuickCheck >= 2.12+    , test-framework-hunit >= 0.3+    , HUnit >= 1.3   default-language:    Haskell2010  executable TestExceptions

@@ -24,6 +24,15 @@ import LiveCoding.Exceptions.Finite as X import LiveCoding.Forever as X import LiveCoding.Handle as X+import LiveCoding.HandlingState as X+    ( HandlingStateT,+      HandlingState(..),+      Handling(..),+      isRegistered,+      runHandlingStateT,+      runHandlingStateC,+      runHandlingState,+    ) import LiveCoding.Handle.Examples as X import LiveCoding.LiveProgram as X import LiveCoding.LiveProgram.HotCodeSwap as X

@@ -52,7 +52,7 @@  \begin{code} sineWait-  :: Double -> CellExcept IO () String Void+  :: Double -> CellExcept () String IO Void sineWait t = do   try $ arr (const "Waiting...") >>> wait 2   safe $ sine t >>> arr asciiArt

@@ -15,6 +15,7 @@ import LiveCoding.Cell import LiveCoding.Handle import LiveCoding.Handle.Examples+import LiveCoding.HandlingState  threadVarHandle :: Handle IO (MVar ThreadId) threadVarHandle = Handle

@@ -28,7 +28,7 @@  -- | Execute the cell for as many steps as the input list is long. resampleList :: Monad m => Cell m a b -> Cell m [a] [b]-resampleList cell = hoistCellKleisli morph cell+resampleList = hoistCellKleisli morph   where     morph _ s [] = return ([], s)     morph singleStep s (a : as) = do

@@ -1,11 +1,14 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} module LiveCoding.Cell.Util where  -- base import Control.Arrow+import Control.Monad (join, guard) import Control.Monad.IO.Class import Data.Data (Data)+import Data.Foldable (toList) import Data.Functor (void) import Data.Maybe @@ -19,6 +22,8 @@ -- essence-of-live-coding import LiveCoding.Cell import LiveCoding.Cell.Feedback+import LiveCoding.Cell.Resample (resampleMaybe)+import LiveCoding.Cell.Util.Internal  -- * State accumulation @@ -46,23 +51,47 @@     cellStep b a = let b' = step a b in return (b', b')  -- | Initialise with a value 'a'.---   If the input is 'Nothing', @keep a@ will output the stored indefinitely.+--   If the input is 'Nothing', @'hold' a@ will output the stored indefinitely. --   A new value can be stored by inputting @'Just' a@.-keep :: (Data a, Monad m) => a -> Cell m (Maybe a) a-keep a = feedback a $ proc (ma, aOld) -> do+hold :: (Data a, Monad m) => a -> Cell m (Maybe a) a+hold a = feedback a $ proc (ma, aOld) -> do   let aNew = fromMaybe aOld ma   returnA -< (aNew, aNew) --- | Like 'keep', but returns 'Nothing' until it is initialised by a @'Just' a@ value.-keepJust+-- | Outputs @'Just' a@ whenever the the value a changes and 'Nothing' otherwise.+--  The first output is always 'Nothing'. The following holds:+--+--  @+--    delay a >>> changes >>> hold a == delay a+--  @+changes+  :: (Data a, Eq a, Monad m) +  => Cell m a (Maybe a)+changes = proc a -> do+  aLast <- delay Nothing -< Just a+  returnA -< do+      aLast' <- aLast+      guard $ a /= aLast'+      return a++-- | Like 'hold', but returns 'Nothing' until it is initialised by a @'Just' a@ value.+holdJust   :: (Monad m, Data a)   => Cell m (Maybe a) (Maybe a)-keepJust = feedback Nothing $ arr keep+holdJust = feedback Nothing $ arr keep   where     keep (Nothing, Nothing) = (Nothing, Nothing)     keep (_, Just a) = (Just a, Just a)     keep (Just a, Nothing) = (Just a, Just a) +-- | Hold the first value and output it indefinitely.+holdFirst :: (Data a, Monad m) => Cell m a a+holdFirst = Cell { .. }+  where+    cellState = Nothing+    cellStep Nothing x = return (x, Just x)+    cellStep (Just s) _ = return (s, Just s)+ -- | @boundedFIFO n@ keeps the first @n@ present values. boundedFIFO :: (Data a, Monad m) => Int -> Cell m (Maybe a) (Seq a) boundedFIFO n = foldC' step empty@@ -70,6 +99,24 @@     step Nothing  as = as     step (Just a) as = Sequence.take n $ a <| as +-- | Buffers and returns the elements in First-In-First-Out order,+--   returning 'Nothing' whenever the buffer is empty.+fifo :: (Monad m, Data a) => Cell m (Seq a) (Maybe a)+fifo = feedback empty $ proc (as, accum) -> do+  let accum' = accum >< as+  returnA -< case accum' of+    Empty    -> (Nothing, empty)+    a :<| as -> (Just a , as)++-- | Like 'fifo', but accepts lists as input.+--   Each step is O(n) in the length of the list.+fifoList :: (Monad m, Data a) => Cell m [a] (Maybe a)+fifoList = arr fromList >>> fifo++-- | Like 'fifoList', but generalised to any 'Foldable'.+fifoFoldable :: (Monad m, Data a, Foldable f) => Cell m (f a) (Maybe a)+fifoFoldable = arr toList >>> fifoList+ -- | Returns 'True' iff the current input value is 'True' and the last input value was 'False'. edge :: Monad m => Cell m Bool Bool edge = proc b -> do@@ -142,3 +189,31 @@   aMaybe' <- buffer -< maybePop ticked ++ maybePush aMaybe   bMaybe' <- cell   -< aMaybe'   returnA           -< (bMaybe', void bMaybe')++-- * Detecting change++{- | Perform an action whenever the parameter @p@ changes, and the code is reloaded.++Note that this does not trigger any actions when adding, or removing an 'onChange' cell.+For this functionality, see "LiveCoding.Handle".+Also, when moving such a cell, the action may not be triggered reliably.+-}+onChange+  :: (Monad m, Data p, Eq p)+  => p -- ^ This parameter has to change during live coding to trigger an action+  -> (p -> p -> a -> m b) -- ^ This action gets passed the old parameter and the new parameter+  -> Cell m a (Maybe b)+onChange p action = proc a -> do+  pCurrent <- arr $ const p -< ()+  pPrevious <- delay p -< pCurrent+  arrM $ whenDifferent action -< (pCurrent, pPrevious, a)++-- | Like 'onChange'', but with a dynamic input.+onChange'+  :: (Monad m, Data p, Eq p)+  => (p -> p -> a -> m b) -- ^ This action gets passed the old parameter and the new parameter+  -> Cell m (p, a) (Maybe b)+onChange' action = proc (pCurrent, a) -> do+  pPrevious <- delay Nothing -< Just pCurrent+  bMaybeMaybe <- resampleMaybe $ arrM $ whenDifferent action -< ( , pCurrent, a) <$> pPrevious+  returnA -< join bMaybeMaybe

@@ -0,0 +1,7 @@+module LiveCoding.Cell.Util.Internal where++-- | Helper for 'onChange'.+whenDifferent :: (Eq p, Monad m) => (p -> p -> a -> m b) -> (p, p, a) -> m (Maybe b)+whenDifferent action (pOld, pNew, a)+  | pOld == pNew = Just <$> action pOld pNew a+  | otherwise    = return Nothing

@@ -12,7 +12,10 @@ -- transformers import Control.Monad.Trans.Except --- essenceoflivecoding+-- mmorph+import Control.Monad.Morph++-- essence-of-live-coding import LiveCoding.Cell import LiveCoding.Exceptions import LiveCoding.Exceptions.Finite@@ -23,39 +26,46 @@ \fxerror{Cite operational} \fxerror{Move the following code into appendix?} \begin{code}-data CellExcept m a b e where-  Return :: e -> CellExcept m a b e+data CellExcept a b m e where+  Return :: e -> CellExcept a b m e   Bind-    :: CellExcept m a b e1-    -> (e1 -> CellExcept m a b e2)-    -> CellExcept m a b e2+    :: CellExcept a b m e1+    -> (e1 -> CellExcept a b m e2)+    -> CellExcept a b m e2   Try     :: (Data e, Finite e)     => Cell (ExceptT e m) a b-    -> CellExcept m a b e+    -> CellExcept a b m e \end{code}  \begin{comment} \begin{code}-instance Monad m => Functor (CellExcept m a b) where+instance Monad m => Functor (CellExcept a b m) where   fmap = liftM -instance Monad m => Applicative (CellExcept m a b) where+instance Monad m => Applicative (CellExcept a b m) where   pure = return   (<*>) = ap++instance MFunctor (CellExcept a b) where+  hoist morphism (Return e) = Return e+  hoist morphism (Bind action cont) = Bind+    (hoist morphism action)+    (hoist morphism . cont)+  hoist morphism (Try cell) = Try $ hoistCell (mapExceptT morphism) cell \end{code} \end{comment} The \mintinline{haskell}{Monad} instance is now trivial: \begin{code}-instance Monad m => Monad (CellExcept m a b) where+instance Monad m => Monad (CellExcept a b m) where   return = Return   (>>=) = Bind \end{code} As is typical for operational monads, all of the effort now goes into the interpretation function: \begin{code} runCellExcept-  :: Monad           m-  => CellExcept      m  a b e+  :: Monad m+  => CellExcept a b m e   -> Cell (ExceptT e m) a b \end{code} \begin{spec}@@ -79,7 +89,7 @@ try   :: (Data e, Finite e)   => Cell (ExceptT e m) a b-  -> CellExcept m a b e+  -> CellExcept a b m e try = Try \end{code} In practice however, this is less often a limitation than first assumed,@@ -92,7 +102,7 @@ \begin{code} safely   :: Monad      m-  => CellExcept m a b Void+  => CellExcept a b m Void   -> Cell       m a b safely = hoistCell discardVoid . runCellExcept discardVoid@@ -101,7 +111,15 @@   ->              m a discardVoid   = fmap (either absurd id) . runExceptT-safe :: Monad m => Cell m a b -> CellExcept m a b Void+safe :: Monad m => Cell m a b -> CellExcept a b m Void safe cell = try $ liftCell cell++-- | Run a monadic action and immediately raise its result as an exception.+once :: (Monad m, Data e, Finite e) => (a -> m e) -> CellExcept a arbitrary m e+once kleisli = try $ arrM $ ExceptT . (Left <$>) . kleisli++-- | Like 'once', but the action does not have an input.+once_ :: (Monad m, Data e, Finite e) => m e -> CellExcept a arbitrary m e+once_ = once . const \end{code} \end{comment}

@@ -64,6 +64,15 @@  throwIf_ :: Monad m => (a -> Bool) -> Cell (ExceptT () m) a a throwIf_ condition = throwIf condition ()++-- | When the incoming value is @'Right' a@, forward it.+--   When it is @'Left' e@, throw it as an exception.+--   Compare with 'except'.+exceptC :: Monad m => Cell (ExceptT e m) (Either e a) a+exceptC = proc ea -> do+  case ea of+    Left e -> throwC -< e+    Right a -> returnA -< a \end{code} \end{comment} @@ -111,6 +120,7 @@           -> cellStep (Exception e) a     cellStep (Exception e) _       = return (Left e, Exception e)+runExceptC cell = runExceptC $ toCell cell \end{code} \end{comment} 

@@ -25,6 +25,30 @@ import LiveCoding.Cell import LiveCoding.Cell.Monad.Trans -- import LiveCoding.CellExcept++{- | A type class for datatypes on which exception handling can branch statically.++These are exactly finite algebraic datatypes,+i.e. those defined from sums and products without recursion.+If you have a datatype with a 'Data' instance,+and there is no recursion in it,+then it is probably finite.++Let us assume your data type is:++@+data Foo = Bar | Baz { baz1 :: Bool, baz2 :: Maybe () }+@++To define the instance you need to add these two lines of boilerplate+(possibly you need to import "GHC.Generics" and enable some language extensions):++@+deriving instance Generic Foo+instance Finite Foo+@++-} \end{code} \end{comment} 

@@ -32,8 +32,8 @@ In other words, how do we repeatedly execute this action: \begin{code} sinesWaitAndTry-  :: MonadFix   m-  => CellExcept m () String ()+  :: MonadFix m+  => CellExcept () String m () sinesWaitAndTry = do   try $ arr (const "Waiting...") >>> wait 1   try $ sine 5 >>> arr asciiArt  >>> wait 5@@ -42,8 +42,8 @@ The one temptation we have to resist is to recurse in the \mintinline{haskell}{CellExcept} context to prove the absence of exceptions: \begin{code} sinesForever'-  :: MonadFix   m-  => CellExcept m () String Void+  :: MonadFix m+  => CellExcept () String m Void sinesForever' = do   sinesWaitAndTry   sinesForever'@@ -84,6 +84,7 @@       case continueExcept of         Left e' -> cellStep f { lastException = e', currentState = initState } a         Right (b, state') -> return (b, f { currentState = state' })+foreverE e cell = foreverE e $ toCell cell \end{code} \end{comment} Again, it is instructive to look at the internal state of the looped cell:

@@ -14,8 +14,8 @@  -- base import Control.Concurrent-import Control.Exception (SomeException, try)-import Control.Monad (void, (>=>))+import Control.Exception (SomeException, try, Exception (toException, displayException))+import Control.Monad (void, (>=>), join) import Data.Data import Data.Function ((&)) @@ -32,6 +32,12 @@ proxyFromLiveProgram :: LiveProgram m -> Proxy m proxyFromLiveProgram _ = Proxy +-- | An exception type marking the absence of a foreign store of the correct type.+data NoStore = NoStore+  deriving Show++instance Exception NoStore+ -- * Retrieving launched programs from the foreign store  -- | Try to retrieve a 'LiveProgram' of a given type from the 'Store',@@ -40,12 +46,10 @@ possiblyLaunchedProgram   :: Launchable m   => Proxy m-  -> IO (Either SomeException (Maybe (LaunchedProgram m)))+  -> IO (Either SomeException (LaunchedProgram m)) possiblyLaunchedProgram _ = do   storeMaybe <- lookupStore 0-  try $ traverse readStore storeMaybe--+  fmap join $ try $ traverse readStore $ maybe (Left $ toException NoStore) Right storeMaybe  -- | Try to load a 'LiveProgram' of a given type from the 'Store'. --   If the store doesn't contain a program, it is (re)started.@@ -54,11 +58,14 @@   launchedProgramPossibly <- possiblyLaunchedProgram $ proxyFromLiveProgram program   case launchedProgramPossibly of     -- Looking up the store failed in some way, restart-    Left (e :: SomeException) -> putStrLn "exc" >> launchAndSave program-    -- The store was empty, restart-    Right Nothing -> putStrLn "empty" >> launchAndSave program+    Left (e :: SomeException) -> do+      putStrLn $ displayException e+      launchAndSave program+     -- A program is running, update it-    Right (Just launchedProgram) -> putStrLn "update" >> update launchedProgram program+    Right launchedProgram -> do+      putStrLn "update"+      update launchedProgram program  -- | Launch a 'LiveProgram' and save it in the 'Store'. launchAndSave :: Launchable m => LiveProgram m -> IO ()@@ -74,7 +81,9 @@   :: Launchable m   => Proxy m   -> IO ()-stopStored proxy = void $ (fmap $ fmap $ fmap stop) $ possiblyLaunchedProgram proxy+stopStored proxy = do+  launchedProgramPossibly <- possiblyLaunchedProgram proxy+  either (putStrLn . displayException) stop launchedProgramPossibly  -- * GHCi commands 

@@ -1,47 +1,31 @@ {-# LANGUAGE Arrows #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -module LiveCoding.Handle-  ( Handle (..)-  , handling-  , HandlingState (..)-  , HandlingStateT-  , isRegistered-  , runHandlingState-  , runHandlingStateC-  , runHandlingStateT-  )-  where+module LiveCoding.Handle where  -- base-import Control.Arrow (returnA, arr, (>>>))+import Control.Arrow (arr, (>>>)) import Data.Data --- containers-import Data.IntMap-import qualified Data.IntMap as IntMap- -- transformers import Control.Monad.Trans.Class (MonadTrans(lift))-import Control.Monad.Trans.State.Strict +-- mmorph+import Control.Monad.Morph+ -- essence-of-live-coding import LiveCoding.Cell-import LiveCoding.Cell.Monad-import LiveCoding.Cell.Monad.Trans-import LiveCoding.LiveProgram-import LiveCoding.LiveProgram.Monad.Trans+import LiveCoding.HandlingState  {- | Container for unserialisable values, such as 'IORef's, threads, 'MVar's, pointers, and device handles. -In a 'Handle', you can store a mechanism to create and destroy a value that survives live coding even if does not have a 'Data' instance.+In a 'Handle', you can store a mechanism to create and destroy a value+that survives reloads occuring during live coding+even if does not have a 'Data' instance. Using the function 'handling', you can create a cell that will automatically initialise your value, and register it in the 'HandlingStateT' monad transformer,@@ -56,6 +40,12 @@   , destroy :: h -> m ()   } +instance MFunctor Handle where+  hoist morphism Handle { .. } = Handle+    { create = morphism create+    , destroy = morphism . destroy+    }+ {- | Combine two handles to one.  'Handle's are not quite 'Monoid's because of the extra type parameter,@@ -71,83 +61,6 @@   , destroy = \(h1, h2) -> destroy handle2 h2 *> destroy handle1 h1   } -data Handling h where-  Handling-    :: { id     :: Key-       , handle :: h-       }-    -> Handling h-  Uninitialized :: Handling h--type Destructors m = IntMap (Destructor m)---- | Hold a map of registered handle keys and destructors-data HandlingState m = HandlingState-  { nHandles    :: Key-  , destructors :: Destructors m-  }-  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--initHandlingState :: HandlingState m-initHandlingState = HandlingState-  { nHandles = 0-  , destructors = IntMap.empty-  }---- | 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--{- | Apply this to your main live cell before passing it to the runtime.--On the first tick, it initialises the 'HandlingState' at "no handles".--On every step, it does:--1. Unregister all handles-2. Register currently present handles-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---- | 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--data Destructor m = Destructor-  { isRegistered :: Bool-  , action       :: m ()-  }- {- | Hide a handle in a cell, taking care of initialisation and destruction. @@ -163,99 +76,93 @@ handling   :: ( Typeable h      , Monad m-    --  , MonadBase m m-    --  , MonadState (HandlingState m) n-    --  , MonadBase m n      )   => Handle m h   -> Cell (HandlingStateT m) arbitrary h-handling handleImpl@Handle { .. } = Cell-  { cellState = Uninitialized-  , cellStep = \state input -> case state of-      handling@Handling { .. } -> do-        reregister handleImpl handling-        return (handle, state)-      Uninitialized -> do-        handle <- lift create-        id <- register handleImpl handle-        return (handle, Handling { .. })-  }--register-  :: Monad m-  => Handle m h-  -> h-  -> HandlingStateT m Key-register handleImpl handle = do-  HandlingState { .. } <- get-  let id = nHandles + 1-  put HandlingState-    { nHandles = id-    , destructors = insertDestructor handleImpl id handle destructors-    }-  return id--reregister-  :: Monad m-  => Handle m h-  -> Handling h-  -> HandlingStateT m ()-reregister handleImpl Handling { .. } = do-  HandlingState { .. } <- get-  put HandlingState { destructors = insertDestructor handleImpl id handle destructors, .. }--insertDestructor-  :: Handle m h-  -> Key-  -> h-  -> Destructors m-  -> Destructors m-insertDestructor Handle { .. } id handle destructors =-  let destructor = Destructor { isRegistered = True, action = destroy handle }-  in  insert id destructor destructors--unregisterAll-  :: Monad m-  => HandlingStateT m ()-unregisterAll = do-  HandlingState { .. } <- get-  let newDestructors = IntMap.map (\destructor -> destructor { isRegistered = False }) destructors-  put HandlingState { destructors = newDestructors, .. }+handling handle = arr (const ()) >>> handlingParametrised (toParametrised handle) -destroyUnregistered-  :: Monad m-  => HandlingStateT m ()-destroyUnregistered = do-  HandlingState { .. } <- get-  let-      (registered, unregistered) = partition isRegistered destructors-  traverse (lift . action) unregistered-  put HandlingState { destructors = registered, .. }+{- | Generalisation of 'Handle' carrying an additional parameter which may change at runtime. --- * 'Data' instances+Like in a 'Handle', the @h@ value of a 'ParametrisedHandle' is preserved through live coding reloads.+Additionally, the parameter @p@ value can be adjusted,+and triggers a destruction and reinitialisation whenever it changes.+-}+data ParametrisedHandle p m h = ParametrisedHandle+  { createParametrised :: p -> m h+  , changeParametrised :: p -> p -> h -> m h+  , destroyParametrised :: p -> h -> m ()+  } -dataTypeHandling :: DataType-dataTypeHandling = mkDataType "Handling" [handlingConstr, uninitializedConstr]+instance MFunctor (ParametrisedHandle p) where+  hoist morphism ParametrisedHandle { .. } = ParametrisedHandle+    { createParametrised = morphism . createParametrised+    , changeParametrised = ((morphism .) .) . changeParametrised+    , destroyParametrised = (morphism .) . destroyParametrised+    } -handlingConstr :: Constr-handlingConstr = mkConstr dataTypeHandling "Handling" [] Prefix+-- | Given the methods 'createParametrised' and 'destroyParametrised',+--   build a fitting method for 'changeParametrised' which+defaultChange :: (Eq p, Monad m) => (p -> m h) -> (p -> h -> m ()) -> p -> p -> h -> m h+defaultChange creator destructor pOld pNew h+  | pOld == pNew = return h+  | otherwise    = do+      destructor pOld h+      creator pNew -uninitializedConstr :: Constr-uninitializedConstr = mkConstr dataTypeHandling "Uninitialized" [] Prefix+-- | Like 'combineHandles', but for 'ParametrisedHandle's.+combineParametrisedHandles+  :: Applicative m+  => ParametrisedHandle  p1      m  h1+  -> ParametrisedHandle      p2  m      h2+  -> ParametrisedHandle (p1, p2) m (h1, h2)+combineParametrisedHandles handle1 handle2 = ParametrisedHandle+  { createParametrised = \(p1, p2) -> ( , ) <$> createParametrised handle1 p1 <*> createParametrised handle2 p2+  , changeParametrised = \(pOld1, pOld2) (pNew1, pNew2) (h1, h2) -> ( , ) <$> changeParametrised handle1 pOld1 pNew1 h1 <*> changeParametrised handle2 pOld2 pNew2 h2+  , destroyParametrised = \(p1, p2) (h1, h2) -> destroyParametrised handle1 p1 h1 *> destroyParametrised handle2 p2 h2+  } -instance (Typeable h) => Data (Handling h) where-  dataTypeOf _ = dataTypeHandling-  toConstr Handling { .. } = handlingConstr-  toConstr Uninitialized = uninitializedConstr-  gunfold _cons nil constructor = nil Uninitialized+{- | Hide a 'ParametrisedHandle' in a cell,+taking care of initialisation and destruction. -dataTypeDestructor :: DataType-dataTypeDestructor = mkDataType "Destructor" [ destructorConstr ]+Upon the first tick, directly after migration, and after each parameter change,+the 'create' method of the 'Handle' is called,+and the result stored.+This result is then not changed anymore until the cell is removed again, or the parameter changes.+A parameter change triggers the destructor immediately,+but if the cell is removed, the destructor will be called on the next tick. -destructorConstr :: Constr-destructorConstr = mkConstr dataTypeDestructor "Destructor" [] Prefix+Migrations will by default not inspect the interior of a 'handling' cell.+This means that parametrised handles are only migrated if they have exactly the same type.+-}+handlingParametrised+  :: ( Typeable h, Typeable p+     , Monad m+     , Eq p+     )+  => ParametrisedHandle p m h+  -> Cell (HandlingStateT m) p h+handlingParametrised handleImpl@ParametrisedHandle { .. } = Cell { .. }+  where+    cellState = Uninitialized+    cellStep Uninitialized parameter = do+      mereHandle <- lift $ createParametrised parameter+      let handle = (mereHandle, parameter)+      key <- register $ destroyParametrised parameter mereHandle+      return (mereHandle, Handling { handle = handle, .. })+    cellStep handling@Handling { handle = (mereHandle, lastParameter), .. } parameter+      | parameter == lastParameter = do+          reregister (destroyParametrised parameter mereHandle) key+          return (mereHandle, handling)+      | otherwise = do+          mereHandle <- lift $ changeParametrised lastParameter parameter mereHandle+          reregister (destroyParametrised parameter mereHandle) key+          return (mereHandle, Handling { handle = (mereHandle, parameter), .. }) -instance Typeable m => Data (Destructor m) where-  dataTypeOf _ = dataTypeDestructor-  toConstr Destructor { .. } = destructorConstr-  gunfold _ _ = error "Destructor.gunfold"+-- | Every 'Handle' is trivially a 'ParametrisedHandle'+--   when the parameter is the trivial type.+toParametrised :: Monad m => Handle m h -> ParametrisedHandle () m h+toParametrised Handle { .. } = ParametrisedHandle+  { createParametrised = const create+  , changeParametrised = const $ const return+  , destroyParametrised = const destroy+  }

@@ -0,0 +1,181 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}++module LiveCoding.HandlingState where++-- base+import Control.Arrow (returnA, arr, (>>>))+import Data.Data++-- transformers+import Control.Monad.Trans.Class (MonadTrans(lift))+import Control.Monad.Trans.State.Strict+import Data.Foldable (traverse_)++-- containers+import Data.IntMap+import qualified Data.IntMap as IntMap++-- essence-of-live-coding+import LiveCoding.Cell+import LiveCoding.Cell.Monad+import LiveCoding.Cell.Monad.Trans+import LiveCoding.LiveProgram+import LiveCoding.LiveProgram.Monad.Trans++data Handling h where+  Handling+    :: { key    :: Key+       , handle :: h+       }+    -> Handling h+  Uninitialized :: Handling h++type Destructors m = IntMap (Destructor m)++-- | Hold a map of registered handle keys and destructors+data HandlingState m = HandlingState+  { nHandles    :: Key+  , destructors :: Destructors m+  }+  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++initHandlingState :: HandlingState m+initHandlingState = HandlingState+  { nHandles = 0+  , destructors = IntMap.empty+  }++-- | 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++{- | Apply this to your main live cell before passing it to the runtime.++On the first tick, it initialises the 'HandlingState' at "no handles".++On every step, it does:++1. Unregister all handles+2. Register currently present handles+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++-- | 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++data Destructor m = Destructor+  { isRegistered :: Bool+  , action       :: m ()+  }+++register+  :: Monad m+  => m () -- ^ Destructor+  -> HandlingStateT m Key+register destructor = do+  HandlingState { .. } <- get+  let key = nHandles + 1+  put HandlingState+    { nHandles = key+    , destructors = insertDestructor destructor key destructors+    }+  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, .. }++destroyUnregistered+  :: Monad m+  => HandlingStateT m ()+destroyUnregistered = do+  HandlingState { .. } <- get+  let+      (registered, unregistered) = partition isRegistered destructors+  traverse_ (lift . action) unregistered+  put HandlingState { destructors = registered, .. }++-- * 'Data' instances++dataTypeHandling :: DataType+dataTypeHandling = mkDataType "Handling" [handlingConstr, uninitializedConstr]++handlingConstr :: Constr+handlingConstr = mkConstr dataTypeHandling "Handling" [] Prefix++uninitializedConstr :: Constr+uninitializedConstr = mkConstr dataTypeHandling "Uninitialized" [] Prefix++instance (Typeable h) => Data (Handling h) where+  dataTypeOf _ = dataTypeHandling+  toConstr Handling { .. } = handlingConstr+  toConstr Uninitialized = uninitializedConstr+  gunfold _cons nil constructor = nil Uninitialized++dataTypeDestructor :: DataType+dataTypeDestructor = mkDataType "Destructor" [ destructorConstr ]++destructorConstr :: Constr+destructorConstr = mkConstr dataTypeDestructor "Destructor" [] Prefix++instance Typeable m => Data (Destructor m) where+  dataTypeOf _ = dataTypeDestructor+  toConstr Destructor { .. } = destructorConstr+  gunfold _ _ = error "Destructor.gunfold"

@@ -10,19 +10,19 @@ -- base import Control.Monad (liftM, ap) import Data.Data+import Data.Void (Void)  -- transformers import Control.Monad.Trans.Except import Control.Monad.Trans.Reader  -- essence-of-live-coding-import LiveCoding.Cell (hoistCell, toLiveCell, liveCell)-import LiveCoding.CellExcept (CellExcept, runCellExcept)+import LiveCoding.Cell (hoistCell, toLiveCell, liveCell, constM)+import LiveCoding.CellExcept (CellExcept, runCellExcept, once_) import LiveCoding.Exceptions.Finite (Finite) import LiveCoding.Forever import LiveCoding.LiveProgram import qualified LiveCoding.CellExcept as CellExcept-import Data.Void (Void)  {- | A live program that can throw an exception. @@ -39,7 +39,7 @@ and it is in fact a newtype around it. -} newtype LiveProgramExcept m e = LiveProgramExcept-  { unLiveProgramExcept :: CellExcept m () () e }+  { unLiveProgramExcept :: CellExcept () () m e }   deriving (Functor, Applicative, Monad)  -- | Execute a 'LiveProgramExcept', throwing its exceptions in the 'ExceptT' monad.@@ -81,6 +81,10 @@   => LiveProgram m   -> LiveProgramExcept m Void safe = LiveProgramExcept . CellExcept.safe . toLiveCell++-- | Run a monadic action and immediately raise its result as an exception.+once :: (Monad m, Data e, Finite e) => m e -> LiveProgramExcept m e+once = LiveProgramExcept . once_  {- | Run a 'LiveProgramExcept' in a loop. 

@@ -32,7 +32,7 @@ try   :: Data          e   => Cell (ExceptT e m) a b-  -> CellExcept      m  a b e+  -> CellExcept         a b m e try = CellExcept id \end{code} And we can leave it safely once we have proven that there are no exceptions left to throw,@@ -41,7 +41,7 @@ \begin{code} safely   :: Monad      m-  => CellExcept m a b Void+  => CellExcept a b m Void   -> Cell       m a b safely = hoistCell discardVoid . runCellExcept @@ -55,7 +55,7 @@ One way to prove the absence of further exceptions is, of course, to run an exception-free cell: \begin{code}-safe :: Monad m => Cell m a b -> CellExcept m a b void+safe :: Monad m => Cell m a b -> CellExcept a b m void safe cell = CellExcept   { fmapExcept = absurd   , cellExcept = liftCell cell@@ -65,8 +65,8 @@ this is also possible: \begin{code} runCellExcept-  :: Monad           m-  => CellExcept      m  a b e+  :: Monad          m+  => CellExcept a b m e   -> Cell (ExceptT e m) a b runCellExcept CellExcept { .. }   = hoistCell (withExceptT fmapExcept)

@@ -64,7 +64,7 @@ \fxwarning{Maybe cite http://comonad.com/reader/2016/adjoint-triples/ or search something else} \fxwarning{Possible other names: Mode} \begin{code}-data CellExcept m a b e = forall e' .+data CellExcept a b m e = forall e' .   Data e' => CellExcept   { fmapExcept :: e' -> e   , cellExcept :: Cell (ExceptT e' m) a b@@ -75,7 +75,7 @@  It is known that this construction gives rise to a \mintinline{haskell}{Functor} instance for free: \begin{code}-instance Functor (CellExcept m a b) where+instance Functor (CellExcept a b m) where   fmap f CellExcept { .. } = CellExcept     { fmapExcept = f . fmapExcept     , ..@@ -87,7 +87,7 @@ while sequential application is a bookkeeping exercise around the previously defined function \mintinline{haskell}{andThen}: \begin{code} instance Monad m-  => Applicative (CellExcept m a b) where+  => Applicative (CellExcept a b m) where   pure e = CellExcept     { fmapExcept = const e     , cellExcept = constM $ throwE ()

@@ -47,9 +47,9 @@ {- bindBool'   :: (Monad m, Data e, Finite e)-  => CellExcept m a b Bool-  -> (Bool -> CellExcept m a b e)-  -> CellExcept m a b e+  => CellExcept a b m Bool+  -> (Bool -> CellExcept a b m e)+  -> CellExcept a b m e bindBool' cellE handler = CellExcept   { fmapExcept = id   , cellExcept = runCellExcept cellE `bindBool` (runCellExcept . handler)@@ -69,7 +69,7 @@ but if it is possible to bind \mintinline{haskell}{Bool}, then it is certainly possible to bind \mintinline{haskell}{(Bool, Bool)}, by nesting two \mintinline{haskell}{if}-statements.-By the same logic, we can bind \mintinline{haskell}{(Bool, Bool, Bool)} %, +By the same logic, we can bind \mintinline{haskell}{(Bool, Bool, Bool)} %, %\mintinline{haskell}{(Bool, Bool, Bool, Bool)}, and so on (and of course any isomorphic type as well).@@ -106,7 +106,7 @@  It is possible to restrict the previous \mintinline{haskell}{CellExcept} definition by the typeclass: \begin{spec}-data CellExcept m a b e = forall e' .+data CellExcept a b m e = forall e' .   (Data e', Finite e') => CellExcept   { fmapExcept :: e' -> e   , cellExcept :: Cell (ExceptT e' m) a b

@@ -24,7 +24,7 @@ we introduce a newtype:  \begin{code}-newtype CellExcept m a b e = CellExcept+newtype CellExcept a b m e = CellExcept   { runCellExcept :: Cell (ExceptT e m) a b } \end{code} @@ -33,7 +33,7 @@ \begin{code} try   :: Cell (ExceptT e m) a b-  -> CellExcept      m  a b e+  -> CellExcept a b m e try = CellExcept \end{code} And we can leave it safely once we have proven that there are no exceptions left to throw,@@ -41,7 +41,7 @@ \begin{code} safely   :: Monad      m-  => CellExcept m a b Void+  => CellExcept a b m Void   -> Cell       m a b \end{code} \begin{comment}@@ -58,7 +58,7 @@ safe   :: Monad      m   => Cell       m a b-  -> CellExcept m a b Void+  -> CellExcept a b m Void \end{code} \begin{comment} \begin{code}@@ -75,7 +75,7 @@ we simply apply a given function to it: \begin{code} instance Functor m-  => Functor (CellExcept m a b) where+  => Functor (CellExcept a b m) where   fmap f (CellExcept cell) = CellExcept     $ hoistCell (withExceptT f) cell \end{code}@@ -88,7 +88,7 @@ pure   :: Monad      m   =>                  e-  -> CellExcept m a b e+  -> CellExcept a b m e pure e = CellExcept $ arr (const e) >>> throwC \end{code} 

@@ -22,6 +22,7 @@ import LiveCoding.LiveProgram.HotCodeSwap import LiveCoding.Cell.Monad.Trans import LiveCoding.Exceptions.Finite (Finite)+import LiveCoding.HandlingState  {- | Monads in which live programs can be launched in 'IO', for example when you have special effects that have to be handled on every reload.@@ -35,7 +36,7 @@ instance Launchable IO where   runIO = id -instance (Typeable m, Launchable m) => Launchable (StateT (HandlingState m) m) where+instance (Typeable m, Launchable m) => Launchable (HandlingStateT m) where   runIO = runIO . runHandlingState  -- | Upon an exception, the program is restarted.@@ -98,7 +99,8 @@ {- | Stops a thread where a 'LiveProgram' is being executed.  Before the thread is killed, an empty program (in the monad @m@) is first inserted and stepped.-This can be used to call cleanup actions encoded in the monad.+This can be used to call cleanup actions encoded in the monad,+such as 'HandlingStateT'. -} stop   :: Launchable m@@ -120,8 +122,8 @@ -- | This is the background task executed by 'launch'. background :: MVar (LiveProgram IO) -> IO () background var = forever $ do-  liveProg   <- takeMVar var-  liveProg'  <- stepProgram liveProg+  liveProg  <- takeMVar var+  liveProg' <- stepProgram liveProg   putMVar var liveProg'  -- | Advance a 'LiveProgram' by a single step.

@@ -88,4 +88,25 @@         $ counterexample labelString         $ catMaybes inputs === catMaybes outputs         .||. bufferNotEmpty+  , testProperty "delay a >>> changes >>> hold a == delay a"+    $ \(inputs :: [Int]) (startValue :: Int) -> fst (runIdentity $ steps (delay startValue) inputs) === +        fst (runIdentity $ steps (delay startValue >>> changes >>> hold startValue) inputs)+  , testProperty "changes applied to a cell that outputs a constant, always outputs Nothing"+    $ \(value :: Int) (inputs :: [Int]) -> [] === +        catMaybes (fst (runIdentity $ steps (arr (const value) >>> changes) inputs))+  , testProperty "changes works as expected" CellSimulation+    { cell = changes+    , input =+        [ 1 :: Int+        , 1 :: Int+        , 2 :: Int+        , 2 :: Int+        ]+    , output =+        [ Nothing+        , Nothing+        , Just (2 :: Int)+        , Nothing+        ]+    }               ]

@@ -1,6 +1,10 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-} module Handle where  -- base@@ -15,20 +19,18 @@ -- test-framework import Test.Framework --- test-framework-import Test.Framework- -- test-framework-quickcheck2 import Test.Framework.Providers.QuickCheck2 --- QuickCheck-import Test.QuickCheck- -- essence-of-live-coding import qualified Handle.LiveProgram import LiveCoding import Util+import GHC.Base (Symbol, Nat)+import GHC.TypeNats (natVal, KnownNat)+import GHC.Natural (naturalToInteger) +-- One day replace State Int with Writer [String] testHandle :: Handle (State Int) String testHandle = Handle   { create = do@@ -44,10 +46,49 @@   }  cellWithAction-  :: forall a b . (State Int b)+  :: forall a b . State Int b   -> Cell Identity a (String, Int) cellWithAction action = flip runStateC 0 $ runHandlingStateC $ handling testHandle >>> arrM (<$ lift action) +testParametrisedHandle :: ParametrisedHandle Bool (State Int) String+testParametrisedHandle = ParametrisedHandle { .. }+  where+    createParametrised flag = do+      n <- get+      let greeting = if flag then "Ye Olde Handle No " else "Crazy new hdl #"+      return $ greeting ++ show n+    destroyParametrised = const $ const $ put 12345+    changeParametrised = defaultChange createParametrised destroyParametrised++cellWithActionParametrized+  :: forall a b . State Int b+  -> Cell Identity Bool (String, Int)+cellWithActionParametrized action+  = flip runStateC 0+  $ runHandlingStateC+  $ handlingParametrised testParametrisedHandle >>> arrM (<$ lift action)++throwAfter2Steps :: Monad m => Cell (ExceptT () m) a Int+throwAfter2Steps = arr (const 1) >>> sumC >>> throwIf_ (> 1)++data Tag (tag :: Nat) = Tag+  deriving (Eq, Show)++testTypelevelHandle :: KnownNat tag => Handle (State Int) (Tag tag)+testTypelevelHandle = Handle+  { create = return Tag+  , destroy = put . fromInteger . naturalToInteger . natVal+  }++cellWithActionTypelevel+  :: KnownNat tag+  => State Int b+  -> Cell Identity a (Tag tag, Int)+cellWithActionTypelevel action+  = flip runStateC 0+  $ runHandlingStateC+  $ handling testTypelevelHandle >>> arrM (<$ lift action)+ test = testGroup "Handle"   [ testProperty "Preserve Handles" CellMigrationSimulation     { cell1 = cellWithAction $ modify (+ 1)@@ -102,6 +143,49 @@     , input2 = replicate 3 ()     , output1 = ("Handle #0", ) <$> replicate 3 0     , output2 = ("Done", ) <$> replicate 3 10000+    }+  , testProperty "Changing parameters triggers destructors" CellSimulation+    { cell = cellWithActionParametrized $ modify (+ 1)+    , input = [True, True, False, False]+    , output =+        [ ("Ye Olde Handle No 0", 1)+        , ("Ye Olde Handle No 0", 2)+        , ("Crazy new hdl #12345", 12346)+        , ("Crazy new hdl #12345", 12347)+        ]+    }+  , testProperty "Transient control flow does not trigger destructors or constructors" CellSimulation+    { cell = cellWithAction (modify (+ 1)) ||| arr (const ("Nope", 23))+    , input = [Right (), Left (), Left (), Right (), Left ()]+    , output =+        [ ("Nope", 23)+        , ("Handle #0", 1)+        , ("Handle #0", 2)+        , ("Nope", 23)+        , ("Handle #0", 3)+        ]+    }+  , testProperty "Permanent control flow does not trigger destructors or constructors" CellSimulation+    { cell = safely $ do+        void $ try $ throwAfter2Steps >>> arr (const ("Nope", 23))+        void $ try $ throwAfter2Steps >>> liftCell (cellWithAction (modify (+ 1)))+        safe $ arr $ const ("Nope", 23)+    , input = replicate 5 ()+    , output =+        [ ("Nope", 23)+        , ("Nope", 23)+        , ("Handle #0", 1)+        , ("Handle #0", 2)+        , ("Nope", 23)+        ]+    }+  , testProperty "Change of type level tags trigger destructors" CellMigrationSimulation+    { cell1 = (cellWithActionTypelevel @23000 $ modify (+ 1)) >>> arr snd+    , cell2 = (cellWithActionTypelevel @42000 $ modify (+ 2)) >>> arr snd+    , input1 = replicate 3 ()+    , input2 = replicate 3 ()+    , output1 = [1, 2, 3]+    , output2 = [23000, 23002, 23004]     }   , Handle.LiveProgram.test   ]

@@ -8,6 +8,7 @@ import qualified Data.IntMap as IntMap  -- transformers+import Control.Monad.Trans.Class (MonadTrans(lift)) import Control.Monad.Trans.RWS.Strict (RWS, tell) import qualified Control.Monad.Trans.RWS.Strict as RWS import Control.Monad.Trans.State.Strict@@ -22,13 +23,14 @@ import LiveCoding import LiveCoding.Handle import Util.LiveProgramMigration-import Control.Monad.Trans.Class (MonadTrans(lift))  testHandle :: Handle (RWS () [String] Int) String testHandle = Handle   { create = do       n <- RWS.get-      return $ "Handle #" ++ show n+      let msg = "Handle #" ++ show n+      tell ["Creating " ++ msg]+      return msg   , destroy = const $ tell ["Destroyed handle"]   } @@ -39,7 +41,8 @@     , liveProgram2 = runHandlingState mempty     , input1 = replicate 3 ()     , input2 = replicate 3 ()-    , output1 = replicate 3 ["Handle #0", "Handles: 1", "Destructors: (1,True)"]+    , 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     }@@ -49,5 +52,5 @@         HandlingState { .. } <- get         lift $ tell           [ "Handles: " ++ show nHandles-          , "Destructors: " ++ unwords ((show . second isRegistered) <$> IntMap.toList destructors)+          , "Destructors: " ++ unwords (show . second isRegistered <$> IntMap.toList destructors)           ]

@@ -22,6 +22,7 @@ import qualified Handle import qualified Monad import qualified Monad.Trans+import qualified RuntimeIO.Launch  import LiveCoding @@ -116,6 +117,7 @@     , Feedback.test     ]   , Monad.Trans.test+  , RuntimeIO.Launch.test   ]  countFrom :: Monad m => Int -> Cell m () Int

@@ -0,0 +1,37 @@+module RuntimeIO.Launch where++-- base+import Data.IORef++-- hunit+import Test.HUnit++-- test-framework-hunit+import Test.Framework.Providers.HUnit++-- essence-of-live-coding+import LiveCoding+import Control.Concurrent (threadDelay)++loggingHandle :: IORef [String] -> Handle IO ()+loggingHandle ref = Handle+  { create = modifyIORef ref ("Created handle" :)+  , destroy = const $ modifyIORef ref ("Destroyed handle" :)+  }++testProgram :: IORef [String] -> LiveProgram (HandlingStateT IO)+testProgram ref = liveCell $ handling $ loggingHandle ref++test = testCase "HandlingStateT destroys all handles" $ do+  ref <- newIORef []+  launchedProgram <- launch mempty+  assertRefContains ref []+  update launchedProgram $ testProgram ref+  assertRefContains ref ["Created handle"]+  stop launchedProgram+  assertRefContains ref ["Destroyed handle", "Created handle"]++assertRefContains ref messagesExpected = do+  threadDelay 100000+  messagesRead <- readIORef ref+  messagesRead @?= messagesExpected