essence-of-live-coding 0.2.6 → 0.2.7

raw patch · 43 files changed

+1547/−1108 lines, 43 filessetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +1/−1
• Setup.hs +1/−0
• app/TestExceptions.hs +2/−2
• app/TestNonBlocking.hs +18/−17
• essence-of-live-coding.cabal +6/−4
• src/LiveCoding.hs +12/−12
• src/LiveCoding/Cell/HotCodeSwap.hs +9/−9
• src/LiveCoding/Cell/Monad.hs +47/−39
• src/LiveCoding/Cell/Monad/Trans.hs +33/−31
• src/LiveCoding/Cell/NonBlocking.hs +40/−38
• src/LiveCoding/Cell/Resample.hs +21/−6
• src/LiveCoding/Cell/Util.hs +65/−54
• src/LiveCoding/Cell/Util/Internal.hs +1/−1
• src/LiveCoding/Debugger/StatePrint.hs +52/−46
• src/LiveCoding/External.hs +7/−7
• src/LiveCoding/GHCi.hs +40/−30
• src/LiveCoding/Handle.hs +60/−51
• src/LiveCoding/Handle/Examples.hs +26/−20
• src/LiveCoding/HandlingState.hs +89/−99
• src/LiveCoding/LiveProgram/Except.hs +37/−34
• src/LiveCoding/LiveProgram/Monad/Trans.hs +20/−16
• src/LiveCoding/Migrate/Cell.hs +56/−53
• src/LiveCoding/Migrate/Debugger.hs +13/−12
• src/LiveCoding/Migrate/Migration.hs +31/−27
• src/LiveCoding/Migrate/Monad/Trans.hs +16/−14
• src/LiveCoding/Migrate/NoMigration.hs +111/−0
• src/LiveCoding/Preliminary/CellExcept/Applicative.lhs +4/−0
• src/LiveCoding/RuntimeIO/Launch.hs +50/−45
• test/Cell.hs +16/−8
• test/Cell/Monad/Trans.hs +8/−5
• test/Cell/Util.hs +169/−86
• test/Feedback.hs +34/−26
• test/Handle.hs +172/−136
• test/Handle/LiveProgram.hs +36/−26
• test/Main.hs +99/−78
• test/Migrate/NoMigration.hs +50/−0
• test/Monad.hs +11/−8
• test/Monad/Trans.hs +12/−9
• test/RuntimeIO/Launch.hs +7/−5
• test/TestData/Foo1.hs +14/−12
• test/TestData/Foo2.hs +21/−18
• test/Util.hs +22/−17
• test/Util/LiveProgramMigration.hs +8/−6

@@ -1,6 +1,6 @@ # Revision history for essence-of-live-coding -## 0.2.6+## 0.2.7  * Add `changes` * Add support for GHC 9.0.2

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -9,8 +9,8 @@ -- essence-of-live-coding import LiveCoding -liveProgram = liveCell-  $ safely $ do+liveProgram = liveCell $+  safely $ do     try $ throwingCell     safe $ arr (const (3 :: Integer)) >>> sumC >>> arr (const ()) 

@@ -1,9 +1,9 @@ {-# LANGUAGE Arrows #-} -module Main-  ( module Main-  , module X-  ) where+module Main (+  module Main,+  module X,+) where  -- base import Control.Arrow@@ -27,20 +27,21 @@   putStrLn "Push return to start a slow calculation."   runHandlingStateT $ foreground $ liveCell mainCell --- | Constantly count the number of ticks passed since program start.---   Whenever the keyboard return key is pressed,---   this number is printed, and passed into a slow "computation" in a separate thread,---   while the foreground thread is not blocked.---   When the background thread returns, the number is printed again.+{- | Constantly count the number of ticks passed since program start.+   Whenever the keyboard return key is pressed,+   this number is printed, and passed into a slow "computation" in a separate thread,+   while the foreground thread is not blocked.+   When the background thread returns, the number is printed again.+-} mainCell :: Cell (HandlingStateT IO) () () mainCell =   let keyboard = nonBlocking False $ constM getLine -- Only poll, never abort       mySlowId = nonBlocking True slowId -- Abort and restart when new data arrives-  in proc _ -> do-    n <- count                             -< ()-    lineMaybe <- keyboard                  -< Just ()-    let nString = show n <$ lineMaybe-    resampleMaybe (arrM $ lift . putStrLn) -< ("Calculating " ++) <$> nString-    resultMaybe <- mySlowId                -< nString-    resampleMaybe (arrM $ lift . putStrLn) -< ("Calculated "  ++) <$> resultMaybe-    arrM $ lift .threadDelay               -< 1000 -- Don't hog CPU+   in proc _ -> do+        n <- count -< ()+        lineMaybe <- keyboard -< Just ()+        let nString = show n <$ lineMaybe+        resampleMaybe (arrM $ lift . putStrLn) -< ("Calculating " ++) <$> nString+        resultMaybe <- mySlowId -< nString+        resampleMaybe (arrM $ lift . putStrLn) -< ("Calculated " ++) <$> resultMaybe+        arrM $ lift . threadDelay -< 1000 -- Don't hog CPU

@@ -1,5 +1,5 @@ name:                essence-of-live-coding-version:             0.2.6+version:             0.2.7 synopsis: General purpose live coding framework description:   essence-of-live-coding is a general purpose and type safe live coding framework.@@ -25,12 +25,12 @@  source-repository head   type:     git-  location: git@github.com:turion/essence-of-live-coding.git+  location: https://github.com/turion/essence-of-live-coding.git  source-repository this   type:     git-  location: git@github.com:turion/essence-of-live-coding.git-  tag:      v0.2.6+  location: https://github.com/turion/essence-of-live-coding.git+  tag:      v0.2.7   library@@ -64,6 +64,7 @@     , LiveCoding.Migrate     , LiveCoding.Migrate.Cell     , LiveCoding.Migrate.Migration+    , LiveCoding.Migrate.NoMigration     , LiveCoding.Migrate.Monad.Trans     , LiveCoding.Migrate.Debugger     , LiveCoding.RuntimeIO@@ -98,6 +99,7 @@   main-is: Main.hs   other-modules:       Cell+    , Migrate.NoMigration     , Cell.Monad.Trans     , Cell.Util     , Feedback

@@ -1,6 +1,5 @@-module LiveCoding-  (module X)-  where+module LiveCoding (module X)+where  -- base import Control.Arrow as X hiding (app)@@ -24,21 +23,22 @@ 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.HandlingState as X (+  Handling (..),+  HandlingState (..),+  HandlingStateT,+  isRegistered,+  runHandlingState,+  runHandlingStateC,+  runHandlingStateT,+ ) import LiveCoding.LiveProgram as X import LiveCoding.LiveProgram.HotCodeSwap as X import LiveCoding.LiveProgram.Monad.Trans as X import LiveCoding.Migrate as X import LiveCoding.Migrate.Debugger as X import LiveCoding.Migrate.Migration as X+import LiveCoding.Migrate.NoMigration as X hiding (changes, delay) import LiveCoding.RuntimeIO as X hiding (update) import LiveCoding.RuntimeIO.Launch as X hiding (foreground)

@@ -4,14 +4,14 @@ import LiveCoding.Cell import LiveCoding.Migrate -hotCodeSwapCell-  :: Cell m a b-  -> Cell m a b-  -> Cell m a b+hotCodeSwapCell ::+  Cell m a b ->+  Cell m a b ->+  Cell m a b hotCodeSwapCell   (Cell newState newStep)-  (Cell oldState _)-  = Cell-  { cellState = migrate newState oldState-  , cellStep  = newStep-  }+  (Cell oldState _) =+    Cell+      { cellState = migrate newState oldState+      , cellStep = newStep+      }

@@ -1,58 +1,66 @@ {-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+ {- | Handling monad morphisms. -} module LiveCoding.Cell.Monad where  -- essence-of-live-coding-import LiveCoding.Cell-import Control.Arrow ((>>>), Arrow(arr))++import Control.Arrow (Arrow (arr), (>>>)) import Data.Data (Data)+import LiveCoding.Cell  -- | Apply a monad morphism that also transforms the output to a cell.-hoistCellOutput-  :: (Monad m1, Monad m2)-  => (forall s . m1 (b1, s) -> m2 (b2, s))-  -> Cell m1 a b1-  -> Cell m2 a b2+hoistCellOutput ::+  (Monad m1, Monad m2) =>+  (forall s. m1 (b1, s) -> m2 (b2, s)) ->+  Cell m1 a b1 ->+  Cell m2 a b2 hoistCellOutput morph = hoistCellKleisli_ (morph .)  -- | Apply a transformation of Kleisli morphisms to a cell.-hoistCellKleisli_-  :: (Monad m1, Monad m2)-  => (forall s . (a1 -> m1 (b1, s)) -> (a2 -> m2 (b2, s)))-  -> Cell m1 a1 b1-  -> Cell m2 a2 b2+hoistCellKleisli_ ::+  (Monad m1, Monad m2) =>+  (forall s. (a1 -> m1 (b1, s)) -> (a2 -> m2 (b2, s))) ->+  Cell m1 a1 b1 ->+  Cell m2 a2 b2 hoistCellKleisli_ morph = hoistCellKleisli (morph .)  -- | Apply a transformation of stateful Kleisli morphisms to a cell.-hoistCellKleisli-  :: (Monad m1, Monad m2)-  => (forall s . (s -> a1 -> m1 (b1, s)) -> (s -> a2 -> m2 (b2, s)))-  -> Cell m1 a1 b1-  -> Cell m2 a2 b2-hoistCellKleisli morph ArrM { .. } = ArrM-  { runArrM = (fmap fst .) $ ($ ()) $ morph $ const $ runArrM >>> fmap ( , ())-  }-hoistCellKleisli morph Cell { .. } = Cell-  { cellStep = morph cellStep-  , ..-  }+hoistCellKleisli ::+  (Monad m1, Monad m2) =>+  (forall s. (s -> a1 -> m1 (b1, s)) -> (s -> a2 -> m2 (b2, s))) ->+  Cell m1 a1 b1 ->+  Cell m2 a2 b2+hoistCellKleisli morph ArrM {..} =+  ArrM+    { runArrM = (fmap fst .) $ ($ ()) $ morph $ const $ runArrM >>> fmap (,())+    }+hoistCellKleisli morph Cell {..} =+  Cell+    { cellStep = morph cellStep+    , ..+    } --- | Apply a transformation of stateful Kleisli morphisms to a cell,---   changing the state type.-hoistCellKleisliStateChange-  :: (Monad m1, Monad m2, (forall s . Data s => Data (t s)))-  => (forall s . (  s -> a1 -> m1 (b1,   s))-              -> (t s -> a2 -> m2 (b2, t s)))-  -> (forall s . (s -> t s))-  -> Cell m1 a1 b1-  -> Cell m2 a2 b2-hoistCellKleisliStateChange morph init Cell { .. } = Cell-  { cellStep  = morph cellStep-  , cellState = init cellState-  }+{- | Apply a transformation of stateful Kleisli morphisms to a cell,+   changing the state type.+-}+hoistCellKleisliStateChange ::+  (Monad m1, Monad m2, (forall s. Data s => Data (t s))) =>+  ( forall s.+    (s -> a1 -> m1 (b1, s)) ->+    (t s -> a2 -> m2 (b2, t s))+  ) ->+  (forall s. (s -> t s)) ->+  Cell m1 a1 b1 ->+  Cell m2 a2 b2+hoistCellKleisliStateChange morph init Cell {..} =+  Cell+    { cellStep = morph cellStep+    , cellState = init cellState+    } hoistCellKleisliStateChange morph init cell = hoistCellKleisliStateChange morph init $ toCell cell

@@ -1,5 +1,6 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-}+ {- | Handling monad transformers. -}@@ -10,8 +11,8 @@ import Data.Data (Data)  -- transformers-import Control.Monad.Trans.Reader (runReaderT, ReaderT)-import Control.Monad.Trans.State.Strict (StateT (..), runStateT, evalStateT)+import Control.Monad.Trans.Reader (ReaderT, runReaderT)+import Control.Monad.Trans.State.Strict (StateT (..), evalStateT, runStateT) import Control.Monad.Trans.Writer.Strict  -- essence-of-live-coding@@ -19,29 +20,29 @@ import LiveCoding.Cell.Monad  -- | Push effectful state into the internal state of a cell-runStateC-  :: (Data stateT, Monad m)-  => Cell (StateT stateT m) a  b-  -- ^ A cell with a state effect-  -> stateT-  -- ^ The initial state-  -> Cell                m  a (b, stateT)-  -- ^ The cell, returning its current state+runStateC ::+  (Data stateT, Monad m) =>+  -- | A cell with a state effect+  Cell (StateT stateT m) a b ->+  -- | The initial state+  stateT ->+  -- | The cell, returning its current state+  Cell m a (b, stateT) runStateC cell stateT = hoistCellKleisliStateChange morph init cell   where-    morph step State { .. } a = do+    morph step State {..} a = do       ((b, stateInternal), stateT) <- runStateT (step stateInternal a) stateT-      return ((b, stateT), State { .. })-    init stateInternal = State { .. }+      return ((b, stateT), State {..})+    init stateInternal = State {..}  -- | Like 'runStateC', but does not return the current state.-runStateC_-  :: (Data stateT, Monad m)-  => Cell (StateT stateT m) a b-  -- ^ A cell with a state effect-  -> stateT-  -- ^ The initial state-  -> Cell                m  a b+runStateC_ ::+  (Data stateT, Monad m) =>+  -- | A cell with a state effect+  Cell (StateT stateT m) a b ->+  -- | The initial state+  stateT ->+  Cell m a b runStateC_ cell stateT = runStateC cell stateT >>> arr fst  -- | The internal state of a cell to which 'runStateC' or 'runStateL' has been applied.@@ -52,21 +53,22 @@   deriving (Data, Eq, Show)  -- | Supply a 'ReaderT' environment before running the cell-runReaderC-  ::               r-  -> Cell (ReaderT r m) a b-  -> Cell            m  a b+runReaderC ::+  r ->+  Cell (ReaderT r m) a b ->+  Cell m a b runReaderC r = hoistCell $ flip runReaderT r  -- | Supply a 'ReaderT' environment live-runReaderC'-  :: Monad m-  => Cell (ReaderT r m) a b-  -> Cell m (r, a) b+runReaderC' ::+  Monad m =>+  Cell (ReaderT r m) a b ->+  Cell m (r, a) b runReaderC' = hoistCellKleisli_ $ \action (r, a) -> runReaderT (action a) r --- | Run the effects of the 'WriterT' monad,---   collecting all its output in the second element of the tuple.+{- | Run the effects of the 'WriterT' monad,+   collecting all its output in the second element of the tuple.+-} runWriterC :: (Monoid w, Monad m) => Cell (WriterT w m) a b -> Cell m a (w, b) runWriterC = hoistCellOutput $ fmap reorder . runWriterT   where

@@ -1,14 +1,14 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RecordWildCards #-} -module LiveCoding.Cell.NonBlocking-  ( nonBlocking-  )-  where+module LiveCoding.Cell.NonBlocking (+  nonBlocking,+)+where  -- base import Control.Concurrent-import Control.Monad ((>=>), void, when)+import Control.Monad (void, when, (>=>)) import Data.Data  -- essence-of-live-coding@@ -18,10 +18,11 @@ import LiveCoding.HandlingState  threadVarHandle :: Handle IO (MVar ThreadId)-threadVarHandle = Handle-  { create = newEmptyMVar-  , destroy = tryTakeMVar >=> mapM_ killThread-  }+threadVarHandle =+  Handle+    { create = newEmptyMVar+    , destroy = tryTakeMVar >=> mapM_ killThread+    }  {- | Wrap a cell in a non-blocking way. Every incoming sample of @nonBlocking cell@ results in an immediate output,@@ -30,38 +31,39 @@ The resulting cell can be polled by sending 'Nothing'. The boolean flag controls whether the current computation is aborted and restarted when new data arrives. -}-nonBlocking-  :: Typeable b-  => Bool-  -- ^ Pass 'True' to abort the computation when new data arrives. 'False' discards new data.-  -> Cell IO a b-  -> Cell (HandlingStateT IO) (Maybe a) (Maybe b)-nonBlocking abort Cell { .. } = proc aMaybe -> do-  threadVar <- handling threadVarHandle            -< ()-  resultVar <- handling emptyMVarHandle            -< ()-  liftCell Cell { cellStep = nonBlockingStep, .. } -< (aMaybe, threadVar, resultVar)-    where-      nonBlockingStep s (Nothing, threadVar, resultVar) = do-        bsMaybe <- tryTakeMVar resultVar-        case bsMaybe of-          Just (b, s') -> do-            threadId <- takeMVar threadVar-            killThread threadId-            return (Just b, s')-          Nothing -> return (Nothing, s)-      nonBlockingStep s (Just a, threadVar, resultVar) = do-        noThreadRunning <- if abort-            -- Abort the current computation if it is still running-          then do+nonBlocking ::+  Typeable b =>+  -- | Pass 'True' to abort the computation when new data arrives. 'False' discards new data.+  Bool ->+  Cell IO a b ->+  Cell (HandlingStateT IO) (Maybe a) (Maybe b)+nonBlocking abort Cell {..} = proc aMaybe -> do+  threadVar <- handling threadVarHandle -< ()+  resultVar <- handling emptyMVarHandle -< ()+  liftCell Cell {cellStep = nonBlockingStep, ..} -< (aMaybe, threadVar, resultVar)+  where+    nonBlockingStep s (Nothing, threadVar, resultVar) = do+      bsMaybe <- tryTakeMVar resultVar+      case bsMaybe of+        Just (b, s') -> do+          threadId <- takeMVar threadVar+          killThread threadId+          return (Just b, s')+        Nothing -> return (Nothing, s)+    nonBlockingStep s (Just a, threadVar, resultVar) = do+      noThreadRunning <-+        if abort+          then -- Abort the current computation if it is still running+          do             maybeThreadId <- tryTakeMVar threadVar             mapM_ killThread maybeThreadId             return True-          -- No computation currently running-          else isEmptyMVar threadVar-        when noThreadRunning $ do-          threadId <- forkIO $ putMVar resultVar =<< cellStep s a-          putMVar threadVar threadId-        nonBlockingStep s (Nothing, threadVar, resultVar)+          else -- No computation currently running+            isEmptyMVar threadVar+      when noThreadRunning $ do+        threadId <- forkIO $ putMVar resultVar =<< cellStep s a+        putMVar threadVar threadId+      nonBlockingStep s (Nothing, threadVar, resultVar)  -- It would have been nice to refactor this with 'hoistCellKleisli', -- but that would expose the existential state type to the handle.

@@ -1,13 +1,13 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+ {- | Run a cell at a fixed integer multiple speed. The general approach is to take an existing cell (the "inner" cell) and produce a new cell (the "outer" cell) that will accept several copies of the input. The inner cell is stepped for each input. -}--{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-} module LiveCoding.Cell.Resample where  -- base@@ -16,7 +16,7 @@ import GHC.TypeNats  -- vector-sized-import Data.Vector.Sized+import Data.Vector.Sized (Vector, fromList, toList)  -- essence-of-live-coding import LiveCoding.Cell@@ -32,9 +32,24 @@   where     morph _ s [] = return ([], s)     morph singleStep s (a : as) = do-      (!b , s' ) <- singleStep s a+      (!b, s') <- singleStep s a       (!bs, s'') <- morph singleStep s' as       return (b : bs, s'')  resampleMaybe :: Monad m => Cell m a b -> Cell m (Maybe a) (Maybe b) resampleMaybe cell = arr maybeToList >>> resampleList cell >>> arr listToMaybe++{- | Create as many cells as the input list is long and execute them in parallel+ (in the sense that each one has a separate state). At each tick the list with+ the different states grows or shrinks depending on the size of the input list.++ Similar to Yampa's [parC](https://hackage.haskell.org/package/Yampa-0.13.3/docs/FRP-Yampa-Switches.html#v:parC).+-}+resampleListPar :: Monad m => Cell m a b -> Cell m [a] [b]+resampleListPar (Cell initial step) = Cell {..}+  where+    cellState = []+    cellStep s xs = unzip <$> traverse (uncurry step) (zip s' xs)+      where+        s' = s ++ replicate (length xs - length s) initial+resampleListPar (ArrM f) = ArrM (traverse f)

@@ -1,11 +1,12 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-}+ module LiveCoding.Cell.Util where  -- base import Control.Arrow-import Control.Monad (join, guard)+import Control.Monad (guard, join) import Control.Monad.IO.Class import Data.Data (Data) import Data.Foldable (toList)@@ -35,49 +36,53 @@ count :: Monad m => Cell m a Integer count = arr (const 1) >>> sumC --- | Accumulate all incoming data,---   using the given fold function and start value.---   For example, if @'foldC' f b@ receives inputs @a0@, @a1@,...---   it will output @b@, @f a0 b@, @f a1 $ f a0 b@, and so on.+{- | Accumulate all incoming data,+   using the given fold function and start value.+   For example, if @'foldC' f b@ receives inputs @a0@, @a1@,...+   it will output @b@, @f a0 b@, @f a1 $ f a0 b@, and so on.+-} foldC :: (Data b, Monad m) => (a -> b -> b) -> b -> Cell m a b-foldC step cellState = Cell { .. }+foldC step cellState = Cell {..}   where     cellStep b a = let b' = step a b in return (b, b')  -- | Like 'foldC', but does not delay the output. foldC' :: (Data b, Monad m) => (a -> b -> b) -> b -> Cell m a b-foldC' step cellState = Cell { .. }+foldC' step cellState = Cell {..}   where     cellStep b a = let b' = step a b in return (b', b') --- | Initialise with a value 'a'.---   If the input is 'Nothing', @'hold' a@ will output the stored indefinitely.---   A new value can be stored by inputting @'Just' a@.+{- | Initialise with a value 'a'.+   If the input is 'Nothing', @'hold' a@ will output the stored indefinitely.+   A new value can be stored by inputting @'Just' a@.+-} 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) --- | 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)+{- | 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+  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)+holdJust ::+  (Monad m, Data a) =>+  Cell m (Maybe a) (Maybe a) holdJust = feedback Nothing $ arr keep   where     keep (Nothing, Nothing) = (Nothing, Nothing)@@ -86,7 +91,7 @@  -- | Hold the first value and output it indefinitely. holdFirst :: (Data a, Monad m) => Cell m a a-holdFirst = Cell { .. }+holdFirst = Cell {..}   where     cellState = Nothing     cellStep Nothing x = return (x, Just x)@@ -96,20 +101,23 @@ boundedFIFO :: (Data a, Monad m) => Int -> Cell m (Maybe a) (Seq a) boundedFIFO n = foldC' step empty   where-    step Nothing  as = as+    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.+{- | 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)+  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.+{- | 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 @@ -137,10 +145,10 @@  -- | A command to send to 'buffer'. data BufferCommand a-  = Push a-  -- ^ Add an 'a' to the buffer.-  | Pop-  -- ^ Remove the oldest element from the buffer.+  = -- | Add an 'a' to the buffer.+    Push a+  | -- | Remove the oldest element from the buffer.+    Pop  -- | Pushes @'Just' a@ and does nothing on 'Nothing'. maybePush :: Maybe a -> [BufferCommand a]@@ -159,12 +167,12 @@ * Remove elements by inputting 'Pop'. -} buffer :: (Monad m, Data a) => Cell m [BufferCommand a] (Maybe a)-buffer = Cell { .. }+buffer = Cell {..}   where     cellState = empty     cellStep as commands = return (currentHead as, nextBuffer as commands)     currentHead as = case viewl as of-      EmptyL   -> Nothing+      EmptyL -> Nothing       a :< as' -> Just a     nextBuffer as [] = as     nextBuffer as (Push a : commands) = nextBuffer (as |> a) commands@@ -181,14 +189,14 @@  This construction guarantees that @cell@ produces exactly one output for every input value. -}-buffered-  :: (Monad m, Data a)-  => Cell m (Maybe a) (Maybe b)-  -> Cell m (Maybe a) (Maybe b)+buffered ::+  (Monad m, Data a) =>+  Cell m (Maybe a) (Maybe b) ->+  Cell m (Maybe a) (Maybe b) buffered cell = feedback Nothing $ proc (aMaybe, ticked) -> do   aMaybe' <- buffer -< maybePop ticked ++ maybePush aMaybe-  bMaybe' <- cell   -< aMaybe'-  returnA           -< (bMaybe', void bMaybe')+  bMaybe' <- cell -< aMaybe'+  returnA -< (bMaybe', void bMaybe')  -- * Detecting change @@ -198,22 +206,25 @@ 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 ::+  (Monad m, Data p, Eq p) =>+  -- | This parameter has to change during live coding to trigger an action+  p ->+  -- | This action gets passed the old parameter and the new parameter+  (p -> p -> a -> m b) ->+  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' ::+  (Monad m, Data p, Eq p) =>+  -- | This action gets passed the old parameter and the new parameter+  (p -> p -> a -> m b) ->+  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+  bMaybeMaybe <- resampleMaybe $ arrM $ whenDifferent action -< (,pCurrent,a) <$> pPrevious   returnA -< join bMaybeMaybe

@@ -4,4 +4,4 @@ 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+  | otherwise = return Nothing

@@ -8,7 +8,7 @@  -- base import Data.Data-import Data.Maybe (fromMaybe, fromJust)+import Data.Maybe (fromJust, fromMaybe) import Data.Proxy import Data.Typeable import Unsafe.Coerce@@ -25,8 +25,8 @@ import LiveCoding.Cell import LiveCoding.Cell.Feedback import LiveCoding.Debugger-import LiveCoding.Forever import LiveCoding.Exceptions+import LiveCoding.Forever  statePrint :: Debugger IO statePrint = Debugger $ liveCell $ arrM $ const $ do@@ -34,22 +34,24 @@   lift $ putStrLn $ stateShow s  stateShow :: Data s => s -> String-stateShow-  =       gshow-  `ext2Q` compositionShow-  `ext2Q` foreverEShow-  `ext2Q` feedbackShow-  `ext2Q` parallelShow-  `ext2Q` exceptShow-  `ext2Q` choiceShow+stateShow =+  gshow+    `ext2Q` compositionShow+    `ext2Q` foreverEShow+    `ext2Q` feedbackShow+    `ext2Q` parallelShow+    `ext2Q` exceptShow+    `ext2Q` choiceShow  isUnit :: Data s => s -> Bool-isUnit = mkQ False-          (\() -> True)-  `ext2Q` (\(a, b) -> isUnit a && isUnit b)-  `ext2Q` (\(Composition s1 s2) -> isUnit s1 && isUnit s2)-  `ext2Q` (\(Parallel s1 s2) -> isUnit s1 && isUnit s2)-  `ext2Q` (\(Choice sL sR) -> isUnit sL && isUnit sR)+isUnit =+  mkQ+    False+    (\() -> True)+    `ext2Q` (\(a, b) -> isUnit a && isUnit b)+    `ext2Q` (\(Composition s1 s2) -> isUnit s1 && isUnit s2)+    `ext2Q` (\(Parallel s1 s2) -> isUnit s1 && isUnit s2)+    `ext2Q` (\(Choice sL sR) -> isUnit sL && isUnit sR)  compositionShow :: (Data s1, Data s2) => Composition s1 s2 -> String compositionShow (Composition s1 s2)@@ -65,26 +67,28 @@   | otherwise = "(" ++ stateShow s1 ++ " *** " ++ stateShow s2 ++ ")"  foreverEShow :: (Data e, Data s) => ForeverE e s -> String-foreverEShow ForeverE { .. }-  =  "forever("-  ++ (if isUnit lastException then "" else gshow lastException ++ ", ")-  ++ stateShow initState ++ "): " ++ stateShow currentState+foreverEShow ForeverE {..} =+  "forever("+    ++ (if isUnit lastException then "" else gshow lastException ++ ", ")+    ++ stateShow initState+    ++ "): "+    ++ stateShow currentState  feedbackShow :: (Data state, Data s) => Feedback state s -> String-feedbackShow Feedback { .. } = "feedback " ++ gshow sAdditional ++ " $ " ++ stateShow sPrevious+feedbackShow Feedback {..} = "feedback " ++ gshow sAdditional ++ " $ " ++ stateShow sPrevious  exceptShow :: (Data s, Data e) => ExceptState s e -> String exceptShow (NotThrown s) = "NotThrown: " ++ stateShow s ++ "\n"-exceptShow (Exception e)-  =  "Exception"-  ++ (if isUnit e then "" else " " ++ gshow e)-  ++ ":\n"+exceptShow (Exception e) =+  "Exception"+    ++ (if isUnit e then "" else " " ++ gshow e)+    ++ ":\n"  choiceShow :: (Data stateL, Data stateR) => Choice stateL stateR -> String-choiceShow Choice { .. }-  | isUnit choiceLeft  = "+" ++ stateShow choiceRight ++ "+"-  | isUnit choiceRight = "+" ++ stateShow choiceLeft  ++ "+"-  | otherwise     = "+" ++ stateShow choiceLeft ++ " +++ " ++ stateShow choiceRight ++ "+"+choiceShow Choice {..}+  | isUnit choiceLeft = "+" ++ stateShow choiceRight ++ "+"+  | isUnit choiceRight = "+" ++ stateShow choiceLeft ++ "+"+  | otherwise = "+" ++ stateShow choiceLeft ++ " +++ " ++ stateShow choiceRight ++ "+"  {- -- TODO  Leave out for now from the examples and open bug when public@@ -98,9 +102,11 @@        => c (t a b) -> Maybe (c (t' a b)) gcast2 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t')) -}-gcast3-  :: forall f t t' a b c. (Typeable t, Typeable t')-  => f (t a b c) -> Maybe (f (t' a b c))+gcast3 ::+  forall f t t' a b c.+  (Typeable t, Typeable t') =>+  f (t a b c) ->+  Maybe (f (t' a b c)) gcast3 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t'))  -- from https://stackoverflow.com/questions/14447050/how-to-define-syb-functions-for-type-extension-for-tertiary-type-constructors-e?rq=1@@ -119,8 +125,8 @@ dropMaybe _ = id -} ---thing :: (Typeable t) => (forall b c d . (Data b, Data c, Data d) => f (t b c d)) -> TypeRep---thing = typeRep+-- thing :: (Typeable t) => (forall b c d . (Data b, Data c, Data d) => f (t b c d)) -> TypeRep+-- thing = typeRep {- dataCast3   :: (Typeable t, Data a)@@ -144,19 +150,19 @@ --ext3 def ext = fromMaybe def $ gcast3' ext --ext3 def ext = maybe def id $ dataCast3 ext -}-ext3-  :: (Data a, Data b, Data c, Data d, Typeable t, Typeable f)-  => f a-  -> f (t b c d)-  -> f a+ext3 ::+  (Data a, Data b, Data c, Data d, Typeable t, Typeable f) =>+  f a ->+  f (t b c d) ->+  f a ext3 def ext = maybe def id $ cast ext -ext3Q-  :: (Data a, Data b, Data c, Data d, Typeable t, Typeable q)-  => (a -> q)-  -> (t b c d -> q)-  -> a -> q+ext3Q ::+  (Data a, Data b, Data c, Data d, Typeable t, Typeable q) =>+  (a -> q) ->+  (t b c d -> q) ->+  a ->+  q ext3Q def ext = unQ ((Q def) `ext3` (Q ext)) --newtype Q q x = Q { unQ :: x -> q }+newtype Q q x = Q {unQ :: x -> q}

@@ -1,10 +1,10 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RecordWildCards #-}+ {- | Utilities for integrating live programs into external loops, using 'IO' concurrency. The basic idea is two wormholes (see Winograd-Court's thesis). -}--{-# LANGUAGE Arrows #-}-{-# LANGUAGE RecordWildCards #-} module LiveCoding.External where  -- base@@ -27,14 +27,14 @@  concurrently :: (MonadIO m, Monoid eOut) => ExternalCell m eIn eOut a b -> IO (Cell m a b, ExternalLoop eIn eOut) concurrently externalCell = do-  inVar  <- newEmptyMVar+  inVar <- newEmptyMVar   outVar <- newEmptyMVar   let     cell = proc a -> do-      eIn       <- constM (liftIO $ takeMVar inVar)      -< ()+      eIn <- constM (liftIO $ takeMVar inVar) -< ()       (eOut, b) <- runWriterC (runReaderC' externalCell) -< (eIn, a)-      arrM (liftIO . putMVar outVar)                     -< eOut-      returnA                                            -< b+      arrM (liftIO . putMVar outVar) -< eOut+      returnA -< b     externalLoop = arrM (putMVar inVar) >>> constM (takeMVar outVar)   return (cell, externalLoop) 

@@ -1,7 +1,8 @@ {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+ {- | Support functions to call common live coding functionalities like launching and reloading from a @ghci@ or @cabal repl@ session. @@ -14,8 +15,8 @@  -- base import Control.Concurrent-import Control.Exception (SomeException, try, Exception (toException, displayException))-import Control.Monad (void, (>=>), join)+import Control.Exception (Exception (displayException, toException), SomeException, try)+import Control.Monad (join, void, (>=>)) import Data.Data import Data.Function ((&)) @@ -34,25 +35,27 @@  -- | An exception type marking the absence of a foreign store of the correct type. data NoStore = NoStore-  deriving Show+  deriving (Show)  instance Exception NoStore  -- * Retrieving launched programs from the foreign store --- | Try to retrieve a 'LiveProgram' of a given type from the 'Store',---   handling all 'IO' exceptions.---   Returns 'Right Nothing' if the store didn't exist.-possiblyLaunchedProgram-  :: Launchable m-  => Proxy m-  -> IO (Either SomeException (LaunchedProgram m))+{- | Try to retrieve a 'LiveProgram' of a given type from the 'Store',+   handling all 'IO' exceptions.+   Returns 'Right Nothing' if the store didn't exist.+-}+possiblyLaunchedProgram ::+  Launchable m =>+  Proxy m ->+  IO (Either SomeException (LaunchedProgram m)) possiblyLaunchedProgram _ = do   storeMaybe <- lookupStore 0   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.+{- | Try to load a 'LiveProgram' of a given type from the 'Store'.+   If the store doesn't contain a program, it is (re)started.+-} sync :: Launchable m => LiveProgram m -> IO () sync program = do   launchedProgramPossibly <- possiblyLaunchedProgram $ proxyFromLiveProgram program@@ -75,12 +78,13 @@ save :: Launchable m => LaunchedProgram m -> IO () save = writeStore $ Store 0 --- | Try to retrieve a 'LaunchedProgram' from the 'Store',---   and if successful, stop it.-stopStored-  :: Launchable m-  => Proxy m-  -> IO ()+{- | Try to retrieve a 'LaunchedProgram' from the 'Store',+   and if successful, stop it.+-}+stopStored ::+  Launchable m =>+  Proxy m ->+  IO () stopStored proxy = do   launchedProgramPossibly <- possiblyLaunchedProgram proxy   either (putStrLn . displayException) stop launchedProgramPossibly@@ -88,15 +92,19 @@ -- * GHCi commands  -- ** Debugging+ -- TODO Could also parametrise this and all other commands by the 'liveProgram' --- | Initialise a launched program in the store,---   but don't start it.-liveinit _ = return $ unlines-  [ "programVar <- newMVar liveProgram"-  , "threadId <- myThreadId"-  , "save LaunchedProgram { .. }"-  ]+{- | Initialise a launched program in the store,+   but don't start it.+-}+liveinit _ =+  return $+    unlines+      [ "programVar <- newMVar liveProgram"+      , "threadId <- myThreadId"+      , "save LaunchedProgram { .. }"+      ]  -- | Run one program step, assuming you have a launched program in a variable @launchedProgram@. livestep _ = return "stepLaunchedProgram launchedProgram"@@ -107,10 +115,12 @@ livelaunch _ = return "sync liveProgram"  -- | Reload the code and do hot code swap and migration.-livereload _ = return $ unlines-  [ ":reload"-  , "sync liveProgram"-  ]+livereload _ =+  return $+    unlines+      [ ":reload"+      , "sync liveProgram"+      ]  -- | Stop the program. livestop _ = return "stopStored $ proxyFromLiveProgram liveProgram"

@@ -11,7 +11,7 @@ import Data.Data  -- transformers-import Control.Monad.Trans.Class (MonadTrans(lift))+import Control.Monad.Trans.Class (MonadTrans (lift))  -- mmorph import Control.Monad.Morph@@ -19,6 +19,7 @@ -- essence-of-live-coding import LiveCoding.Cell import LiveCoding.HandlingState+import LiveCoding.Migrate.NoMigration  {- | Container for unserialisable values, such as 'IORef's, threads, 'MVar's, pointers, and device handles.@@ -41,10 +42,11 @@   }  instance MFunctor Handle where-  hoist morphism Handle { .. } = Handle-    { create = morphism create-    , destroy = morphism . destroy-    }+  hoist morphism Handle {..} =+    Handle+      { create = morphism create+      , destroy = morphism . destroy+      }  {- | Combine two handles to one. @@ -56,10 +58,11 @@ (because the destructor is contravariant in @h@). -} combineHandles :: Applicative m => Handle m h1 -> Handle m h2 -> Handle m (h1, h2)-combineHandles handle1 handle2 = Handle-  { create = ( , ) <$> create handle1 <*> create handle2-  , destroy = \(h1, h2) -> destroy handle2 h2 *> destroy handle1 h1-  }+combineHandles handle1 handle2 =+  Handle+    { create = (,) <$> create handle1 <*> create handle2+    , destroy = \(h1, h2) -> destroy handle2 h2 *> destroy handle1 h1+    }  {- | Hide a handle in a cell, taking care of initialisation and destruction.@@ -73,12 +76,12 @@ Migrations will by default not inspect the interior of a 'handling' cell. This means that handles are only migrated if they have exactly the same type. -}-handling-  :: ( Typeable h-     , Monad m-     )-  => Handle m h-  -> Cell (HandlingStateT m) arbitrary h+handling ::+  ( Typeable h+  , Monad m+  ) =>+  Handle m h ->+  Cell (HandlingStateT m) arbitrary h handling handle = arr (const ()) >>> handlingParametrised (toParametrised handle)  {- | Generalisation of 'Handle' carrying an additional parameter which may change at runtime.@@ -94,32 +97,35 @@   }  instance MFunctor (ParametrisedHandle p) where-  hoist morphism ParametrisedHandle { .. } = ParametrisedHandle-    { createParametrised = morphism . createParametrised-    , changeParametrised = ((morphism .) .) . changeParametrised-    , destroyParametrised = (morphism .) . destroyParametrised-    }+  hoist morphism ParametrisedHandle {..} =+    ParametrisedHandle+      { createParametrised = morphism . createParametrised+      , changeParametrised = ((morphism .) .) . changeParametrised+      , destroyParametrised = (morphism .) . destroyParametrised+      } --- | Given the methods 'createParametrised' and 'destroyParametrised',---   build a fitting method for 'changeParametrised' which+{- | 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+  | otherwise = do       destructor pOld h       creator pNew  -- | 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-  }+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+    }  {- | Hide a 'ParametrisedHandle' in a cell, taking care of initialisation and destruction.@@ -134,35 +140,38 @@ 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 { .. }+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+      return (mereHandle, Initialized Handling {handle = handle, ..})+    cellStep handling@(Initialized 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), .. })+          return (mereHandle, Initialized Handling {handle = (mereHandle, parameter), ..}) --- | Every 'Handle' is trivially a 'ParametrisedHandle'---   when the parameter is the trivial type.+{- | 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-  }+toParametrised Handle {..} =+  ParametrisedHandle+    { createParametrised = const create+    , changeParametrised = const $ const return+    , destroyParametrised = const destroy+    }

@@ -10,30 +10,36 @@  -- | Create an 'IORef', with no special cleanup action. ioRefHandle :: a -> Handle IO (IORef a)-ioRefHandle a = Handle-  { create = newIORef a-  , destroy = const $ return () -- IORefs are garbage collected-  }+ioRefHandle a =+  Handle+    { create = newIORef a+    , destroy = const $ return () -- IORefs are garbage collected+    }  -- | Create an uninitialised 'MVar', with no special cleanup action. emptyMVarHandle :: Handle IO (MVar a)-emptyMVarHandle = Handle-  { create = newEmptyMVar-  , destroy = const $ return () -- MVars are garbage collected-  }+emptyMVarHandle =+  Handle+    { create = newEmptyMVar+    , destroy = const $ return () -- MVars are garbage collected+    } --- | Create an 'MVar' initialised to some value @a@,---   with no special cleanup action.+{- | Create an 'MVar' initialised to some value @a@,+   with no special cleanup action.+-} newMVarHandle :: a -> Handle IO (MVar a)-newMVarHandle a = Handle-  { create = newMVar a-  , destroy = const $ return () -- MVars are garbage collected-  }+newMVarHandle a =+  Handle+    { create = newMVar a+    , destroy = const $ return () -- MVars are garbage collected+    } --- | Launch a thread executing the given action---   and kill it when the handle is removed.+{- | Launch a thread executing the given action+   and kill it when the handle is removed.+-} threadHandle :: IO () -> Handle IO ThreadId-threadHandle action = Handle-  { create  = forkIO action-  , destroy = killThread-  }+threadHandle action =+  Handle+    { create = forkIO action+    , destroy = killThread+    }

@@ -6,11 +6,11 @@ module LiveCoding.HandlingState where  -- base-import Control.Arrow (returnA, arr, (>>>))+import Control.Arrow (arr, returnA, (>>>)) import Data.Data  -- transformers-import Control.Monad.Trans.Class (MonadTrans(lift))+import Control.Monad.Trans.Class (MonadTrans (lift)) import Control.Monad.Trans.State.Strict import Data.Foldable (traverse_) @@ -25,41 +25,41 @@ import LiveCoding.LiveProgram import LiveCoding.LiveProgram.Monad.Trans -data Handling h where-  Handling-    :: { key    :: Key-       , handle :: h-       }-    -> Handling h-  Uninitialized :: Handling h+data Handling h = Handling+  { key :: Key+  , handle :: h+  }  type Destructors m = IntMap (Destructor m)  -- | Hold a map of registered handle keys and destructors data HandlingState m = HandlingState-  { nHandles    :: Key+  { nHandles :: Key   , destructors :: Destructors m   }-  deriving Data+  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.+{- | 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-  }+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+{- | 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.@@ -73,109 +73,99 @@ 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 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-  , ..-  }+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 ::+  Monad m =>+  HandlingStateT m a ->+  HandlingStateT m a garbageCollected action = unregisterAll >> action <* destroyUnregistered  data Destructor m = Destructor   { isRegistered :: Bool-  , action       :: m ()+  , action :: m ()   } --register-  :: Monad m-  => m () -- ^ Destructor-  -> HandlingStateT m Key+register ::+  Monad m =>+  -- | Destructor+  m () ->+  HandlingStateT m Key register destructor = do-  HandlingState { .. } <- get+  HandlingState {..} <- get   let key = nHandles + 1-  put HandlingState-    { nHandles = key-    , destructors = insertDestructor destructor key destructors-    }+  put+    HandlingState+      { nHandles = key+      , destructors = insertDestructor destructor key destructors+      }   return key -reregister-  :: Monad m-  => m ()-  -> Key-  -> HandlingStateT m ()+reregister ::+  Monad m =>+  m () ->+  Key ->+  HandlingStateT m () reregister action key = do-  HandlingState { .. } <- get-  put HandlingState { destructors = insertDestructor action key destructors, .. }+  HandlingState {..} <- get+  put HandlingState {destructors = insertDestructor action key destructors, ..} -insertDestructor-  :: m ()-  -> Key-  -> Destructors m-  -> Destructors m+insertDestructor ::+  m () ->+  Key ->+  Destructors m ->+  Destructors m insertDestructor action key destructors =-  let destructor = Destructor { isRegistered = True, .. }-  in  insert key destructor destructors+  let destructor = Destructor {isRegistered = True, ..}+   in insert key destructor destructors -unregisterAll-  :: Monad m-  => HandlingStateT m ()+unregisterAll ::+  Monad m =>+  HandlingStateT m () unregisterAll = do-  HandlingState { .. } <- get-  let newDestructors = IntMap.map (\destructor -> destructor { isRegistered = False }) destructors-  put HandlingState { destructors = newDestructors, .. }+  HandlingState {..} <- get+  let newDestructors = IntMap.map (\destructor -> destructor {isRegistered = False}) destructors+  put HandlingState {destructors = newDestructors, ..} -destroyUnregistered-  :: Monad m-  => HandlingStateT m ()+destroyUnregistered ::+  Monad m =>+  HandlingStateT m () destroyUnregistered = do-  HandlingState { .. } <- get+  HandlingState {..} <- get   let-      (registered, unregistered) = partition isRegistered destructors+    (registered, unregistered) = partition isRegistered destructors   traverse_ (lift . action) unregistered-  put HandlingState { destructors = registered, .. }+  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 ]+dataTypeDestructor = mkDataType "Destructor" [destructorConstr]  destructorConstr :: Constr destructorConstr = mkConstr dataTypeDestructor "Destructor" [] Prefix  instance Typeable m => Data (Destructor m) where   dataTypeOf _ = dataTypeDestructor-  toConstr Destructor { .. } = destructorConstr+  toConstr Destructor {..} = destructorConstr   gunfold _ _ = error "Destructor.gunfold"

@@ -1,5 +1,6 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+ {- | Live programs in the @'ExceptT' e m@ monad can stop execution by throwing an exception @e@.  Handling these exceptions is done by realising that live programs in fact form a monad in the exception type.@@ -8,7 +9,7 @@ module LiveCoding.LiveProgram.Except where  -- base-import Control.Monad (liftM, ap)+import Control.Monad (ap, liftM) import Data.Data import Data.Void (Void) @@ -17,12 +18,12 @@ import Control.Monad.Trans.Reader  -- essence-of-live-coding-import LiveCoding.Cell (hoistCell, toLiveCell, liveCell, constM)-import LiveCoding.CellExcept (CellExcept, runCellExcept, once_)+import LiveCoding.Cell (constM, hoistCell, liveCell, toLiveCell)+import LiveCoding.CellExcept (CellExcept, once_, runCellExcept)+import qualified LiveCoding.CellExcept as CellExcept import LiveCoding.Exceptions.Finite (Finite) import LiveCoding.Forever import LiveCoding.LiveProgram-import qualified LiveCoding.CellExcept as CellExcept  {- | A live program that can throw an exception. @@ -39,25 +40,25 @@ 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.-runLiveProgramExcept-  :: Monad m-  => LiveProgramExcept m e-  -> LiveProgram (ExceptT e m)-runLiveProgramExcept LiveProgramExcept { .. } = liveCell $ runCellExcept unLiveProgramExcept+runLiveProgramExcept ::+  Monad m =>+  LiveProgramExcept m e ->+  LiveProgram (ExceptT e m)+runLiveProgramExcept LiveProgramExcept {..} = liveCell $ runCellExcept unLiveProgramExcept  {- | Lift a 'LiveProgram' into the 'LiveProgramExcept' monad.  Similar to 'LiveProgram.CellExcept.try'. This will execute the live program until it throws an exception. -}-try-  :: (Data e, Finite e, Functor m)-  => LiveProgram (ExceptT e m)-  -> LiveProgramExcept m e+try ::+  (Data e, Finite e, Functor m) =>+  LiveProgram (ExceptT e m) ->+  LiveProgramExcept m e try = LiveProgramExcept . CellExcept.try . toLiveCell  {- | Safely convert to 'LiveProgram's.@@ -66,20 +67,20 @@ no exceptions can be thrown, and thus we can safely assume that it is a 'LiveProgram' in @m@. -}-safely-  :: Monad m-  => LiveProgramExcept m Void-  -> LiveProgram m+safely ::+  Monad m =>+  LiveProgramExcept m Void ->+  LiveProgram m safely = liveCell . CellExcept.safely . unLiveProgramExcept  {- | Run a 'LiveProgram' as a 'LiveProgramExcept'.  This is always safe in the sense that it has no exceptions. -}-safe-  :: Monad m-  => LiveProgram m-  -> LiveProgramExcept m Void+safe ::+  Monad m =>+  LiveProgram m ->+  LiveProgramExcept m Void safe = LiveProgramExcept . CellExcept.safe . toLiveCell  -- | Run a monadic action and immediately raise its result as an exception.@@ -95,19 +96,21 @@ This way, you can create an infinite loop, with the exception as the loop variable. -}-foreverELiveProgram-  :: (Data e, Monad m)-  => e -- ^ The loop initialisation-  -> LiveProgramExcept (ReaderT e m) e -- ^ The live program to execute indefinitely-  -> LiveProgram                  m-foreverELiveProgram e LiveProgramExcept { .. } = liveCell $ foreverE e $ hoistCell commute $ runCellExcept unLiveProgramExcept+foreverELiveProgram ::+  (Data e, Monad m) =>+  -- | The loop initialisation+  e ->+  -- | The live program to execute indefinitely+  LiveProgramExcept (ReaderT e m) e ->+  LiveProgram m+foreverELiveProgram e LiveProgramExcept {..} = liveCell $ foreverE e $ hoistCell commute $ runCellExcept unLiveProgramExcept   where     commute :: ExceptT e (ReaderT r m) a -> ReaderT r (ExceptT e m) a     commute action = ReaderT $ ExceptT . runReaderT (runExceptT action)  -- | Run a 'LiveProgramExcept' in a loop, discarding the exception.-foreverCLiveProgram-  :: (Data e, Monad m)-  => LiveProgramExcept m e-  -> LiveProgram       m-foreverCLiveProgram LiveProgramExcept { .. } = liveCell $ foreverC $ runCellExcept unLiveProgramExcept+foreverCLiveProgram ::+  (Data e, Monad m) =>+  LiveProgramExcept m e ->+  LiveProgram m+foreverCLiveProgram LiveProgramExcept {..} = liveCell $ foreverC $ runCellExcept unLiveProgramExcept

@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE RecordWildCards #-}+ module LiveCoding.LiveProgram.Monad.Trans where  -- base@@ -9,21 +10,24 @@ import Control.Monad.Trans.State.Strict  -- essence-of-live-coding-import LiveCoding.LiveProgram+ import LiveCoding.Cell.Monad.Trans+import LiveCoding.LiveProgram --- | Remove a stateful effect from the monad stack by supplying the initial state.---   This state then becomes part of the internal live program state,---   and is subject to migration as any other state.---   Live programs are automatically migrated to and from applications of 'runStateL'.-runStateL-  :: (Data stateT, Monad m)-  => LiveProgram (StateT stateT m)-  ->                     stateT-  -> LiveProgram                m-runStateL LiveProgram { .. } stateT = LiveProgram-  { liveState = State { stateInternal = liveState, .. }-  , liveStep = \State { .. } -> do-      (stateInternal, stateT) <- runStateT (liveStep stateInternal) stateT-      return State { .. }-  }+{- | Remove a stateful effect from the monad stack by supplying the initial state.+   This state then becomes part of the internal live program state,+   and is subject to migration as any other state.+   Live programs are automatically migrated to and from applications of 'runStateL'.+-}+runStateL ::+  (Data stateT, Monad m) =>+  LiveProgram (StateT stateT m) ->+  stateT ->+  LiveProgram m+runStateL LiveProgram {..} stateT =+  LiveProgram+    { liveState = State {stateInternal = liveState, ..}+    , liveStep = \State {..} -> do+        (stateInternal, stateT) <- runStateT (liveStep stateInternal) stateT+        return State {..}+    }

@@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-}+ module LiveCoding.Migrate.Cell where  -- base@@ -9,46 +10,49 @@ import Data.Generics.Aliases  -- essence-of-live-coding++import Control.Applicative (Alternative ((<|>))) import LiveCoding.Cell import LiveCoding.Cell.Feedback import LiveCoding.Exceptions import LiveCoding.Migrate.Migration-import Control.Applicative (Alternative((<|>)))  -- * Migrations to and from pairs  -- ** Generic migration functions --- | Builds the migration function for a pair, or product type,---   such as tuples, but customisable to your own products.---   You need to pass it the equivalents of 'fst', 'snd', and '(,)'.---   Tries to migrate the value into the first element, then into the second.-maybeMigrateToPair-  :: (Typeable a, Typeable b, Typeable c)-  => (t a b -> a)-  -- ^ The accessor of the first element-  -> (t a b -> b)-  -- ^ The accessor of the second element-  -> (a -> b -> t a b)-  -- ^ The constructor-  -> t a b-  -- ^ The pair-  -> c-  -- ^ The new value for the first or second element-  -> Maybe (t a b)+{- | Builds the migration function for a pair, or product type,+   such as tuples, but customisable to your own products.+   You need to pass it the equivalents of 'fst', 'snd', and '(,)'.+   Tries to migrate the value into the first element, then into the second.+-}+maybeMigrateToPair ::+  (Typeable a, Typeable b, Typeable c) =>+  -- | The accessor of the first element+  (t a b -> a) ->+  -- | The accessor of the second element+  (t a b -> b) ->+  -- | The constructor+  (a -> b -> t a b) ->+  -- | The pair+  t a b ->+  -- | The new value for the first or second element+  c ->+  Maybe (t a b) maybeMigrateToPair fst snd cons pair c = do   flip cons (snd pair) <$> cast c <|> cons (fst pair) <$> cast c --- | Like 'maybeMigrateToPair', but in the other direction.---   Again, it is biased with respect to the first element of the pair.-maybeMigrateFromPair-  :: (Typeable a, Typeable b, Typeable c)-  => (t a b -> a)-  -- ^ The accessor of the first element-  -> (t a b -> b)-  -- ^ The accessor of the second element-  -> t a b-  -> Maybe c+{- | Like 'maybeMigrateToPair', but in the other direction.+   Again, it is biased with respect to the first element of the pair.+-}+maybeMigrateFromPair ::+  (Typeable a, Typeable b, Typeable c) =>+  -- | The accessor of the first element+  (t a b -> a) ->+  -- | The accessor of the second element+  (t a b -> b) ->+  t a b ->+  Maybe c maybeMigrateFromPair fst snd pair = cast (fst pair) <|> cast (snd pair)  -- ** Migrations involving sequential compositions of cells@@ -57,16 +61,15 @@ migrationToComposition :: Migration migrationToComposition = migrationTo2 $ maybeMigrateToPair state1 state2 Composition - -- | Migrate @cell1 >>> cell2@ to @cell1@, and if this fails, to @cell2@. migrationFromComposition :: Migration migrationFromComposition = constMigrationFrom2 $ maybeMigrateFromPair state1 state2  -- | Combines all migrations related to composition, favouring migration to compositions. migrationComposition :: Migration-migrationComposition-  =  migrationToComposition-  <> migrationFromComposition+migrationComposition =+  migrationToComposition+    <> migrationFromComposition  -- ** Migrations involving parallel compositions of cells @@ -80,9 +83,9 @@  -- | Combines all migrations related to parallel composition, favouring migration to parallel composition. migrationParallel :: Migration-migrationParallel-  =  migrationToParallel-  <> migrationFromParallel+migrationParallel =+  migrationToParallel+    <> migrationFromParallel  -- ** Migration involving 'ArrowChoice' @@ -96,9 +99,9 @@  -- | Combines all migrations related to choice, favouring migration to choice. migrationChoice :: Migration-migrationChoice-  =  migrationToChoice-  <> migrationFromChoice+migrationChoice =+  migrationToChoice+    <> migrationFromChoice  -- ** Feedback @@ -116,11 +119,11 @@  -- * Control flow -maybeMigrateToExceptState-  :: (Typeable state, Typeable state')-  => ExceptState state e-  ->             state'-  -> Maybe (ExceptState state e)+maybeMigrateToExceptState ::+  (Typeable state, Typeable state') =>+  ExceptState state e ->+  state' ->+  Maybe (ExceptState state e) maybeMigrateToExceptState (NotThrown _) state = NotThrown <$> cast state maybeMigrateToExceptState (Exception e) _ = Just $ Exception e @@ -128,10 +131,10 @@ migrationToExceptState :: Migration migrationToExceptState = migrationTo2 maybeMigrateToExceptState -maybeMigrateFromExceptState-  :: (Typeable state, Typeable state')-  => ExceptState state e-  -> Maybe       state'+maybeMigrateFromExceptState ::+  (Typeable state, Typeable state') =>+  ExceptState state e ->+  Maybe state' maybeMigrateFromExceptState (NotThrown state) = cast state maybeMigrateFromExceptState (Exception e) = Nothing @@ -147,9 +150,9 @@  -- | Combines all 'Cell'-related migrations. migrationCell :: Migration-migrationCell-  =  migrationComposition-  <> migrationParallel-  <> migrationChoice-  <> migrationExceptState-  <> migrationFeedback+migrationCell =+  migrationComposition+    <> migrationParallel+    <> migrationChoice+    <> migrationExceptState+    <> migrationFeedback

@@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-}+ module LiveCoding.Migrate.Debugger where  -- base@@ -9,24 +10,24 @@ import LiveCoding.Debugger import LiveCoding.Migrate.Migration -maybeMigrateToDebugging-  :: (Typeable state', Typeable state)-  => Debugging dbgState state-  -> state'-  -> Maybe (Debugging dbgState state)-maybeMigrateToDebugging Debugging { dbgState } state' = do+maybeMigrateToDebugging ::+  (Typeable state', Typeable state) =>+  Debugging dbgState state ->+  state' ->+  Maybe (Debugging dbgState state)+maybeMigrateToDebugging Debugging {dbgState} state' = do   state <- cast state'-  return Debugging { .. }+  return Debugging {..}  -- | Tries to cast the current state into the joint state of debugger and program. migrationToDebugging :: Migration migrationToDebugging = migrationTo2 maybeMigrateToDebugging -maybeMigrateFromDebugging-  :: (Typeable state', Typeable state)-  => Debugging dbgState state-  -> Maybe              state'-maybeMigrateFromDebugging Debugging { state } = cast state+maybeMigrateFromDebugging ::+  (Typeable state', Typeable state) =>+  Debugging dbgState state ->+  Maybe state'+maybeMigrateFromDebugging Debugging {state} = cast state  -- | Try to extract a state from the current joint state of debugger and program. migrationFromDebugging :: Migration

@@ -13,20 +13,23 @@ import Data.Generics.Schemes (glength)  data Migration = Migration-  { runMigration :: forall a b . (Data a, Data b) => a -> b -> Maybe a }+  {runMigration :: forall a b. (Data a, Data b) => a -> b -> Maybe a}  -- | Run a migration and insert the new initial state in case of failure.-runSafeMigration-  :: (Data a, Data b)-  => Migration-  -> a -> b -> a+runSafeMigration ::+  (Data a, Data b) =>+  Migration ->+  a ->+  b ->+  a runSafeMigration migration a b = fromMaybe a $ runMigration migration a b  -- | If both migrations would succeed, the result from the first is used. instance Semigroup Migration where-  migration1 <> migration2 = Migration $ \a b -> getFirst-    $  (First $ runMigration migration1 a b)-    <> (First $ runMigration migration2 a b)+  migration1 <> migration2 = Migration $ \a b ->+    getFirst $+      (First $ runMigration migration1 a b)+        <> (First $ runMigration migration2 a b)  instance Monoid Migration where   mempty = Migration $ const $ const Nothing@@ -45,29 +48,30 @@   -- Try to cast the single child to b   gmapM (const $ cast b) a --- | If you have a specific type that you would like to be migrated to a specific other type,---   you can create a migration for this.---   For example: @userMigration (toInteger :: Int -> Integer)@-userMigration-  :: (Typeable c, Typeable d)-  => (c -> d)-  -> Migration+{- | If you have a specific type that you would like to be migrated to a specific other type,+   you can create a migration for this.+   For example: @userMigration (toInteger :: Int -> Integer)@+-}+userMigration ::+  (Typeable c, Typeable d) =>+  (c -> d) ->+  Migration userMigration specific = Migration $ \_a b -> cast =<< specific <$> cast b -migrationTo2-  :: Typeable t-  => (forall a b c . (Typeable a, Typeable b, Typeable c) => t b c -> a -> Maybe (t b c))-  -> Migration+migrationTo2 ::+  Typeable t =>+  (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> a -> Maybe (t b c)) ->+  Migration migrationTo2 f = Migration $ \t a -> ext2M (const Nothing) (flip f a) t -constMigrationFrom2-  :: Typeable t-  => (forall a b c . (Typeable a, Typeable b, Typeable c) => t b c -> Maybe a)-  -> Migration+constMigrationFrom2 ::+  Typeable t =>+  (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> Maybe a) ->+  Migration constMigrationFrom2 f = Migration $ \_ t -> ext2Q (const Nothing) f t -migrationTo1-  :: Typeable t-  => (forall a b . (Typeable a, Typeable b) => t b -> a -> Maybe (t b))-  -> Migration+migrationTo1 ::+  Typeable t =>+  (forall a b. (Typeable a, Typeable b) => t b -> a -> Maybe (t b)) ->+  Migration migrationTo1 f = Migration $ \t a -> ext1M (const Nothing) (flip f a) t

@@ -1,5 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-}+ module LiveCoding.Migrate.Monad.Trans where  -- base@@ -9,25 +10,26 @@ import LiveCoding.Cell.Monad.Trans import LiveCoding.Migrate.Migration -maybeMigrateToState-  :: (Typeable stateInternal', Typeable stateInternal)-  => State stateT stateInternal-  -> stateInternal'-  -> Maybe (State stateT stateInternal)-maybeMigrateToState State { stateT } stateInternal' = do+maybeMigrateToState ::+  (Typeable stateInternal', Typeable stateInternal) =>+  State stateT stateInternal ->+  stateInternal' ->+  Maybe (State stateT stateInternal)+maybeMigrateToState State {stateT} stateInternal' = do   stateInternal <- cast stateInternal'-  return State { .. }+  return State {..} --- | Tries to cast the current state into the joint state of a program---   where a state effect has been absorbed into the internal state with 'runStateL' or 'runStateC'.+{- | Tries to cast the current state into the joint state of a program+   where a state effect has been absorbed into the internal state with 'runStateL' or 'runStateC'.+-} migrationToState :: Migration migrationToState = migrationTo2 maybeMigrateToState -maybeMigrateFromState-  :: (Typeable stateInternal', Typeable stateInternal)-  => State stateT stateInternal-  -> Maybe              stateInternal'-maybeMigrateFromState State { stateInternal } = cast stateInternal+maybeMigrateFromState ::+  (Typeable stateInternal', Typeable stateInternal) =>+  State stateT stateInternal ->+  Maybe stateInternal'+maybeMigrateFromState State {stateInternal} = cast stateInternal  -- | Try to extract a state from the current joint state of a program wrapped with 'runStateL' or 'runStateC'. migrationFromState :: Migration

@@ -0,0 +1,111 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE RecordWildCards #-}++{- |+Module      : LiveCoding.Migrate.NoMigration+Description : Mechanism to save state in a Cell without requiring a Data instance.++If a data type is wrapped in 'NoMigration' then it can be used as the state of a 'Cell'+without requiring it to have a 'Data' instance. The consequence is that if the type has changed+in between a livereload, then the previous saved value will be discarded, and no migration attempt+will happen.++'LiveCoding' does not export 'delay' and 'changes' from this module. These functions should be+used with a qualified import.+-}+module LiveCoding.Migrate.NoMigration where++-- base++import Control.Arrow (Arrow (arr, second), returnA, (>>>))+import Control.Monad (guard)+import Data.Data (+  Constr,+  Data (dataTypeOf, gunfold, toConstr),+  DataType,+  Fixity (Prefix),+  Typeable,+  mkConstr,+  mkDataType,+ )++-- essence-of-live-coding+import LiveCoding.Cell+import qualified LiveCoding.Cell.Feedback as Feedback+import LiveCoding.Cell.Monad (hoistCellKleisli)++-- * 'NoMigration' data type and 'Data' instance.++{- | Isomorphic to @'Maybe' a@ but has a different 'Data' instance. The 'Data' instance for @'NoMigration' a@ doesn't require a 'Data' instance for @a@.++ If a data type is wrapped in 'NoMigration' then it can be used as the state of a 'Cell'+ without requiring it to have a 'Data' instance. The consequence is that if the type has changed+ in between a livereload, then the previous saved value will be discarded, and no migration attempt+ will happen.+-}+data NoMigration a = Initialized a | Uninitialized+  deriving (Show, Eq, Functor, Foldable, Traversable)++fromNoMigration :: a -> NoMigration a -> a+fromNoMigration _ (Initialized a) = a+fromNoMigration a Uninitialized = a++dataTypeNoMigration :: DataType+dataTypeNoMigration = mkDataType "NoMigration" [initializedConstr, uninitializedConstr]++initializedConstr :: Constr+initializedConstr = mkConstr dataTypeNoMigration "Initialized" [] Prefix++uninitializedConstr :: Constr+uninitializedConstr = mkConstr dataTypeNoMigration "Uninitialized" [] Prefix++-- |The Data instance for @'NoMigration' a@ doesn't require a 'Data' instance for @a@.+instance (Typeable a) => Data (NoMigration a) where+  dataTypeOf _ = dataTypeNoMigration+  toConstr (Initialized _) = initializedConstr+  toConstr Uninitialized = uninitializedConstr+  gunfold _cons nil _ = nil Uninitialized++-- * Utility functions which internally use 'NoMigration'.++{- | Like 'Feedback.delay', but doesn't require 'Data' instance, and only migrates the+ last value if it still has the same type.+-}+delay :: (Monad m, Typeable a) => a -> Cell m a a+delay a = arr Initialized >>> Feedback.delay Uninitialized >>> arr (fromNoMigration a)++{- | Like 'Utils.changes', but doesn't require Data instance, and only migrates the last+ value if it still is of the same type.+-}+changes :: (Typeable 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++{- | Caching version of 'arrM'.++   Only runs the computation in @m@ when the input value+   changes. Meanwhile it keeps outputing the last outputted value. Also runs the computation+   on the first tick. Does not require 'Data' instance. On `:livereload` will run action again on+   first tick.+-}+arrChangesM :: (Monad m, Typeable a, Typeable b, Eq a) => (a -> m b) -> Cell m a b+arrChangesM f = Cell {cellState = Uninitialized, ..}+  where+    cellStep Uninitialized a = h a+    cellStep (Initialized (a', b)) a =+      if a == a'+        then return (b, Initialized (a, b))+        else h a+    h a = (\b' -> (b', Initialized (a, b'))) <$> f a++cellNoMigration :: (Typeable s, Functor m) => s -> (s -> a -> m (b, s)) -> Cell m a b+cellNoMigration state step = Cell {cellState = Uninitialized, ..}+  where+    cellStep Uninitialized a = second Initialized <$> step state a+    cellStep (Initialized s) a = second Initialized <$> step s a

@@ -37,6 +37,10 @@ \end{code}  \begin{comment}+\begin{code}+cell1 `andThen` cell2 = cell1 `andThen` toCell cell2+\end{code}+ \begin{spec}   hoistCell readException cell2   where

@@ -1,8 +1,9 @@+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+ module LiveCoding.RuntimeIO.Launch where  -- base@@ -11,18 +12,20 @@ import Data.Data  -- transformers-import Control.Monad.Trans.State.Strict+ import Control.Monad.Trans.Except+import Control.Monad.Trans.State.Strict  -- essence-of-live-coding++import LiveCoding.Cell.Monad.Trans import LiveCoding.Debugger+import LiveCoding.Exceptions.Finite (Finite) import LiveCoding.Handle+import LiveCoding.HandlingState import LiveCoding.LiveProgram import LiveCoding.LiveProgram.Except 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.@@ -39,8 +42,9 @@ instance (Typeable m, Launchable m) => Launchable (HandlingStateT m) where   runIO = runIO . runHandlingState --- | Upon an exception, the program is restarted.---   To handle or log the exception, see "LiveCoding.LiveProgram.Except".+{- | Upon an exception, the program is restarted.+   To handle or log the exception, see "LiveCoding.LiveProgram.Except".+-} instance (Data e, Finite e, Launchable m) => Launchable (ExceptT e m) where   runIO liveProgram = runIO $ foreverCLiveProgram $ try liveProgram @@ -54,22 +58,22 @@ main = liveMain liveProgram @ -}-liveMain-  :: Launchable m-  => LiveProgram m-  -> IO ()+liveMain ::+  Launchable m =>+  LiveProgram m ->+  IO () liveMain = foreground . runIO  -- | Launch a 'LiveProgram' in the foreground thread (blocking). foreground :: Monad m => LiveProgram m -> m ()-foreground liveProgram-  =   stepProgram liveProgram-  >>= foreground+foreground liveProgram =+  stepProgram liveProgram+    >>= foreground  -- | A launched 'LiveProgram' and the thread in which it is running. data LaunchedProgram (m :: * -> *) = LaunchedProgram   { programVar :: MVar (LiveProgram IO)-  , threadId   :: ThreadId+  , threadId :: ThreadId   }  {- | Launch a 'LiveProgram' in a separate thread.@@ -78,23 +82,24 @@ The 'ThreadId' represents the thread where the program runs in. You're advised not to kill it directly, but to run 'stop' instead. -}-launch-  :: Launchable m-  => LiveProgram m-  -> IO (LaunchedProgram m)+launch ::+  Launchable m =>+  LiveProgram m ->+  IO (LaunchedProgram m) launch liveProg = do   programVar <- newMVar $ runIO liveProg   threadId <- forkIO $ background programVar-  return LaunchedProgram { .. }+  return LaunchedProgram {..}  -- | Migrate (using 'hotCodeSwap') the 'LiveProgram' to a new version.-update-  :: Launchable m-  => LaunchedProgram m-  -> LiveProgram     m-  -> IO ()-update LaunchedProgram { .. } newProg = modifyMVarMasked_ programVar-  $ return . hotCodeSwap (runIO newProg)+update ::+  Launchable m =>+  LaunchedProgram m ->+  LiveProgram m ->+  IO ()+update LaunchedProgram {..} newProg =+  modifyMVarMasked_ programVar $+    return . hotCodeSwap (runIO newProg)  {- | Stops a thread where a 'LiveProgram' is being executed. @@ -102,27 +107,27 @@ This can be used to call cleanup actions encoded in the monad, such as 'HandlingStateT'. -}-stop-  :: Launchable m-  => LaunchedProgram m-  -> IO ()-stop launchedProgram@LaunchedProgram { .. } = do+stop ::+  Launchable m =>+  LaunchedProgram m ->+  IO ()+stop launchedProgram@LaunchedProgram {..} = do   update launchedProgram mempty   stepLaunchedProgram launchedProgram   killThread threadId  -- | Launch a 'LiveProgram', but first attach a debugger to it.-launchWithDebugger-  :: (Monad m, Launchable m)-  => LiveProgram m-  -> Debugger m-  -> IO (LaunchedProgram m)+launchWithDebugger ::+  (Monad m, Launchable m) =>+  LiveProgram m ->+  Debugger m ->+  IO (LaunchedProgram m) launchWithDebugger liveProg debugger = launch $ liveProg `withDebugger` debugger  -- | This is the background task executed by 'launch'. background :: MVar (LiveProgram IO) -> IO () background var = forever $ do-  liveProg  <- takeMVar var+  liveProg <- takeMVar var   liveProg' <- stepProgram liveProg   putMVar var liveProg' @@ -130,11 +135,11 @@ stepProgram :: Monad m => LiveProgram m -> m (LiveProgram m) stepProgram LiveProgram {..} = do   liveState' <- liveStep liveState-  return LiveProgram { liveState = liveState', .. }+  return LiveProgram {liveState = liveState', ..}  -- | Advance a launched 'LiveProgram' by a single step and store the result.-stepLaunchedProgram-  :: (Monad m, Launchable m)-  => LaunchedProgram m-  -> IO ()-stepLaunchedProgram LaunchedProgram { .. } = modifyMVarMasked_ programVar stepProgram+stepLaunchedProgram ::+  (Monad m, Launchable m) =>+  LaunchedProgram m ->+  IO ()+stepLaunchedProgram LaunchedProgram {..} = modifyMVarMasked_ programVar stepProgram

@@ -1,10 +1,12 @@ {-# LANGUAGE ScopedTypeVariables #-}+ module Cell where  -- base-import Prelude hiding (id)+ import Control.Category import Data.Functor.Identity+import Prelude hiding (id)  -- transformers import Control.Monad.Trans.Identity@@ -21,12 +23,18 @@ -- essence-of-live-coding import LiveCoding -import qualified Cell.Util import qualified Cell.Monad.Trans+import qualified Cell.Util -test = testGroup "Cell"-  [ testProperty "steps produces outputs"-    $ \(inputs :: [Int]) -> inputs === fst (runIdentity $ steps (id :: Cell Identity Int Int) inputs)-  , Cell.Util.test-  , Cell.Monad.Trans.test-  ]+test =+  testGroup+    "Cell"+    [ testProperty "steps produces outputs" $+        \(inputs :: [Int]) -> inputs === fst (runIdentity $ steps (id :: Cell Identity Int Int) inputs)+    , testProperty "sumC works as expected" $+        forAll (vector 100) $ \(inputs :: [Int]) ->+          sum (init inputs)+            === last (fst (runIdentity $ steps (sumC :: Cell Identity Int Int) inputs))+    , Cell.Util.test+    , Cell.Monad.Trans.test+    ]

@@ -1,5 +1,6 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE ScopedTypeVariables #-}+ module Cell.Monad.Trans where  -- transformers@@ -19,8 +20,10 @@  import Util -test = testGroup "Cell.Monad.Trans"-  [ testProperty "readerC" $ inIdentityT $ proc (n :: Int) -> do-      nReader <- runReaderC' $ constM ask -< (n, ())-      returnA -< n === nReader-  ]+test =+  testGroup+    "Cell.Monad.Trans"+    [ testProperty "readerC" $ inIdentityT $ proc (n :: Int) -> do+        nReader <- runReaderC' $ constM ask -< (n, ())+        returnA -< n === nReader+    ]

@@ -1,12 +1,15 @@ {-# LANGUAGE Arrows #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-}+ module Cell.Util where  -- base import qualified Control.Category as C+import Control.Monad import Data.Functor.Identity+import Data.List import Data.Maybe-import Control.Monad  -- transformers import Control.Monad.Trans.Reader@@ -25,88 +28,168 @@  import Util -test = testGroup "Utility unit tests"---   [ testProperty "Buffer works as expected" CellSimulation---       { cell = buffer---       , input = []---     --   , input =---     --       [ []---     --       , [Pop]---     --       , [Push (23 :: Int)]---     --       , []---     --       , [Pop, Pop]---     --       , [Push 42, Pop]---     --       , [Push 1, Push 2]---     --       , []---     --       , []---     --       , [Pop, Push 3]---     --       , []---     --       , [Pop]---     --       , [Pop]---     --       , []---     --       ]---       , output = []---     --   , output =---     --       [ Nothing---     --       , Nothing---     --       , Just 23---     --       , Just 23---     --       , Nothing---     --       , Nothing---     --       , Just 1---     --       , Just 1---     --       , Just 1---     --       , Just 2---     --       , Just 2---     --       , Just 3---     --       , Nothing---     --       , Nothing---     --       ]---       }-  [ testProperty "buffered works as expected" CellSimulation-    { cell = buffered C.id-    , input =-        [ Just (23 :: Int)-        ]-    , output =-        [ Nothing-        ]-    }-  , testProperty "buffered can be used in an asynchronous setting" $ do-      jointInputs <- arbitrary -- Simulates when input arrives and when inner cell is activated-      -- Make sure cell is ticked at the last time, and no new input arrives-      let innerCell = proc (aMaybe :: Maybe Int) -> do-            isScheduled <- constM ask -< ()-            returnA -< guard isScheduled >> aMaybe-          outerCell = buffered innerCell-          (outputs, _) = runIdentity $ steps (runReaderC' outerCell) jointInputs-          labelString = unwords [show jointInputs, show outputs, show $ length jointInputs, show $ length outputs]-          inputs = snd $ unzip jointInputs-          bufferNotEmpty = isJust $ listToMaybe $ reverse outputs-      -- Make sure each message arrived exactly once, in order-      return-        $ 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-        ]-    }            -  ]+test =+  testGroup+    "Utility unit tests"+    --   [ testProperty "Buffer works as expected" CellSimulation+    --       { cell = buffer+    --       , input = []+    --     --   , input =+    --     --       [ []+    --     --       , [Pop]+    --     --       , [Push (23 :: Int)]+    --     --       , []+    --     --       , [Pop, Pop]+    --     --       , [Push 42, Pop]+    --     --       , [Push 1, Push 2]+    --     --       , []+    --     --       , []+    --     --       , [Pop, Push 3]+    --     --       , []+    --     --       , [Pop]+    --     --       , [Pop]+    --     --       , []+    --     --       ]+    --       , output = []+    --     --   , output =+    --     --       [ Nothing+    --     --       , Nothing+    --     --       , Just 23+    --     --       , Just 23+    --     --       , Nothing+    --     --       , Nothing+    --     --       , Just 1+    --     --       , Just 1+    --     --       , Just 1+    --     --       , Just 2+    --     --       , Just 2+    --     --       , Just 3+    --     --       , Nothing+    --     --       , Nothing+    --     --       ]+    --       }+    [ testProperty+        "buffered works as expected"+        CellSimulation+          { cell = buffered C.id+          , input =+              [ Just (23 :: Int)+              ]+          , output =+              [ Nothing+              ]+          }+    , testProperty "buffered can be used in an asynchronous setting" $ do+        jointInputs <- arbitrary -- Simulates when input arrives and when inner cell is activated+        -- Make sure cell is ticked at the last time, and no new input arrives+        let innerCell = proc (aMaybe :: Maybe Int) -> do+              isScheduled <- constM ask -< ()+              returnA -< guard isScheduled >> aMaybe+            outerCell = buffered innerCell+            (outputs, _) = runIdentity $ steps (runReaderC' outerCell) jointInputs+            labelString = unwords [show jointInputs, show outputs, show $ length jointInputs, show $ length outputs]+            inputs = snd $ unzip jointInputs+            bufferNotEmpty = isJust $ listToMaybe $ reverse outputs+        -- Make sure each message arrived exactly once, in order+        return $+          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+              ]+          }+    , testProperty+        "changes migrates correctly to itself"+        CellMigrationSimulation+          { cell1 = changes+          , cell2 = changes+          , input1 = [1, 2] :: [Int]+          , input2 = [3, 4] :: [Int]+          , output1 = [Nothing, Just 2]+          , output2 = [Just 3, Just 4]+          }+    , testProperty+        "delay migrates correctly to itself"+        CellMigrationSimulation+          { cell1 = LiveCoding.delay 0+          , cell2 = LiveCoding.delay 0+          , input1 = [1 :: Int, 2, 3, 4]+          , input2 = [5 :: Int, 6, 7, 8]+          , output1 = [0, 1, 2, 3]+          , output2 = [4, 5, 6, 7]+          }+    , testProperty+        "delay migrates correctly with original type wrapped in data type with single constructor"+        CellMigrationSimulation+          { cell1 = LiveCoding.delay 0 :: Cell Identity Int Int+          , cell2 = arr Stuff >>> LiveCoding.delay (Stuff 99) >>> arr (\(Stuff a) -> a) :: Cell Identity Int Int+          , input1 = [1, 2, 3, 4] :: [Int]+          , input2 = [10, 10, 10, 10] :: [Int]+          , output1 = [0, 1, 2, 3] :: [Int]+          , output2 = [4, 10, 10, 10] :: [Int]+          }+    , testProperty "resampleListPar works as expected" $+        forAll (vector 100) $ \(inputs :: [(Int, Int)]) ->+          let+            inputs' = fmap pairToList inputs+            pairToList :: (a, a) -> [a]+            pairToList (x, y) = [x, y]+           in+            CellSimulation+              { cell = resampleListPar (sumC :: Cell Identity Int Int)+              , input = inputs'+              , output = fmap sum . transpose <$> [[0 :: Int, 0]] : tail (inits (init inputs'))+              }+    , testProperty+        "resampleListPar grow"+        CellSimulation+          { cell = resampleListPar (sumC :: Cell Identity Int Int)+          , input = [[1, 1, 1], [1, 1, 1], [1, 1, 1, 1], [1, 1, 1, 1], [1, 1, 1, 1, 1]]+          , output = [[0, 0, 0], [1, 1, 1], [2, 2, 2, 0], [3, 3, 3, 1], [4, 4, 4, 2, 0]]+          }+    , testProperty+        "resampleListPar shrink"+        CellSimulation+          { cell = resampleListPar (sumC :: Cell Identity Int Int)+          , input = [[1, 1, 1], [1, 1, 1], [1, 1], [1, 1], [1], []]+          , output = [[0, 0, 0], [1, 1, 1], [2, 2], [3, 3], [4], []]+          }+    , testProperty+        "resampleListPar grow then shrink"+        CellSimulation+          { cell = resampleListPar (sumC :: Cell Identity Int Int)+          , input = [[1, 1, 1], [1, 1, 1, 1], [1, 1, 1]]+          , output = [[0, 0, 0], [1, 1, 1, 0], [2, 2, 2]]+          }+    , testProperty+        "resampleListPar shrink then grow"+        CellSimulation+          { cell = resampleListPar (sumC :: Cell Identity Int Int)+          , input = [[1, 1, 1], [1, 1], [1, 1, 1]]+          , output = [[0, 0, 0], [1, 1], [2, 2, 0]]+          }+    ]++data Stuff a = Stuff a deriving (Eq, Data)

@@ -1,5 +1,6 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RecordWildCards #-}+ module Feedback where  -- essence-of-live-coding@@ -18,30 +19,37 @@ import LiveCoding  constCell :: Monad m => Int -> Cell m () Int-constCell cellState = Cell-  { cellStep = \state _ -> return (state, state)-  , ..-  }+constCell cellState =+  Cell+    { cellStep = \state _ -> return (state, state)+    , ..+    } -test = testGroup "Feedback"-  [ testProperty "Migrates into feedback" CellMigrationSimulation-      { cell1 = constCell 23-      , cell2 = feedback [] $ proc ((), ns) -> do-          n <- constCell 42 -< ()-          returnA -< (sum ns, n : ns)-      , input1 = replicate 3 ()-      , input2 = replicate 3 ()-      , output1 = [23, 23, 23]-      , output2 = [0, 23, 46]-      }-  , testProperty "Migrates out of feedback" CellMigrationSimulation-      { cell1 = feedback [] $ proc ((), ns) -> do-          n <- constCell 23 -< ()-          returnA -< (sum ns, n : ns)-      , cell2 = constCell 42-      , input1 = replicate 3 ()-      , input2 = replicate 3 ()-      , output1 = [0, 23, 46]-      , output2 = [23, 23, 23]-      }-  ]+test =+  testGroup+    "Feedback"+    [ testProperty+        "Migrates into feedback"+        CellMigrationSimulation+          { cell1 = constCell 23+          , cell2 = feedback [] $ proc ((), ns) -> do+              n <- constCell 42 -< ()+              returnA -< (sum ns, n : ns)+          , input1 = replicate 3 ()+          , input2 = replicate 3 ()+          , output1 = [23, 23, 23]+          , output2 = [0, 23, 46]+          }+    , testProperty+        "Migrates out of feedback"+        CellMigrationSimulation+          { cell1 = feedback [] $ proc ((), ns) -> do+              n <- constCell 23 -< ()+              returnA -< (sum ns, n : ns)+          , cell2 = constCell 42+          , input1 = replicate 3 ()+          , input2 = replicate 3 ()+          , output1 = [0, 23, 46]+          , output2 = [23, 23, 23]+          }+    ]

@@ -5,12 +5,15 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-}+ module Handle where  -- base import Control.Arrow import Data.Functor import Data.Functor.Identity+import GHC.Natural (naturalToInteger)+import GHC.TypeNats (KnownNat, Nat, natVal)  -- transformers import Control.Monad.Trans.Class (lift)@@ -26,32 +29,32 @@ 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-      n <- get-      return $ "Handle #" ++ show n-  , destroy = const $ put 10000-  }+testHandle =+  Handle+    { create = do+        n <- get+        return $ "Handle #" ++ show n+    , destroy = const $ put 10000+    }  testUnitHandle :: Handle (State Int) ()-testUnitHandle = Handle-  { create = return ()-  , destroy = const $ put 20000-  }+testUnitHandle =+  Handle+    { create = return ()+    , destroy = const $ put 20000+    } -cellWithAction-  :: forall a b . State Int b-  -> Cell Identity a (String, Int)+cellWithAction ::+  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 { .. }+testParametrisedHandle = ParametrisedHandle {..}   where     createParametrised flag = do       n <- get@@ -60,13 +63,14 @@     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)+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)@@ -75,117 +79,149 @@   deriving (Eq, Show)  testTypelevelHandle :: KnownNat tag => Handle (State Int) (Tag tag)-testTypelevelHandle = Handle-  { create = return Tag-  , destroy = put . fromInteger . naturalToInteger . natVal-  }+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)+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)-    , cell2 = cellWithAction $ return ()-    , input1 = replicate 3 ()-    , input2 = replicate 3 ()-    , output1 = ("Handle #0", ) <$> [1, 2, 3]-    , output2 = ("Handle #0", ) <$> [3, 3, 3]-    }-  , testProperty "Initialise Handles upon migration" CellMigrationSimulation-    { cell1 = flip runStateC 0 $ constM $ modify (+ 1) >> return ""-    , cell2 = cellWithAction $ return ()-    , input1 = replicate 3 ()-    , input2 = replicate 3 ()-    , output1 = ("", ) <$> [1, 2, 3]-    , output2 = ("Handle #3", ) <$> [3, 3, 3]-    }-  , testProperty "Preserve Handles in more complex migration" CellMigrationSimulation-    { cell1 = flip runStateC 22-        $ constM (modify (+ 1)) >>> runHandlingStateC (handling testHandle)-    , cell2 = cellWithAction $ return ()-    , input1 = replicate 3 ()-    , input2 = replicate 3 ()-    , output1 = ("Handle #23", ) <$> [23, 24, 25]-    , output2 = ("Handle #23", ) <$> replicate 3 25-    }-  , testProperty "Reinitialise Handles in too complex migration" CellMigrationSimulation-    { cell1 = flip runStateC 22-        $   constM (modify (+ 1))-        >>> constM get >>> sumC >>> sumC-        >>> runHandlingStateC (handling testHandle)-    , cell2 = cellWithAction $ return ()-    , input1 = replicate 3 ()-    , input2 = replicate 3 ()-    , output1 = ("Handle #23", ) <$> [23, 24, 25]-    , output2 = ("Handle #25", ) <$> replicate 3 25-    }-  , testProperty "Doesn't crash when handle is introspected by migration" CellMigrationSimulation-    { cell1 = cellWithAction $ return ()-    , cell2 = flip runStateC 0 $ runHandlingStateC-        $ handling testUnitHandle >>> arr (const "")-    , input1 = replicate 3 ()-    , input2 = replicate 3 ()-    , output1 = ("Handle #0", ) <$> replicate 3 0-    , output2 = ("", ) <$> replicate 3 10000-    }-  , testProperty "Trigger destructors" CellMigrationSimulation-    { cell1 = cellWithAction $ return ()-    , cell2 = flip runStateC 23-        $ runHandlingStateC $ arr $ const "Done"-    , input1 = replicate 3 ()-    , 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-  ]+test =+  testGroup+    "Handle"+    [ testProperty+        "Preserve Handles"+        CellMigrationSimulation+          { cell1 = cellWithAction $ modify (+ 1)+          , cell2 = cellWithAction $ return ()+          , input1 = replicate 3 ()+          , input2 = replicate 3 ()+          , output1 = ("Handle #0",) <$> [1, 2, 3]+          , output2 = ("Handle #0",) <$> [3, 3, 3]+          }+    , testProperty+        "Initialise Handles upon migration"+        CellMigrationSimulation+          { cell1 = flip runStateC 0 $ constM $ modify (+ 1) >> return ""+          , cell2 = cellWithAction $ return ()+          , input1 = replicate 3 ()+          , input2 = replicate 3 ()+          , output1 = ("",) <$> [1, 2, 3]+          , output2 = ("Handle #3",) <$> [3, 3, 3]+          }+    , testProperty+        "Preserve Handles in more complex migration"+        CellMigrationSimulation+          { cell1 =+              flip runStateC 22 $+                constM (modify (+ 1)) >>> runHandlingStateC (handling testHandle)+          , cell2 = cellWithAction $ return ()+          , input1 = replicate 3 ()+          , input2 = replicate 3 ()+          , output1 = ("Handle #23",) <$> [23, 24, 25]+          , output2 = ("Handle #23",) <$> replicate 3 25+          }+    , testProperty+        "Reinitialise Handles in too complex migration"+        CellMigrationSimulation+          { cell1 =+              flip runStateC 22 $+                constM (modify (+ 1))+                  >>> constM get+                  >>> sumC+                  >>> sumC+                  >>> runHandlingStateC (handling testHandle)+          , cell2 = cellWithAction $ return ()+          , input1 = replicate 3 ()+          , input2 = replicate 3 ()+          , output1 = ("Handle #23",) <$> [23, 24, 25]+          , output2 = ("Handle #25",) <$> replicate 3 25+          }+    , testProperty+        "Doesn't crash when handle is introspected by migration"+        CellMigrationSimulation+          { cell1 = cellWithAction $ return ()+          , cell2 =+              flip runStateC 0 $+                runHandlingStateC $+                  handling testUnitHandle >>> arr (const "")+          , input1 = replicate 3 ()+          , input2 = replicate 3 ()+          , output1 = ("Handle #0",) <$> replicate 3 0+          , output2 = ("",) <$> replicate 3 10000+          }+    , testProperty+        "Trigger destructors"+        CellMigrationSimulation+          { cell1 = cellWithAction $ return ()+          , cell2 =+              flip runStateC 23 $+                runHandlingStateC $+                  arr $+                    const "Done"+          , input1 = replicate 3 ()+          , 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+    ]

@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-}+ module Handle.LiveProgram where  -- base@@ -8,7 +9,7 @@ import qualified Data.IntMap as IntMap  -- transformers-import Control.Monad.Trans.Class (MonadTrans(lift))+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@@ -25,32 +26,41 @@ import Util.LiveProgramMigration  testHandle :: Handle (RWS () [String] Int) String-testHandle = Handle-  { create = do-      n <- RWS.get-      let msg = "Handle #" ++ show n-      tell ["Creating " ++ msg]-      return msg-  , destroy = const $ tell ["Destroyed handle"]-  }--test = testGroup "Handle.LiveProgram"-  [ testProperty "Trigger destructors in live program" LiveProgramMigration-    { liveProgram1 = runHandlingState $ liveCell-        $ handling testHandle >>> arrM (lift . tell . return) >>> constM inspectHandlingState-    , 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+testHandle =+  Handle+    { create = do+        n <- RWS.get+        let msg = "Handle #" ++ show n+        tell ["Creating " ++ msg]+        return msg+    , destroy = const $ tell ["Destroyed handle"]     }-  ]-    where-      inspectHandlingState = do-        HandlingState { .. } <- get-        lift $ tell++test =+  testGroup+    "Handle.LiveProgram"+    [ testProperty+        "Trigger destructors in live program"+        LiveProgramMigration+          { liveProgram1 =+              runHandlingState $+                liveCell $+                  handling testHandle >>> arrM (lift . tell . return) >>> constM inspectHandlingState+          , 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+          }+    ]+  where+    inspectHandlingState = do+      HandlingState {..} <- get+      lift $+        tell           [ "Handles: " ++ show nHandles           , "Destructors: " ++ unwords (show . second isRegistered <$> IntMap.toList destructors)           ]

@@ -1,7 +1,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}  -- base import Control.Arrow@@ -20,6 +20,7 @@ import qualified Cell import qualified Feedback import qualified Handle+import qualified Migrate.NoMigration import qualified Monad import qualified Monad.Trans import qualified RuntimeIO.Launch@@ -37,85 +38,105 @@ main = defaultMain tests  tests =-  [ testGroup "Builtin types"-    [ testProperty "Same"-      $ \(x :: Integer) (y :: Integer) -> x === migrate y x-    , testProperty "Different"-      $ \(x :: Integer) (y :: Bool) -> y === migrate y x-    ]-  , testGroup "Product types"-    [ testProperty "Adds default field"-      $ Foo1.foo' === migrate Foo1.foo Foo2.foo-    , testProperty "Keeps only sensible field"-      $ Foo2.foo' === migrate Foo2.foo Foo1.foo-    ]-  , testGroup "Records"-    [ testProperty "Takes record field names into account"-      $ \barA barB barC barC2 barD-      -> Foo2.Bar { barC = barC2, .. } === migrate Foo2.Bar { barC = barC2, .. } Foo1.Bar { .. }-    , testProperty "Migrates nested records"-      $ Foo2.baz' === migrate Foo2.baz Foo1.baz-    ]-  , testGroup "Constructors"-    [ testProperty "Finds correct constructor"-      $ \x y z -> migrate (Foo2.Fooo z) (Foo1.Foo x y) === Foo2.Foo x-    , testProperty "Finds correct constructor with records"-      $ \barA barB barC baarA baarB -> migrate Foo2.Bar { .. } Foo1.Baar { .. } === Foo2.Baar { .. }-    ]-  , testGroup "User migration"-    [ testProperty "Can add migration from Int to Integer"-      $ Foo2.frob' === migrateWith (userMigration intToInteger) Foo2.frob Foo1.frob-    ]-  , testGroup "Newtypes"-    [ testProperty "Wraps into newtype"-      $ \(x :: Integer) -> Foo2.Frob x === migrate Foo2.frob x-    ]-  , testGroup "Debugging"-    [ testProperty "To debugging state"-      $ \(x :: Int) (y :: Int) (z :: Int)-      -> Debugging { dbgState = x, state = y } === migrate Debugging { dbgState = x, state = z } y-    , testProperty "From debugging state"-    $ \(x :: Int) (y :: Int) (z :: Int)-    -> x === migrate y Debugging { dbgState = z, state = x }-    ]-  , testGroup "Cells"-    [ testGroup "Sequential composition"-      [ testProperty "From 1" CellMigrationSimulation-          { cell1 = sumC >>> arr toInteger-          , cell2 = sumC >>> arr toInteger >>> sumC-          , input1 = [1, 1, 1] :: [Int]-          , input2 = [1, 1, 1]-          , output1 = [0, 1, 2]-          , output2 = [0, 3, 7]-          }+  [ testGroup+      "Builtin types"+      [ testProperty "Same" $+          \(x :: Integer) (y :: Integer) -> x === migrate y x+      , testProperty "Different" $+          \(x :: Integer) (y :: Bool) -> y === migrate y x       ]-    , testGroup "Choice"-      [ testProperty "From left" CellMigrationSimulation-        { cell1 = arr fromEither >>> sumC >>> arr toInteger-        , cell2 = (sumC >>> arr toInteger) ||| (arr toInteger >>> sumC)-        , input1 = [Left  1, Right 1, Left  (1 :: Int)]-        , input2 = [Right 1, Left  1, Right 1]-        , output1 = [0, 1, 2]-        , output2 = [0, 3, 1]-        }+  , testGroup+      "Product types"+      [ testProperty "Adds default field" $+          Foo1.foo' === migrate Foo1.foo Foo2.foo+      , testProperty "Keeps only sensible field" $+          Foo2.foo' === migrate Foo2.foo Foo1.foo       ]-    , testGroup "Control flow"-      [ testProperty "Into safe" CellMigrationSimulation-        { cell1 = countFrom 0-        , cell2 = safely $ do-            try $ countFrom 10  >>> throwIf (>  1) ()-            safe $ countFrom 20-        , input1 = replicate 3 ()-        , input2 = replicate 3 ()-        , output1 = [0, 1, 2]-        , output2 = [23, 24, 25]-        }+  , testGroup+      "Records"+      [ testProperty "Takes record field names into account" $+          \barA barB barC barC2 barD ->+            Foo2.Bar {barC = barC2, ..} === migrate Foo2.Bar {barC = barC2, ..} Foo1.Bar {..}+      , testProperty "Migrates nested records" $+          Foo2.baz' === migrate Foo2.baz Foo1.baz       ]-    , Cell.test-    , Handle.test-    , Monad.test-    , Feedback.test-    ]+  , testGroup+      "Constructors"+      [ testProperty "Finds correct constructor" $+          \x y z -> migrate (Foo2.Fooo z) (Foo1.Foo x y) === Foo2.Foo x+      , testProperty "Finds correct constructor with records" $+          \barA barB barC baarA baarB -> migrate Foo2.Bar {..} Foo1.Baar {..} === Foo2.Baar {..}+      , testProperty "Finds correct constructor if type doesn't change" $+          \(x :: Int) -> migrate Nothing (Just x) === Just x+      ]+  , testGroup+      "User migration"+      [ testProperty "Can add migration from Int to Integer" $+          Foo2.frob' === migrateWith (userMigration intToInteger) Foo2.frob Foo1.frob+      ]+  , testGroup+      "Newtypes"+      [ testProperty "Wraps into newtype" $+          \(x :: Integer) -> Foo2.Frob x === migrate Foo2.frob x+      ]+  , testGroup+      "Debugging"+      [ testProperty "To debugging state" $+          \(x :: Int) (y :: Int) (z :: Int) ->+            Debugging {dbgState = x, state = y} === migrate Debugging {dbgState = x, state = z} y+      , testProperty "From debugging state" $+          \(x :: Int) (y :: Int) (z :: Int) ->+            x === migrate y Debugging {dbgState = z, state = x}+      ]+  , testGroup+      "Cells"+      [ testGroup+          "Sequential composition"+          [ testProperty+              "From 1"+              CellMigrationSimulation+                { cell1 = sumC >>> arr toInteger+                , cell2 = sumC >>> arr toInteger >>> sumC+                , input1 = [1, 1, 1] :: [Int]+                , input2 = [1, 1, 1]+                , output1 = [0, 1, 2]+                , output2 = [0, 3, 7]+                }+          ]+      , testGroup+          "Choice"+          [ testProperty+              "From left"+              CellMigrationSimulation+                { cell1 = arr fromEither >>> sumC >>> arr toInteger+                , cell2 = (sumC >>> arr toInteger) ||| (arr toInteger >>> sumC)+                , input1 = [Left 1, Right 1, Left (1 :: Int)]+                , input2 = [Right 1, Left 1, Right 1]+                , output1 = [0, 1, 2]+                , output2 = [0, 3, 1]+                }+          ]+      , testGroup+          "Control flow"+          [ testProperty+              "Into safe"+              CellMigrationSimulation+                { cell1 = countFrom 0+                , cell2 = safely $ do+                    try $ countFrom 10 >>> throwIf (> 1) ()+                    safe $ countFrom 20+                , input1 = replicate 3 ()+                , input2 = replicate 3 ()+                , output1 = [0, 1, 2]+                , output2 = [23, 24, 25]+                }+          ]+      , Cell.test+      , Handle.test+      , Migrate.NoMigration.test+      , Monad.test+      , Feedback.test+      ]   , Monad.Trans.test   , RuntimeIO.Launch.test   ]@@ -123,5 +144,5 @@ countFrom :: Monad m => Int -> Cell m () Int countFrom n = arr (const 1) >>> sumC >>> arr (+ n) -fromEither (Left  a) = a+fromEither (Left a) = a fromEither (Right a) = a

@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++module Migrate.NoMigration where++-- base+import Control.Arrow (Arrow (arr), (>>>))+import Data.Data (Data)+import Data.Maybe (fromJust)++-- test-framework+import Test.Framework (testGroup)++-- test-framework-quickcheck2+import Test.Framework.Providers.QuickCheck2 (testProperty)++-- essence-of-live-coding++import qualified LiveCoding.Migrate.NoMigration as NoMigration+import Util++data Stuff a = Stuff a deriving (Eq, Data)++test =+  testGroup+    "NoMigration unit tests"+    [ testProperty+        "LiveCoding.Migrate.NoMigration.delay migrates correctly to itself"+        CellMigrationSimulation+          { cell1 = NoMigration.delay 0+          , cell2 = NoMigration.delay 0+          , input1 = [1 :: Int, 2, 3, 4]+          , input2 = [5 :: Int, 6, 7, 8]+          , output1 = [0, 1, 2, 3]+          , output2 = [4, 5, 6, 7]+          }+    , testProperty+        "LiveCoding.Migrate.NoMigration.delay different type will not migrate"+        CellMigrationSimulation+          { cell1 = NoMigration.delay 0+          , cell2 = arr Stuff >>> NoMigration.delay (Stuff 99) >>> arr (\(Stuff a) -> a)+          , input1 = [1 :: Int, 2, 3, 4]+          , input2 = [10 :: Int, 10, 10, 10]+          , output1 = [0, 1, 2, 3]+          , output2 = [99, 10, 10, 10]+          }+    ]

@@ -13,11 +13,14 @@ -- test-framework-quickcheck2 import Test.Framework.Providers.QuickCheck2 -test = testProperty "State effect" CellMigrationSimulation-  { cell1 = flip runStateC (0 :: Int) $ constM (modify (+ 1))-  , cell2 = flip runStateC 23 $ constM (modify (+ 2))-  , input1 = [(), (), ()]-  , input2 = [(), (), ()]-  , output1 = [((), 1), ((), 2), ((), 3)]-  , output2 = [((), 5), ((), 7), ((), 9)]-  }+test =+  testProperty+    "State effect"+    CellMigrationSimulation+      { cell1 = flip runStateC (0 :: Int) $ constM (modify (+ 1))+      , cell2 = flip runStateC 23 $ constM (modify (+ 2))+      , input1 = [(), (), ()]+      , input2 = [(), (), ()]+      , output1 = [((), 1), ((), 2), ((), 3)]+      , output2 = [((), 5), ((), 7), ((), 9)]+      }

@@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+ module Monad.Trans where  -- test-framework@@ -13,13 +14,15 @@  -- essence-of-live-coding import LiveCoding-import LiveCoding.Cell.Monad.Trans (State(State))+import LiveCoding.Cell.Monad.Trans (State (State)) -test = testGroup "Monad.Trans"-  [ testProperty "Migrates into runStateL"-    $ \(stateT :: Int) (stateInternal :: Int)-      -> State { .. } === migrate State { stateInternal = 23, .. } stateInternal-  , testProperty "Migrates from runStateL"-    $ \(stateT :: Int) (stateInternal :: Int)-      -> stateInternal === migrate 42 State { .. }-  ]+test =+  testGroup+    "Monad.Trans"+    [ testProperty "Migrates into runStateL" $+        \(stateT :: Int) (stateInternal :: Int) ->+          State {..} === migrate State {stateInternal = 23, ..} stateInternal+    , testProperty "Migrates from runStateL" $+        \(stateT :: Int) (stateInternal :: Int) ->+          stateInternal === migrate 42 State {..}+    ]

@@ -10,14 +10,16 @@ import Test.Framework.Providers.HUnit  -- essence-of-live-coding-import LiveCoding+ import Control.Concurrent (threadDelay)+import LiveCoding  loggingHandle :: IORef [String] -> Handle IO ()-loggingHandle ref = Handle-  { create = modifyIORef ref ("Created handle" :)-  , destroy = const $ modifyIORef ref ("Destroyed handle" :)-  }+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

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+ module TestData.Foo1 where  -- base@@ -13,21 +14,22 @@  data Bar   = Bar-  { barA :: Integer-  , barD :: Integer-  , barC :: Bool-  }+      { barA :: Integer+      , barD :: Integer+      , barC :: Bool+      }   | Baar-  { baarB :: Bool-  , baarA :: Int-  }+      { baarB :: Bool+      , baarA :: Int+      }   deriving (Show, Eq, Typeable, Data) -bar = Bar-  { barA = 23-  , barD = 5-  , barC = True-  }+bar =+  Bar+    { barA = 23+    , barD = 5+    , barC = True+    }  data Baz = Baz   { bazFoo :: Foo

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-}+ module TestData.Foo2 where  -- base@@ -7,7 +8,7 @@  data Foo   = Fooo Integer-  | Foo  Integer+  | Foo Integer   deriving (Show, Eq, Typeable, Data)  foo = Foo 2@@ -15,26 +16,28 @@  data Bar   = Bar-  { barB :: Integer-  , barA :: Integer-  , barC :: String-  }+      { barB :: Integer+      , barA :: Integer+      , barC :: String+      }   | Baar-  { baarA :: Int-  }+      { baarA :: Int+      }   deriving (Show, Eq, Typeable, Data) -bar = Bar-  { barB = 42-  , barA = 100-  , barC = "Bar"-  }+bar =+  Bar+    { barB = 42+    , barA = 100+    , barC = "Bar"+    } -bar' = Bar-  { barB = 42-  , barA = 23-  , barC = "Bar"-  }+bar' =+  Bar+    { barB = 42+    , barA = 23+    , barC = "Bar"+    }  data Baz = Baz   { bazBar :: Bar@@ -48,5 +51,5 @@ data Frob = Frob Integer   deriving (Show, Eq, Typeable, Data) -frob  = Frob 2+frob = Frob 2 frob' = Frob 1

@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-}+ module Util where  -- base@@ -37,14 +38,15 @@   }  instance (Eq b, Show b) => Testable (CellMigrationSimulation a b) where-  property CellMigrationSimulation { .. }-    = let Identity (output1', output2') = simulateCellMigration cell1 cell2 input1 input2-      in output1 === output1' .&&. output2 === output2'+  property CellMigrationSimulation {..} =+    let Identity (output1', output2') = simulateCellMigration cell1 cell2 input1 input2+     in output1 === output1' .&&. output2 === output2' --- | Step the first cell with the first input,---   migrate it to the second cell,---   and step the migration result with the second input.---   Return both outputs.+{- | Step the first cell with the first input,+   migrate it to the second cell,+   and step the migration result with the second input.+   Return both outputs.+-} simulateCellMigration :: Monad m => Cell m a b -> Cell m a b -> [a] -> [a] -> m ([b], [b]) simulateCellMigration cell1 cell2 as1 as2 = do   (bs1, cell1') <- steps cell1 as1@@ -64,8 +66,9 @@ inIdentityT :: Cell Identity a prop -> Cell Identity a prop inIdentityT = id --- | Basic unit test for 'Cell's.---   Check whether a given 'input' to your 'cell' results in a given 'output'.+{- | Basic unit test for 'Cell's.+   Check whether a given 'input' to your 'cell' results in a given 'output'.+-} data CellSimulation a b = CellSimulation   { cell :: Cell Identity a b   , input :: [a]@@ -73,11 +76,13 @@   }  instance (Eq b, Show b) => Testable (CellSimulation a b) where-  property CellSimulation { .. } = property CellMigrationSimulation-    { cell1 = cell-    , cell2 = cell-    , input1 = input-    , input2 = []-    , output1 = output-    , output2 = []-    }+  property CellSimulation {..} =+    property+      CellMigrationSimulation+        { cell1 = cell+        , cell2 = cell+        , input1 = input+        , input2 = []+        , output1 = output+        , output2 = []+        }

@@ -1,9 +1,10 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RecordWildCards #-}+ module Util.LiveProgramMigration where  -- transformers-import Control.Monad.Trans.RWS.Strict (runRWS, RWS)+import Control.Monad.Trans.RWS.Strict (RWS, runRWS)  -- QuickCheck import Test.QuickCheck@@ -11,7 +12,8 @@ -- essence-of-live-coding import LiveCoding -data LiveProgramMigration a b = forall s . LiveProgramMigration+data LiveProgramMigration a b = forall s.+  LiveProgramMigration   { liveProgram1 :: LiveProgram (RWS a b s)   , liveProgram2 :: LiveProgram (RWS a b s)   , initialState :: s@@ -28,14 +30,14 @@ stepsLiveProgramRWS liveProg s [] = (liveProg, s, []) stepsLiveProgramRWS liveProg s (a : as) =   let (liveProg', s', b) = stepLiveProgramRWS liveProg a s-  in (liveProg', s', b : third (stepsLiveProgramRWS liveProg' s' as))+   in (liveProg', s', b : third (stepsLiveProgramRWS liveProg' s' as))  third :: (a, b, c) -> c third (a, b, c) = c  instance (Monoid b, Eq b, Show b) => Testable (LiveProgramMigration a b) where-  property LiveProgramMigration { .. } =+  property LiveProgramMigration {..} =     let (liveProg', s', output1') = stepsLiveProgramRWS liveProgram1 initialState input1         liveProg2 = hotCodeSwap liveProgram2 liveProg'         (_, _, output2') = stepsLiveProgramRWS liveProg2 s' input2-    in output1 === output1' .&&. output2 === output2'+     in output1 === output1' .&&. output2 === output2'