essence-of-live-coding 0.2.1 → 0.2.2

raw patch · 9 files changed

+177/−179 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• essence-of-live-coding.cabal +4/−3
• src/LiveCoding/Cell.lhs +17/−16
• src/LiveCoding/Cell/Feedback.lhs +8/−11
• src/LiveCoding/Cell/Util.hs +11/−0
• src/LiveCoding/Debugger/StatePrint.hs +5/−5
• src/LiveCoding/Migrate/Cell.hs +78/−143
• test/Feedback.hs +47/−0
• test/Main.hs +3/−1

@@ -1,5 +1,9 @@ # Revision history for essence-of-live-coding +## 0.2.2++* Added feedback migration+ ## 0.2.1  * Adapted pulse backend to handles and refactored

@@ -1,5 +1,5 @@ name:                essence-of-live-coding-version:             0.2.1+version:             0.2.2 synopsis: General purpose live coding framework description:   essence-of-live-coding is a general purpose and type safe live coding framework.@@ -30,7 +30,7 @@ source-repository this   type:     git   location: git@github.com:turion/essence-of-live-coding.git-  tag:      v0.2.1+  tag:      v0.2.2   library@@ -92,7 +92,8 @@   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:-      Handle+      Feedback+    , Handle     , Handle.LiveProgram     , Monad     , Monad.Trans

@@ -215,13 +215,12 @@  \begin{comment} \begin{code}--- TODO For some weird reason, this is more efficient than my own ADT-newtype Composition state1 state2 = Composition (state1, state2)+data Composition state1 state2 = Composition+  { state1 :: state1+  , state2 :: state2+  }   deriving Data -getState2 :: Composition state1 state2 -> state2-getState2 (Composition (state1, state2)) = state2- instance Monad m => Category (Cell m) where   id = ArrM return @@ -236,11 +235,11 @@     }   Cell state2 step2 . Cell state1 step1 = Cell { .. }     where-      cellState = Composition (state1, state2)-      cellStep (Composition (state1, state2)) a = do+      cellState = Composition state1 state2+      cellStep (Composition state1 state2) a = do         (!b, state1') <- step1 state1 a         (!c, state2') <- step2 state2 b-        return (c, Composition (state1', state2'))+        return (c, Composition state1' state2') -- {-# RULES -- "arrM/>>>" forall (f :: forall a b m . Monad m => a -> m b) g . arrM f >>> arrM g = arrM (f >=> g) -- #-} -- Don't really need rules here because GHC will inline all that anyways@@ -372,8 +371,10 @@  \begin{comment} \begin{code}---data Parallel s1 s2 = Parallel s1 s2-newtype Parallel s1 s2 = Parallel (s1, s2)+data Parallel stateP1 stateP2 = Parallel+  { stateP1 :: stateP1+  , stateP2 :: stateP2+  }   deriving Data  instance Monad m => Arrow (Cell m) where@@ -401,13 +402,13 @@       return ((b, d), state')     , ..     }-  Cell state1 step1 *** Cell state2 step2 = Cell { .. }+  Cell stateP1 step1 *** Cell stateP2 step2 = Cell { .. }     where-      cellState = Parallel (state1, state2)-      cellStep (Parallel (state1, state2)) (a, c) = do-        (!b, state1') <- step1 state1 a-        (!d, state2') <- step2 state2 c-        return ((b, d), Parallel (state1', state2'))+      cellState = Parallel { .. }+      cellStep (Parallel { .. }) (a, c) = do+        (!b, stateP1') <- step1 stateP1 a+        (!d, stateP2') <- step2 stateP2 c+        return ((b, d), Parallel stateP1' stateP2')  arrM :: (a -> m b) -> Cell m a b arrM = ArrM

@@ -30,12 +30,12 @@   -> Cell   m    a      b \end{code} Let us have a look at its internal state:-\begin{spec}+\begin{code} data Feedback sPrevious sAdditional = Feedback   { sPrevious   :: sPrevious   , sAdditional :: sAdditional-  }-\end{spec}+  } deriving Data+\end{code} In \mintinline{haskell}{feedback sAdditional cell}, the \mintinline{haskell}{cell} has state \mintinline{haskell}{sPrevious}, and to this state we add \mintinline{haskell}{sAdditional}.@@ -50,15 +50,12 @@ \fxwarning{Possibly remark on Data instance of s?} \begin{comment} \begin{code}-newtype Feedback s s' = Feedback (s, s')-  deriving Data--feedback s (Cell state step) = Cell { .. }+feedback sAdditional (Cell sPrevious step) = Cell { .. }   where-    cellState = Feedback (state, s)-    cellStep (Feedback (state, s)) a = do-      ((!b, !s'), state') <- step state (a, s)-      return (b, Feedback (state', s'))+    cellState = Feedback { .. }+    cellStep Feedback { .. } a = do+      ((!b, !sAdditional'), sPrevious') <- step sPrevious (a, sAdditional)+      return (b, Feedback sPrevious' sAdditional') feedback cellState (ArrM f) = Cell { .. }   where     cellStep state a = f (a, state)

@@ -1,8 +1,10 @@ {-# LANGUAGE Arrows #-}+{-# LANGUAGE RecordWildCards #-} module LiveCoding.Cell.Util where  -- base import Control.Arrow+import Data.Data (Data)  -- essence-of-live-coding import LiveCoding.Cell@@ -15,3 +17,12 @@ -- | Count the number of ticks, starting at 0 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.+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')

@@ -47,19 +47,19 @@ 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` (\(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))+compositionShow (Composition s1 s2)   | isUnit s1 = stateShow s2   | isUnit s2 = stateShow s1   | otherwise = stateShow s1 ++ " >>> " ++ stateShow s2  -- TODO Would be cooler if this was multiline parallelShow :: (Data s1, Data s2) => Parallel s1 s2 -> String-parallelShow (Parallel (s1, s2))+parallelShow (Parallel s1 s2)   | isUnit s1 = stateShow s2   | isUnit s2 = stateShow s1   | otherwise = "(" ++ stateShow s1 ++ " *** " ++ stateShow s2 ++ ")"@@ -71,7 +71,7 @@   ++ stateShow initState ++ "): " ++ stateShow currentState  feedbackShow :: (Data state, Data s) => Feedback state s -> String-feedbackShow (Feedback (state, s)) = "feedback " ++ gshow s ++ " $ " ++ stateShow state+feedbackShow Feedback { .. } = "feedback " ++ gshow sAdditional ++ " $ " ++ stateShow sPrevious  exceptShow :: (Data s, Data e) => ExceptState s e -> String exceptShow (NotThrown s) = "NotThrown: " ++ stateShow s ++ "\n"

@@ -1,3 +1,4 @@+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} module LiveCoding.Migrate.Cell where @@ -9,176 +10,109 @@  -- essence-of-live-coding import LiveCoding.Cell+import LiveCoding.Cell.Feedback import LiveCoding.Exceptions import LiveCoding.Migrate.Migration+import Control.Applicative (Alternative((<|>))) --- * Migrations involving sequential compositions of cells+-- * Migrations to and from pairs -maybeMigrateToComposition1-  :: (Typeable state1', Typeable state1)-  => Composition state1 state2-  -> state1'-  -> Maybe (Composition state1 state2)-maybeMigrateToComposition1 (Composition (_, state2)) state1' = do-  state1 <- cast state1'-  return $ Composition (state1, state2)+-- ** Generic migration functions --- | Migrate @cell1@ to @cell1 >>> cell2@.-migrationToComposition1 :: Migration-migrationToComposition1 = migrationTo2 maybeMigrateToComposition1+-- | 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)+maybeMigrateToPair fst snd cons pair c = do+  flip cons (snd pair) <$> cast c <|> cons (fst pair) <$> cast c -maybeMigrateFromComposition1-  :: (Typeable state1', Typeable state1)-  => Composition state1 state2-  -> Maybe       state1'-maybeMigrateFromComposition1 (Composition (state1, _)) = cast state1+-- | 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+maybeMigrateFromPair fst snd pair = cast (fst pair) <|> cast (snd pair) --- | Migrate to @cell1@ from @cell1 >>> cell2@.-migrationFromComposition1 :: Migration-migrationFromComposition1 = constMigrationFrom2 maybeMigrateFromComposition1+-- ** Migrations involving sequential compositions of cells -maybeMigrateToComposition2-  :: (Typeable state2', Typeable state2)-  => Composition state1 state2-  -> state2'-  -> Maybe (Composition state1 state2)-maybeMigrateToComposition2 (Composition (state1, _)) state2' = do-  state2 <- cast state2'-  return $ Composition (state1, state2)+-- | Migrate @cell@ to @cell >>> cell'@, and if this fails, to @cell' >>> cell@.+migrationToComposition :: Migration+migrationToComposition = migrationTo2 $ maybeMigrateToPair state1 state2 Composition --- | Migrate @cell2@ to @cell1 >>> cell2@.-migrationToComposition2 :: Migration-migrationToComposition2 = migrationTo2 maybeMigrateToComposition2 -maybeMigrateFromComposition2-  :: (Typeable state2', Typeable state2)-  => Composition state1 state2-  -> Maybe              state2'-maybeMigrateFromComposition2 (Composition (_, state2)) = cast state2---- | Migrate to @cell2@ from @cell1 >>> cell2@.-migrationFromComposition2 :: Migration-migrationFromComposition2 = constMigrationFrom2 maybeMigrateFromComposition2+-- | 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 the first argument.+-- | Combines all migrations related to composition, favouring migration to compositions. migrationComposition :: Migration migrationComposition-  =  migrationToComposition1-  <> migrationFromComposition1-  <> migrationToComposition2-  <> migrationFromComposition2---- * Migrations involving parallel compositions of cells--maybeMigrateToParallel1-  :: (Typeable state1', Typeable state1)-  => Parallel state1 state2-  -> state1'-  -> Maybe (Parallel state1 state2)-maybeMigrateToParallel1 (Parallel (_, state2)) state1' = do-  state1 <- cast state1'-  return $ Parallel (state1, state2)---- | Migrate @cell1@ to @cell1 *** cell2@.-migrationToParallel1 :: Migration-migrationToParallel1 = migrationTo2 maybeMigrateToParallel1--maybeMigrateFromParallel1-  :: (Typeable state1', Typeable state1)-  => Parallel state1 state2-  -> Maybe    state1'-maybeMigrateFromParallel1 (Parallel (state1, _)) = cast state1---- | Migrate to @cell1@ from @cell1 *** cell2@.-migrationFromParallel1 :: Migration-migrationFromParallel1 = constMigrationFrom2 maybeMigrateFromParallel1--maybeMigrateToParallel2-  :: (Typeable state2', Typeable state2)-  => Parallel state1 state2-  -> state2'-  -> Maybe (Parallel state1 state2)-maybeMigrateToParallel2 (Parallel (state1, _)) state2' = do-  state2 <- cast state2'-  return $ Parallel (state1, state2)+  =  migrationToComposition+  <> migrationFromComposition --- | Migrate @cell2@ to @cell1 *** cell2@.-migrationToParallel2 :: Migration-migrationToParallel2 = migrationTo2 maybeMigrateToParallel2+-- ** Migrations involving parallel compositions of cells -maybeMigrateFromParallel2-  :: (Typeable state2', Typeable state2)-  => Parallel state1 state2-  -> Maybe           state2'-maybeMigrateFromParallel2 (Parallel (_, state2)) = cast state2+-- | Migrate @cell@ to @cell *** cell'@, and if this fails, to @cell' *** cell@.+migrationToParallel :: Migration+migrationToParallel = migrationTo2 $ maybeMigrateToPair stateP1 stateP2 Parallel --- | Migrate to @cell2@ from @cell1 *** cell2@.-migrationFromParallel2 :: Migration-migrationFromParallel2 = constMigrationFrom2 maybeMigrateFromParallel2+-- | Migrate from @cell1 *** cell2@ to @cell1@, and if this fails, to @cell2@.+migrationFromParallel :: Migration+migrationFromParallel = constMigrationFrom2 $ maybeMigrateFromPair stateP1 stateP2 --- | Combines all migrations related to parallel composition, favouring the first argument.+-- | Combines all migrations related to parallel composition, favouring migration to parallel composition. migrationParallel :: Migration migrationParallel-  =  migrationToParallel1-  <> migrationFromParallel1-  <> migrationToParallel2-  <> migrationFromParallel2---- * Migration involving 'ArrowChoice'--maybeMigrateToChoice1-  :: (Typeable stateLeft', Typeable stateLeft)-  => Choice stateLeft stateRight-  -> stateLeft'-  -> Maybe (Choice stateLeft stateRight)-maybeMigrateToChoice1 Choice { .. } choiceLeft' = do-  choiceLeft <- cast choiceLeft'-  return Choice { .. }+  =  migrationToParallel+  <> migrationFromParallel --- | Migrate @cell1@ to @cell1 ||| cell2@.-migrationToChoice1 :: Migration-migrationToChoice1 = migrationTo2 maybeMigrateToChoice1+-- ** Migration involving 'ArrowChoice' -maybeMigrateFromChoice1-  :: (Typeable stateLeft', Typeable stateLeft)-  => Choice stateLeft stateRight-  -> Maybe  stateLeft'-maybeMigrateFromChoice1 Choice { .. } = cast choiceLeft+-- | Migrate @cell@ to @cell ||| cell'@, and if this fails, to @cell' ||| cell@.+migrationToChoice :: Migration+migrationToChoice = migrationTo2 $ maybeMigrateToPair choiceLeft choiceRight Choice --- | Migrate to @cell1@ from @cell1 ||| cell2@.-migrationFromChoice1 :: Migration-migrationFromChoice1 = constMigrationFrom2 maybeMigrateFromChoice1+-- | Migrate from @cell1 ||| cell2@ to @cell1@, and if this fails, to @cell2@.+migrationFromChoice :: Migration+migrationFromChoice = constMigrationFrom2 $ maybeMigrateFromPair choiceLeft choiceRight -maybeMigrateToChoice2-  :: (Typeable stateRight', Typeable stateRight)-  => Choice stateLeft stateRight-  -> stateRight'-  -> Maybe (Choice stateLeft stateRight)-maybeMigrateToChoice2 Choice { .. } choiceRight' = do-  choiceRight <- cast choiceRight'-  return Choice { .. }+-- | Combines all migrations related to choice, favouring migration to choice.+migrationChoice :: Migration+migrationChoice+  =  migrationToChoice+  <> migrationFromChoice --- | Migrate @cell2@ to @cell1 ||| cell2@.-migrationToChoice2 :: Migration-migrationToChoice2 = migrationTo2 maybeMigrateToChoice2+-- ** Feedback -maybeMigrateFromChoice2-  :: (Typeable stateRight', Typeable stateRight)-  => Choice stateLeft stateRight-  -> Maybe            stateRight'-maybeMigrateFromChoice2 Choice { .. } = cast choiceRight+-- | Migrate from @cell@ to @feedback s cell@, and if this fails, to @feedback (cellState cell) cell'@.+migrationToFeedback :: Migration+migrationToFeedback = migrationTo2 $ maybeMigrateToPair sPrevious sAdditional Feedback --- | Migrate to @cell2@ from @cell1 ||| cell2@.-migrationFromChoice2 :: Migration-migrationFromChoice2 = constMigrationFrom2 maybeMigrateFromChoice2+-- | Migrate from @feedback s cell@ to @cell@, and if this fails, to @Cell { cellState = s, .. }@.+migrationFromFeedback :: Migration+migrationFromFeedback = constMigrationFrom2 $ maybeMigrateFromPair sPrevious sAdditional --- | Combines all migrations related to choice.-migrationChoice :: Migration-migrationChoice-  =  migrationToChoice1-  <> migrationFromChoice1-  <> migrationToChoice2-  <> migrationFromChoice2+-- | Combines all migrations related to feedback, favouring migration to feedback.+migrationFeedback :: Migration+migrationFeedback = migrationToFeedback <> migrationFromFeedback  -- * Control flow @@ -218,3 +152,4 @@   <> migrationParallel   <> migrationChoice   <> migrationExceptState+  <> migrationFeedback

@@ -0,0 +1,47 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RecordWildCards #-}+module Feedback where++-- essence-of-live-coding+import Util++-- test-framework+import Test.Framework++-- test-framework-quickcheck2+import Test.Framework.Providers.QuickCheck2++-- QuickCheck+import Test.QuickCheck++-- essence-of-live-coding+import LiveCoding++constCell :: Monad m => Int -> Cell m () Int+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]+      }+  ]

@@ -17,6 +17,7 @@ import Test.QuickCheck  -- essence-of-live-coding+import qualified Feedback import qualified Handle import qualified Monad import LiveCoding@@ -108,8 +109,9 @@       ]     , Handle.test     , Monad.test+    , Feedback.test     ]-    , Monad.Trans.test+  , Monad.Trans.test   ]  countFrom :: Monad m => Int -> Cell m () Int