diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Revision history for essence-of-live-coding +## 0.2.4 + +* Extended testing utilities +* Extended LiveCoding.Cell.Util by buffer, edge, boundedFIFO and other utilities + ## 0.2.3 * Added printTimeC debugging utility 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.3 +version: 0.2.4 synopsis: General purpose live coding framework description: essence-of-live-coding is a general purpose and type safe live coding framework. @@ -93,7 +93,10 @@ type: exitcode-stdio-1.0 main-is: Main.hs other-modules: - Feedback + Cell + , Cell.Monad.Trans + , Cell.Util + , Feedback , Handle , Handle.LiveProgram , Monad diff --git a/src/LiveCoding/Cell/Feedback.lhs b/src/LiveCoding/Cell/Feedback.lhs --- a/src/LiveCoding/Cell/Feedback.lhs +++ b/src/LiveCoding/Cell/Feedback.lhs @@ -77,25 +77,3 @@ sumFeedback = feedback 0 $ arr $ \(a, accum) -> (accum, a + accum) \end{code} - -\fxerror{Mention keepJust and keep} -\begin{comment} -\begin{code} -keepJust - :: (Monad m, Data a) - => Cell m (Maybe a) (Maybe a) -keepJust = feedback Nothing $ arr keep - where - keep (Nothing, Nothing) = (Nothing, Nothing) - keep (_, Just a) = (Just a, Just a) - keep (Just a, Nothing) = (Just a, Just a) - --- | Initialise with a value 'a'. --- If the input is 'Nothing', @keep a@ will output the stored indefinitely. --- A new value can be stored by inputting 'Maybe a'. -keep :: (Data a, Monad m) => a -> Cell m (Maybe a) a -keep a = feedback a $ proc (ma, aOld) -> do - let aNew = fromMaybe aOld ma - returnA -< (aNew, aNew) -\end{code} -\end{comment} 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 @@ -6,7 +6,13 @@ import Control.Arrow import Control.Monad.IO.Class import Data.Data (Data) +import Data.Functor (void) +import Data.Maybe +-- containers +import Data.Sequence hiding (take) +import qualified Data.Sequence as Sequence + -- time import Data.Time.Clock @@ -14,6 +20,8 @@ import LiveCoding.Cell import LiveCoding.Cell.Feedback +-- * State accumulation + -- | Sum all past inputs, starting by the given number sumFrom :: Monad m => Integer -> Cell m Integer Integer sumFrom n0 = feedback n0 $ proc (n, acc) -> returnA -< (acc, acc + n) @@ -31,6 +39,43 @@ 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 { .. } + where + cellStep b a = let b' = step a b in return (b', b') + +-- | Initialise with a value 'a'. +-- If the input is 'Nothing', @keep a@ will output the stored indefinitely. +-- A new value can be stored by inputting 'Maybe a'. +keep :: (Data a, Monad m) => a -> Cell m (Maybe a) a +keep a = feedback a $ proc (ma, aOld) -> do + let aNew = fromMaybe aOld ma + returnA -< (aNew, aNew) + +-- | Like 'keep', but returns 'Nothing' until it is initialised by a @'Just' a@ value. +keepJust + :: (Monad m, Data a) + => Cell m (Maybe a) (Maybe a) +keepJust = feedback Nothing $ arr keep + where + keep (Nothing, Nothing) = (Nothing, Nothing) + keep (_, Just a) = (Just a, Just a) + keep (Just a, Nothing) = (Just a, Just a) + +-- | @boundedFIFO n@ keeps the first @n@ present values. +boundedFIFO :: (Data a, Monad m) => Int -> Cell m (Maybe a) (Seq a) +boundedFIFO n = foldC' step empty + where + step Nothing as = as + step (Just a) as = Sequence.take n $ a <| as + +-- | Returns 'True' iff the current input value is 'True' and the last input value was 'False'. +edge :: Monad m => Cell m Bool Bool +edge = proc b -> do + bLast <- delay False -< b + returnA -< b && not bLast + -- * Debugging utilities -- | Print the current UTC time, prepended with the first 8 characters of the given message. @@ -40,3 +85,60 @@ -- | Like 'printTime', but as a cell. printTimeC :: MonadIO m => String -> Cell m () () printTimeC msg = constM $ printTime msg + +-- * Buffers + +-- | 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. + +-- | Pushes @'Just' a@ and does nothing on 'Nothing'. +maybePush :: Maybe a -> [BufferCommand a] +maybePush = (Push <$>) . maybeToList + +-- | Pops on @'Just' a@ and does nothing on 'Nothing'. +maybePop :: Maybe a -> [BufferCommand b] +maybePop = (const Pop <$>) . maybeToList + +{- | Single-consumer, multi-producer buffer. + +The output value is the oldest value in the buffer, +if it exists. + +* Add elements by inputting @'Push' a@. +* Remove elements by inputting 'Pop'. +-} +buffer :: (Monad m, Data a) => Cell m [BufferCommand a] (Maybe a) +buffer = Cell { .. } + where + cellState = empty + cellStep as commands = return (currentHead as, nextBuffer as commands) + currentHead as = case viewl as of + EmptyL -> Nothing + a :< as' -> Just a + nextBuffer as [] = as + nextBuffer as (Push a : commands) = nextBuffer (as |> a) commands + nextBuffer as (Pop : commands) = nextBuffer (Sequence.drop 1 as) commands + +{- | Equip a 'Cell' with a 'buffer'. + +* Whenever @'Just' a@ value enters @buffered cell@, + it is added to the buffer. +* Whenever @cell@ emits @'Just' b@, + the oldest value is dropped from the buffer. +* @cell@ is always fed with 'Just' the oldest value from the buffer, + except when the buffer is empty, then it is fed 'Nothing'. + +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 cell = feedback Nothing $ proc (aMaybe, ticked) -> do + aMaybe' <- buffer -< maybePop ticked ++ maybePush aMaybe + bMaybe' <- cell -< aMaybe' + returnA -< (bMaybe', void bMaybe') diff --git a/test/Cell.hs b/test/Cell.hs new file mode 100644 --- /dev/null +++ b/test/Cell.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Cell where + +-- base +import Prelude hiding (id) +import Control.Category +import Data.Functor.Identity + +-- transformers +import Control.Monad.Trans.Identity + +-- test-framework +import Test.Framework + +-- test-framework-quickcheck2 +import Test.Framework.Providers.QuickCheck2 + +-- QuickCheck +import Test.QuickCheck + +-- essence-of-live-coding +import LiveCoding + +import qualified Cell.Util +import qualified Cell.Monad.Trans + +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 + ] diff --git a/test/Cell/Monad/Trans.hs b/test/Cell/Monad/Trans.hs new file mode 100644 --- /dev/null +++ b/test/Cell/Monad/Trans.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Cell.Monad.Trans where + +-- transformers +import Control.Monad.Trans.Reader + +-- test-framework +import Test.Framework + +-- test-framework-quickcheck2 +import Test.Framework.Providers.QuickCheck2 + +-- QuickCheck +import Test.QuickCheck hiding (output) + +-- essence-of-live-coding +import LiveCoding + +import Util + +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 new file mode 100644 --- /dev/null +++ b/test/Cell/Util.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Cell.Util where + +-- base +import qualified Control.Category as C +import Data.Functor.Identity +import Data.Maybe +import Control.Monad + +-- transformers +import Control.Monad.Trans.Reader + +-- test-framework +import Test.Framework + +-- test-framework-quickcheck2 +import Test.Framework.Providers.QuickCheck2 + +-- QuickCheck +import Test.QuickCheck hiding (output) + +-- essence-of-live-coding +import LiveCoding + +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 + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -17,14 +17,17 @@ import Test.QuickCheck -- essence-of-live-coding +import qualified Cell import qualified Feedback import qualified Handle import qualified Monad +import qualified Monad.Trans + import LiveCoding -import qualified Monad.Trans import qualified TestData.Foo1 as Foo1 import qualified TestData.Foo2 as Foo2 + import Util intToInteger :: Int -> Integer @@ -107,6 +110,7 @@ , output2 = [23, 24, 25] } ] + , Cell.test , Handle.test , Monad.test , Feedback.test diff --git a/test/Monad/Trans.hs b/test/Monad/Trans.hs --- a/test/Monad/Trans.hs +++ b/test/Monad/Trans.hs @@ -20,6 +20,6 @@ $ \(stateT :: Int) (stateInternal :: Int) -> State { .. } === migrate State { stateInternal = 23, .. } stateInternal , testProperty "Migrates from runStateL" - $ \(stateT :: Int) (stateInternal :: Int) - -> stateInternal === migrate 42 State { .. } + $ \(stateT :: Int) (stateInternal :: Int) + -> stateInternal === migrate 42 State { .. } ] diff --git a/test/Util.hs b/test/Util.hs --- a/test/Util.hs +++ b/test/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} module Util where @@ -50,3 +51,33 @@ let cell2' = hotCodeSwapCell cell2 cell1' (bs2, _) <- steps cell2' as2 return (bs1, bs2) + +-- FIXME move to essence-of-live-coding-quickcheck +-- https://github.com/turion/essence-of-live-coding/issues/36 +instance (Arbitrary a, Testable prop) => Testable (Cell Identity a prop) where + property cell = property $ do + as <- arbitrary + let (props, _) = runIdentity $ steps cell as + return $ conjoin props + +-- | Helper to unify cells to the 'Identity' monad. +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'. +data CellSimulation a b = CellSimulation + { cell :: Cell Identity a b + , input :: [a] + , output :: [b] + } + +instance (Eq b, Show b) => Testable (CellSimulation a b) where + property CellSimulation { .. } = property CellMigrationSimulation + { cell1 = cell + , cell2 = cell + , input1 = input + , input2 = [] + , output1 = output + , output2 = [] + }