diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/app/TestExceptions.hs b/app/TestExceptions.hs --- a/app/TestExceptions.hs +++ b/app/TestExceptions.hs @@ -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 ()) diff --git a/app/TestNonBlocking.hs b/app/TestNonBlocking.hs --- a/app/TestNonBlocking.hs +++ b/app/TestNonBlocking.hs @@ -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 diff --git a/essence-of-live-coding.cabal b/essence-of-live-coding.cabal --- a/essence-of-live-coding.cabal +++ b/essence-of-live-coding.cabal @@ -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 diff --git a/src/LiveCoding.hs b/src/LiveCoding.hs --- a/src/LiveCoding.hs +++ b/src/LiveCoding.hs @@ -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) diff --git a/src/LiveCoding/Cell/HotCodeSwap.hs b/src/LiveCoding/Cell/HotCodeSwap.hs --- a/src/LiveCoding/Cell/HotCodeSwap.hs +++ b/src/LiveCoding/Cell/HotCodeSwap.hs @@ -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 + } diff --git a/src/LiveCoding/Cell/Monad.hs b/src/LiveCoding/Cell/Monad.hs --- a/src/LiveCoding/Cell/Monad.hs +++ b/src/LiveCoding/Cell/Monad.hs @@ -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 diff --git a/src/LiveCoding/Cell/Monad/Trans.hs b/src/LiveCoding/Cell/Monad/Trans.hs --- a/src/LiveCoding/Cell/Monad/Trans.hs +++ b/src/LiveCoding/Cell/Monad/Trans.hs @@ -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 diff --git a/src/LiveCoding/Cell/NonBlocking.hs b/src/LiveCoding/Cell/NonBlocking.hs --- a/src/LiveCoding/Cell/NonBlocking.hs +++ b/src/LiveCoding/Cell/NonBlocking.hs @@ -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. diff --git a/src/LiveCoding/Cell/Resample.hs b/src/LiveCoding/Cell/Resample.hs --- a/src/LiveCoding/Cell/Resample.hs +++ b/src/LiveCoding/Cell/Resample.hs @@ -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) diff --git a/src/LiveCoding/Cell/Util.hs b/src/LiveCoding/Cell/Util.hs --- a/src/LiveCoding/Cell/Util.hs +++ b/src/LiveCoding/Cell/Util.hs @@ -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 diff --git a/src/LiveCoding/Cell/Util/Internal.hs b/src/LiveCoding/Cell/Util/Internal.hs --- a/src/LiveCoding/Cell/Util/Internal.hs +++ b/src/LiveCoding/Cell/Util/Internal.hs @@ -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 diff --git a/src/LiveCoding/Debugger/StatePrint.hs b/src/LiveCoding/Debugger/StatePrint.hs --- a/src/LiveCoding/Debugger/StatePrint.hs +++ b/src/LiveCoding/Debugger/StatePrint.hs @@ -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} diff --git a/src/LiveCoding/External.hs b/src/LiveCoding/External.hs --- a/src/LiveCoding/External.hs +++ b/src/LiveCoding/External.hs @@ -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) diff --git a/src/LiveCoding/GHCi.hs b/src/LiveCoding/GHCi.hs --- a/src/LiveCoding/GHCi.hs +++ b/src/LiveCoding/GHCi.hs @@ -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" diff --git a/src/LiveCoding/Handle.hs b/src/LiveCoding/Handle.hs --- a/src/LiveCoding/Handle.hs +++ b/src/LiveCoding/Handle.hs @@ -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 + } diff --git a/src/LiveCoding/Handle/Examples.hs b/src/LiveCoding/Handle/Examples.hs --- a/src/LiveCoding/Handle/Examples.hs +++ b/src/LiveCoding/Handle/Examples.hs @@ -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 + } diff --git a/src/LiveCoding/HandlingState.hs b/src/LiveCoding/HandlingState.hs --- a/src/LiveCoding/HandlingState.hs +++ b/src/LiveCoding/HandlingState.hs @@ -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" diff --git a/src/LiveCoding/LiveProgram/Except.hs b/src/LiveCoding/LiveProgram/Except.hs --- a/src/LiveCoding/LiveProgram/Except.hs +++ b/src/LiveCoding/LiveProgram/Except.hs @@ -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 diff --git a/src/LiveCoding/LiveProgram/Monad/Trans.hs b/src/LiveCoding/LiveProgram/Monad/Trans.hs --- a/src/LiveCoding/LiveProgram/Monad/Trans.hs +++ b/src/LiveCoding/LiveProgram/Monad/Trans.hs @@ -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 {..} + } diff --git a/src/LiveCoding/Migrate/Cell.hs b/src/LiveCoding/Migrate/Cell.hs --- a/src/LiveCoding/Migrate/Cell.hs +++ b/src/LiveCoding/Migrate/Cell.hs @@ -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 diff --git a/src/LiveCoding/Migrate/Debugger.hs b/src/LiveCoding/Migrate/Debugger.hs --- a/src/LiveCoding/Migrate/Debugger.hs +++ b/src/LiveCoding/Migrate/Debugger.hs @@ -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 diff --git a/src/LiveCoding/Migrate/Migration.hs b/src/LiveCoding/Migrate/Migration.hs --- a/src/LiveCoding/Migrate/Migration.hs +++ b/src/LiveCoding/Migrate/Migration.hs @@ -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 diff --git a/src/LiveCoding/Migrate/Monad/Trans.hs b/src/LiveCoding/Migrate/Monad/Trans.hs --- a/src/LiveCoding/Migrate/Monad/Trans.hs +++ b/src/LiveCoding/Migrate/Monad/Trans.hs @@ -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 diff --git a/src/LiveCoding/Migrate/NoMigration.hs b/src/LiveCoding/Migrate/NoMigration.hs new file mode 100644 --- /dev/null +++ b/src/LiveCoding/Migrate/NoMigration.hs @@ -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 diff --git a/src/LiveCoding/Preliminary/CellExcept/Applicative.lhs b/src/LiveCoding/Preliminary/CellExcept/Applicative.lhs --- a/src/LiveCoding/Preliminary/CellExcept/Applicative.lhs +++ b/src/LiveCoding/Preliminary/CellExcept/Applicative.lhs @@ -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 diff --git a/src/LiveCoding/RuntimeIO/Launch.hs b/src/LiveCoding/RuntimeIO/Launch.hs --- a/src/LiveCoding/RuntimeIO/Launch.hs +++ b/src/LiveCoding/RuntimeIO/Launch.hs @@ -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 diff --git a/test/Cell.hs b/test/Cell.hs --- a/test/Cell.hs +++ b/test/Cell.hs @@ -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 + ] diff --git a/test/Cell/Monad/Trans.hs b/test/Cell/Monad/Trans.hs --- a/test/Cell/Monad/Trans.hs +++ b/test/Cell/Monad/Trans.hs @@ -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 + ] diff --git a/test/Cell/Util.hs b/test/Cell/Util.hs --- a/test/Cell/Util.hs +++ b/test/Cell/Util.hs @@ -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) diff --git a/test/Feedback.hs b/test/Feedback.hs --- a/test/Feedback.hs +++ b/test/Feedback.hs @@ -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] + } + ] diff --git a/test/Handle.hs b/test/Handle.hs --- a/test/Handle.hs +++ b/test/Handle.hs @@ -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 + ] diff --git a/test/Handle/LiveProgram.hs b/test/Handle/LiveProgram.hs --- a/test/Handle/LiveProgram.hs +++ b/test/Handle/LiveProgram.hs @@ -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) ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 diff --git a/test/Migrate/NoMigration.hs b/test/Migrate/NoMigration.hs new file mode 100644 --- /dev/null +++ b/test/Migrate/NoMigration.hs @@ -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] + } + ] diff --git a/test/Monad.hs b/test/Monad.hs --- a/test/Monad.hs +++ b/test/Monad.hs @@ -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)] + } diff --git a/test/Monad/Trans.hs b/test/Monad/Trans.hs --- a/test/Monad/Trans.hs +++ b/test/Monad/Trans.hs @@ -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 {..} + ] diff --git a/test/RuntimeIO/Launch.hs b/test/RuntimeIO/Launch.hs --- a/test/RuntimeIO/Launch.hs +++ b/test/RuntimeIO/Launch.hs @@ -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 diff --git a/test/TestData/Foo1.hs b/test/TestData/Foo1.hs --- a/test/TestData/Foo1.hs +++ b/test/TestData/Foo1.hs @@ -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 diff --git a/test/TestData/Foo2.hs b/test/TestData/Foo2.hs --- a/test/TestData/Foo2.hs +++ b/test/TestData/Foo2.hs @@ -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 diff --git a/test/Util.hs b/test/Util.hs --- a/test/Util.hs +++ b/test/Util.hs @@ -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 = [] + } diff --git a/test/Util/LiveProgramMigration.hs b/test/Util/LiveProgramMigration.hs --- a/test/Util/LiveProgramMigration.hs +++ b/test/Util/LiveProgramMigration.hs @@ -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'