essence-of-live-coding 0.2.7 → 0.2.8

raw patch · 29 files changed

+414/−75 lines, 29 filesdep +profunctorsdep +selectivedep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: profunctors, selective

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• essence-of-live-coding.cabal +21/−6
• src/LiveCoding.hs +3/−0
• src/LiveCoding/Cell.lhs +42/−2
• src/LiveCoding/Cell/Monad.hs +2/−2
• src/LiveCoding/Cell/Monad/Trans.hs +9/−2
• src/LiveCoding/Cell/NonBlocking.hs +1/−1
• src/LiveCoding/Cell/Resample.hs +9/−12
• src/LiveCoding/Cell/Util.hs +5/−5
• src/LiveCoding/Debugger/StatePrint.hs +2/−2
• src/LiveCoding/GHCi.hs +5/−5
• src/LiveCoding/Handle.hs +3/−3
• src/LiveCoding/HandlingState.hs +7/−7
• src/LiveCoding/LiveProgram/Except.hs +3/−3
• src/LiveCoding/Migrate.lhs +4/−1
• src/LiveCoding/Migrate/Migration.hs +3/−3
• src/LiveCoding/Migrate/NoMigration.hs +1/−1
• src/LiveCoding/RuntimeIO/Launch.hs +7/−7
• test/Cell.hs +2/−0
• test/Cell/Util.hs +32/−3
• test/Cell/Util/Traversable.hs +137/−0
• test/Feedback.hs +1/−1
• test/Handle.hs +3/−3
• test/Main.hs +5/−3
• test/Migrate.hs +60/−0
• test/TestData/Foo1.hs +6/−0
• test/TestData/Foo2.hs +10/−0
• test/Util.hs +18/−1
• test/Util/LiveProgramMigration.hs +2/−2

@@ -1,6 +1,17 @@ # Revision history for essence-of-live-coding +## 0.2.8++* Support GHC 9.10+* Add Selective instances+ ## 0.2.7++* Add support for GHC 9.2+* Formatting with Fourmolu+* Added `NoMigration`++## 0.2.6  * Add `changes` * Add support for GHC 9.0.2

@@ -1,5 +1,5 @@ name:                essence-of-live-coding-version:             0.2.7+version:             0.2.8 synopsis: General purpose live coding framework description:   essence-of-live-coding is a general purpose and type safe live coding framework.@@ -22,6 +22,15 @@ build-type:          Simple extra-source-files:  CHANGELOG.md cabal-version:       >=1.10+tested-with:+  GHC == 8.8.4+  GHC == 8.10.7+  GHC == 9.0.2+  GHC == 9.2.8+  GHC == 9.4.8+  GHC == 9.6.5+  GHC == 9.8.2+  GHC == 9.10.1  source-repository head   type:     git@@ -30,7 +39,7 @@ source-repository this   type:     git   location: https://github.com/turion/essence-of-live-coding.git-  tag:      v0.2.7+  tag:      v0.2.8   library@@ -82,7 +91,7 @@    other-extensions:    DeriveDataTypeable   build-depends:-      base >= 4.11 && < 5+      base >= 4.13 && < 4.21     , transformers >= 0.5     , containers >= 0.6     , syb >= 0.7@@ -90,6 +99,8 @@     , foreign-store >= 0.2     , time >= 1.9     , mmorph >= 1.1+    , profunctors >= 5.2+    , selective >= 0.4   hs-source-dirs:      src   default-language:    Haskell2010   default-extensions: StrictData@@ -99,9 +110,11 @@   main-is: Main.hs   other-modules:       Cell+    , Migrate     , Migrate.NoMigration     , Cell.Monad.Trans     , Cell.Util+    , Cell.Util.Traversable     , Feedback     , Handle     , Handle.LiveProgram@@ -114,7 +127,7 @@     , Util.LiveProgramMigration   hs-source-dirs: test   build-depends:-      base >= 4.11 && < 5+      base >= 4.13 && < 4.21     , syb >= 0.7     , transformers >= 0.5     , containers >= 0.6@@ -123,15 +136,17 @@     , test-framework >= 0.8     , test-framework-quickcheck2 >= 0.3     , QuickCheck >= 2.12+    , selective >= 0.4     , test-framework-hunit >= 0.3     , HUnit >= 1.3+    , vector-sized >= 1.2   default-language:    Haskell2010  executable TestExceptions   main-is: TestExceptions.hs   hs-source-dirs: app   build-depends:-      base >= 4.11 && < 5+      base >= 4.13 && < 4.21     , essence-of-live-coding     , transformers >= 0.5   default-language:    Haskell2010@@ -140,7 +155,7 @@   main-is: TestNonBlocking.hs   hs-source-dirs: app   build-depends:-      base >= 4.11 && < 5+      base >= 4.13 && < 4.21     , transformers >= 0.5     , essence-of-live-coding   default-language:    Haskell2010

@@ -4,6 +4,9 @@ -- base import Control.Arrow as X hiding (app) import Data.Data as X+import Data.Profunctor as X hiding (Choice)+import Data.Profunctor.Strong as X+import Data.Profunctor.Traversing as X  -- essence-of-live-coding import LiveCoding.Bind as X

@@ -6,16 +6,27 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingVia #-} module LiveCoding.Cell where  -- base+import Data.Profunctor+    ( Strong, WrappedArrow(WrapArrow), Profunctor )+import Data.Profunctor.Strong ( Strong )+import Data.Profunctor.Choice ( Choice )+import Data.Profunctor.Traversing ( Traversing(traverse') )+import Control.Monad.Trans.State.Lazy+  (StateT(runStateT, StateT)) import Control.Arrow import Control.Category import Control.Concurrent (threadDelay)@@ -24,6 +35,9 @@ import Data.Data import Prelude hiding ((.), id) +-- selective+import Control.Selective+ -- transformers import Control.Monad.Trans.Class import Control.Monad.Trans.Reader@@ -96,6 +110,7 @@   | ArrM { runArrM :: a -> m b }   -- ^ Effectively a cell with trivial state.   --   Added to improve performance and keep state types simpler.+deriving instance Functor m => Functor (Cell m a) \end{code} \end{comment} \begin{comment}@@ -412,6 +427,15 @@  \begin{comment} \begin{code}+deriving via (WrappedArrow (Cell m)) instance Monad m => Profunctor (Cell m)+deriving via (WrappedArrow (Cell m)) instance Monad m => Strong (Cell m)+deriving via (WrappedArrow (Cell m)) instance Monad m => Data.Profunctor.Choice.Choice (Cell m)++instance Monad m => Traversing (Cell m) where+  traverse' (Cell state step) = Cell state step' where+    step' s a = runStateT (traverse (\a -> StateT (`step` a)) a) s+  traverse' (ArrM f) = ArrM (traverse f)+ data Parallel stateP1 stateP2 = Parallel   { stateP1 :: stateP1   , stateP2 :: stateP2@@ -457,8 +481,24 @@ constM :: m b -> Cell m a b constM = arrM . const -constC :: Monad m => b -> Cell m a b-constC = constM . return+constC :: Applicative m => b -> Cell m a b+constC = constM . pure++instance Applicative m => Applicative (Cell m a) where+  pure = constC+  Cell fState0 fStep <*> Cell aState0 aStep = Cell+    { cellStep = \(Parallel fState aState) a -> (\(f, fState') (a, aState') -> (f a, Parallel fState' aState')) <$> fStep fState a <*> aStep aState a+    , cellState = Parallel fState0 aState0+    }++instance Monad m => Selective (Cell m a) where+  select cell1 cell2 = proc i -> do+    ebc <- cell1 -< i+    case ebc of+      Left a -> do+        f <- cell2 -< i+        returnA -< f a+      Right b -> returnA -< b \end{code} \end{comment} 

@@ -11,7 +11,7 @@ -- essence-of-live-coding  import Control.Arrow (Arrow (arr), (>>>))-import Data.Data (Data)+import Data.Data (Data, Typeable) import LiveCoding.Cell  -- | Apply a monad morphism that also transforms the output to a cell.@@ -50,7 +50,7 @@    changing the state type. -} hoistCellKleisliStateChange ::-  (Monad m1, Monad m2, (forall s. Data s => Data (t s))) =>+  (Monad m1, Monad m2, Typeable t, (forall s. (Data s) => Data (t s))) =>   ( forall s.     (s -> a1 -> m1 (b1, s)) ->     (t s -> a2 -> m2 (b2, t s))

@@ -11,7 +11,7 @@ import Data.Data (Data)  -- transformers-import Control.Monad.Trans.Reader (ReaderT, runReaderT)+import Control.Monad.Trans.Reader (ReaderT (..), reader, runReaderT) import Control.Monad.Trans.State.Strict (StateT (..), evalStateT, runStateT) import Control.Monad.Trans.Writer.Strict @@ -61,10 +61,17 @@  -- | Supply a 'ReaderT' environment live runReaderC' ::-  Monad m =>+  (Monad m) =>   Cell (ReaderT r m) a b ->   Cell m (r, a) b runReaderC' = hoistCellKleisli_ $ \action (r, a) -> runReaderT (action a) r++-- | Inverse to 'runReaderC''+readerC' ::+  (Monad m) =>+  Cell m (r, a) b ->+  Cell (ReaderT r m) a b+readerC' = hoistCellKleisli_ $ \action a -> ReaderT $ \r -> action (r, a)  {- | Run the effects of the 'WriterT' monad,    collecting all its output in the second element of the tuple.

@@ -32,7 +32,7 @@ The boolean flag controls whether the current computation is aborted and restarted when new data arrives. -} nonBlocking ::-  Typeable b =>+  (Typeable b) =>   -- | Pass 'True' to abort the computation when new data arrives. 'False' discards new data.   Bool ->   Cell IO a b ->

@@ -15,6 +15,9 @@ import Data.Maybe import GHC.TypeNats +-- profunctors+import Data.Profunctor.Traversing (Traversing (traverse'))+ -- vector-sized import Data.Vector.Sized (Vector, fromList, toList) @@ -24,20 +27,14 @@  -- | Execute the inner cell for n steps per outer step. resample :: (Monad m, KnownNat n) => Cell m a b -> Cell m (Vector n a) (Vector n b)-resample cell = arr toList >>> resampleList cell >>> arr (fromList >>> fromJust)+resample = traverse'  -- | Execute the cell for as many steps as the input list is long.-resampleList :: Monad m => Cell m a b -> Cell m [a] [b]-resampleList = hoistCellKleisli morph-  where-    morph _ s [] = return ([], s)-    morph singleStep s (a : as) = do-      (!b, s') <- singleStep s a-      (!bs, s'') <- morph singleStep s' as-      return (b : bs, s'')+resampleList :: (Monad m) => Cell m a b -> Cell m [a] [b]+resampleList = traverse' -resampleMaybe :: Monad m => Cell m a b -> Cell m (Maybe a) (Maybe b)-resampleMaybe cell = arr maybeToList >>> resampleList cell >>> arr listToMaybe+resampleMaybe :: (Monad m) => Cell m a b -> Cell m (Maybe a) (Maybe b)+resampleMaybe = traverse'  {- | 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@@ -45,7 +42,7 @@   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 :: (Monad m) => Cell m a b -> Cell m [a] [b] resampleListPar (Cell initial step) = Cell {..}   where     cellState = []

@@ -29,11 +29,11 @@ -- * State accumulation  -- | Sum all past inputs, starting by the given number-sumFrom :: Monad m => Integer -> Cell m Integer Integer+sumFrom :: (Monad m) => Integer -> Cell m Integer Integer sumFrom n0 = feedback n0 $ proc (n, acc) -> returnA -< (acc, acc + n)  -- | Count the number of ticks, starting at 0-count :: Monad m => Cell m a Integer+count :: (Monad m) => Cell m a Integer count = arr (const 1) >>> sumC  {- | Accumulate all incoming data,@@ -126,7 +126,7 @@ fifoFoldable = arr toList >>> fifoList  -- | Returns 'True' iff the current input value is 'True' and the last input value was 'False'.-edge :: Monad m => Cell m Bool Bool+edge :: (Monad m) => Cell m Bool Bool edge = proc b -> do   bLast <- delay False -< b   returnA -< b && not bLast@@ -134,11 +134,11 @@ -- * Debugging utilities  -- | Print the current UTC time, prepended with the first 8 characters of the given message.-printTime :: MonadIO m => String -> m ()+printTime :: (MonadIO m) => String -> m () printTime msg = liftIO $ putStrLn . (take 8 msg ++) . show =<< getCurrentTime  -- | Like 'printTime', but as a cell.-printTimeC :: MonadIO m => String -> Cell m () ()+printTimeC :: (MonadIO m) => String -> Cell m () () printTimeC msg = constM $ printTime msg  -- * Buffers

@@ -33,7 +33,7 @@   s <- get   lift $ putStrLn $ stateShow s -stateShow :: Data s => s -> String+stateShow :: (Data s) => s -> String stateShow =   gshow     `ext2Q` compositionShow@@ -43,7 +43,7 @@     `ext2Q` exceptShow     `ext2Q` choiceShow -isUnit :: Data s => s -> Bool+isUnit :: (Data s) => s -> Bool isUnit =   mkQ     False

@@ -46,7 +46,7 @@    Returns 'Right Nothing' if the store didn't exist. -} possiblyLaunchedProgram ::-  Launchable m =>+  (Launchable m) =>   Proxy m ->   IO (Either SomeException (LaunchedProgram m)) possiblyLaunchedProgram _ = do@@ -56,7 +56,7 @@ {- | 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 :: (Launchable m) => LiveProgram m -> IO () sync program = do   launchedProgramPossibly <- possiblyLaunchedProgram $ proxyFromLiveProgram program   case launchedProgramPossibly of@@ -71,18 +71,18 @@       update launchedProgram program  -- | Launch a 'LiveProgram' and save it in the 'Store'.-launchAndSave :: Launchable m => LiveProgram m -> IO ()+launchAndSave :: (Launchable m) => LiveProgram m -> IO () launchAndSave = launch >=> save  -- | Save a 'LiveProgram' to the store.-save :: Launchable m => LaunchedProgram m -> IO ()+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 =>+  (Launchable m) =>   Proxy m ->   IO () stopStored proxy = do

@@ -57,7 +57,7 @@ Note: 'Handle' is not an 'Applicative' because it is not a 'Functor' (because the destructor is contravariant in @h@). -}-combineHandles :: Applicative m => Handle m h1 -> Handle m h2 -> Handle m (h1, h2)+combineHandles :: (Applicative m) => Handle m h1 -> Handle m h2 -> Handle m (h1, h2) combineHandles handle1 handle2 =   Handle     { create = (,) <$> create handle1 <*> create handle2@@ -116,7 +116,7 @@  -- | Like 'combineHandles', but for 'ParametrisedHandle's. combineParametrisedHandles ::-  Applicative m =>+  (Applicative m) =>   ParametrisedHandle p1 m h1 ->   ParametrisedHandle p2 m h2 ->   ParametrisedHandle (p1, p2) m (h1, h2)@@ -168,7 +168,7 @@ {- | Every 'Handle' is trivially a 'ParametrisedHandle'    when the parameter is the trivial type. -}-toParametrised :: Monad m => Handle m h -> ParametrisedHandle () m h+toParametrised :: (Monad m) => Handle m h -> ParametrisedHandle () m h toParametrised Handle {..} =   ParametrisedHandle     { createParametrised = const create

@@ -57,7 +57,7 @@    Since there is no garbage collection, don't use this function for live coding. -} runHandlingStateT ::-  Monad m =>+  (Monad m) =>   HandlingStateT m a ->   m a runHandlingStateT = flip evalStateT initHandlingState@@ -97,7 +97,7 @@       }  garbageCollected ::-  Monad m =>+  (Monad m) =>   HandlingStateT m a ->   HandlingStateT m a garbageCollected action = unregisterAll >> action <* destroyUnregistered@@ -108,7 +108,7 @@   }  register ::-  Monad m =>+  (Monad m) =>   -- | Destructor   m () ->   HandlingStateT m Key@@ -123,7 +123,7 @@   return key  reregister ::-  Monad m =>+  (Monad m) =>   m () ->   Key ->   HandlingStateT m ()@@ -141,7 +141,7 @@    in insert key destructor destructors  unregisterAll ::-  Monad m =>+  (Monad m) =>   HandlingStateT m () unregisterAll = do   HandlingState {..} <- get@@ -149,7 +149,7 @@   put HandlingState {destructors = newDestructors, ..}  destroyUnregistered ::-  Monad m =>+  (Monad m) =>   HandlingStateT m () destroyUnregistered = do   HandlingState {..} <- get@@ -165,7 +165,7 @@ destructorConstr :: Constr destructorConstr = mkConstr dataTypeDestructor "Destructor" [] Prefix -instance Typeable m => Data (Destructor m) where+instance (Typeable m) => Data (Destructor m) where   dataTypeOf _ = dataTypeDestructor   toConstr Destructor {..} = destructorConstr   gunfold _ _ = error "Destructor.gunfold"

@@ -45,7 +45,7 @@  -- | Execute a 'LiveProgramExcept', throwing its exceptions in the 'ExceptT' monad. runLiveProgramExcept ::-  Monad m =>+  (Monad m) =>   LiveProgramExcept m e ->   LiveProgram (ExceptT e m) runLiveProgramExcept LiveProgramExcept {..} = liveCell $ runCellExcept unLiveProgramExcept@@ -68,7 +68,7 @@ and thus we can safely assume that it is a 'LiveProgram' in @m@. -} safely ::-  Monad m =>+  (Monad m) =>   LiveProgramExcept m Void ->   LiveProgram m safely = liveCell . CellExcept.safely . unLiveProgramExcept@@ -78,7 +78,7 @@ This is always safe in the sense that it has no exceptions. -} safe ::-  Monad m =>+  (Monad m) =>   LiveProgram m ->   LiveProgramExcept m Void safe = LiveProgramExcept . CellExcept.safe . toLiveCell

@@ -64,10 +64,13 @@ matchingAlgebraicDataTypes a b   = isAlgType typeA   && isAlgType typeB-  && dataTypeName typeA == dataTypeName typeB+  && withoutModule (dataTypeName typeA) == withoutModule (dataTypeName typeB)   where     typeA = dataTypeOf a     typeB = dataTypeOf b+    withoutModule string = let+      (prefix, suffix) = break (== '.') string+      in if null suffix then prefix else withoutModule $ tail suffix  -- | Assuming that both are algebraic data types, possibly the constructor names match. --   In that case, we will try and recursively migrate as much data as possible onto the new constructor.

@@ -59,19 +59,19 @@ userMigration specific = Migration $ \_a b -> cast =<< specific <$> cast b  migrationTo2 ::-  Typeable t =>+  (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 =>+  (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 =>+  (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

@@ -60,7 +60,7 @@ uninitializedConstr :: Constr uninitializedConstr = mkConstr dataTypeNoMigration "Uninitialized" [] Prefix --- |The Data instance for @'NoMigration' a@ doesn't require a 'Data' instance for @a@.+-- | 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

@@ -33,7 +33,7 @@ The only thing necessary is to transform the 'LiveProgram' into one in the 'IO' monad, and the rest is taken care of in the framework. -}-class Monad m => Launchable m where+class (Monad m) => Launchable m where   runIO :: LiveProgram m -> LiveProgram IO  instance Launchable IO where@@ -59,13 +59,13 @@ @ -} liveMain ::-  Launchable m =>+  (Launchable m) =>   LiveProgram m ->   IO () liveMain = foreground . runIO  -- | Launch a 'LiveProgram' in the foreground thread (blocking).-foreground :: Monad m => LiveProgram m -> m ()+foreground :: (Monad m) => LiveProgram m -> m () foreground liveProgram =   stepProgram liveProgram     >>= foreground@@ -83,7 +83,7 @@ You're advised not to kill it directly, but to run 'stop' instead. -} launch ::-  Launchable m =>+  (Launchable m) =>   LiveProgram m ->   IO (LaunchedProgram m) launch liveProg = do@@ -93,7 +93,7 @@  -- | Migrate (using 'hotCodeSwap') the 'LiveProgram' to a new version. update ::-  Launchable m =>+  (Launchable m) =>   LaunchedProgram m ->   LiveProgram m ->   IO ()@@ -108,7 +108,7 @@ such as 'HandlingStateT'. -} stop ::-  Launchable m =>+  (Launchable m) =>   LaunchedProgram m ->   IO () stop launchedProgram@LaunchedProgram {..} = do@@ -132,7 +132,7 @@   putMVar var liveProg'  -- | Advance a 'LiveProgram' by a single step.-stepProgram :: Monad m => LiveProgram m -> m (LiveProgram m)+stepProgram :: (Monad m) => LiveProgram m -> m (LiveProgram m) stepProgram LiveProgram {..} = do   liveState' <- liveStep liveState   return LiveProgram {liveState = liveState', ..}

@@ -25,6 +25,7 @@  import qualified Cell.Monad.Trans import qualified Cell.Util+import qualified Cell.Util.Traversable  test =   testGroup@@ -36,5 +37,6 @@           sum (init inputs)             === last (fst (runIdentity $ steps (sumC :: Cell Identity Int Int) inputs))     , Cell.Util.test+    , Cell.Util.Traversable.testTraverse'     , Cell.Monad.Trans.test     ]

@@ -1,6 +1,17 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE Arrows #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}  module Cell.Util where @@ -10,10 +21,22 @@ import Data.Functor.Identity import Data.List import Data.Maybe+import GHC.TypeLits (KnownNat) +-- containers+import Data.Map (Map)+import Data.Sequence (Seq)+ -- transformers import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Lazy +-- vector-sized+import qualified Data.Vector.Sized as V++-- selective+import Control.Selective+ -- test-framework import Test.Framework @@ -95,10 +118,9 @@           counterexample labelString $             catMaybes inputs === catMaybes outputs               .||. bufferNotEmpty-    , testProperty "delay a >>> changes >>> hold a == delay a" $+    , 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)+          CellIdentitySimulation (delay startValue) (delay startValue >>> changes >>> hold startValue) inputs     , testProperty "changes applied to a cell that outputs a constant, always outputs Nothing" $         \(value :: Int) (inputs :: [Int]) ->           []@@ -189,6 +211,13 @@           { 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]]+          }+    , testProperty+        "Selective instance is sound"+        CellSimulation+          { cell = select C.id (pure length) :: Cell Identity (Either [()] Int) Int+          , input = [Right 42, Left [(), ()]]+          , output = [42, 2]           }     ] 

@@ -0,0 +1,137 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Cell.Util.Traversable where++-- base+import qualified Control.Category as C+import Control.Monad+import Data.Functor.Identity+import Data.List+import Data.Maybe+import GHC.TypeLits (KnownNat)++-- containers+import Data.Map (Map)+import Data.Sequence (Seq)++-- transformers+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Lazy++-- vector-sized+import qualified Data.Vector.Sized as V++-- 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++type TestTraversables = Traversables '[Maybe, [], V.Vector 10, Seq, Map Int]++testTraverse' :: Test+testTraverse' =+  testGroup+    "Traversing unit tests"+    [ genTraversableTests' @TestTraversables "traverse' (arr f) = arr (f <$>)" $+        makeTraversableTest (traverseArrLaw @Int @Int)+    , genTraversableTests' @TestTraversables+        "traverse' works as expected for any Cell Identy Int Int created with constructor Cell"+        $ makeTraversableTest (traverseCellTest @Int @Int @Int)+    , testProperty "traverse' by itself does not force the entire list (ArrM)" $+        CellSimulation+          { cell = arr head+          , input = [1 : error "Bang !"]+          , output = [1]+          }+    , testProperty "traverse' by itself does not force the entire list (Cell)" $+        CellSimulation+          { cell = toCell $ arr head+          , input = [1 : error "Bang !"]+          , output = [1]+          }+    ]++traverseArrLaw ::+  forall a b t.+  (Traversable t) =>+  Proxy t ->+  [t a] ->+  Fun a b ->+  CellIdentitySimulation (t a) (t b)+traverseArrLaw _ joinInput (Fn f) =+  CellIdentitySimulation+    { cellL = arr (f <$>)+    , cellR = traverse' (arr f)+    , ..+    }++traverseCellTest ::+  forall s a b t.+  (Traversable t, Data s) =>+  Proxy t ->+  s ->+  Fun (s, a) (b, s) ->+  [t a] ->+  CellSimulation (t a) (t b)+traverseCellTest _ s (Fn2 f) input =+  CellSimulation+    { cell = traverse' (Cell s (\s a -> pure $ f s a))+    , output = runIdentity $ evalStateT (traverse (traverse (\a -> StateT (Identity . (`f` a)))) input) s+    , ..+    }++makeTraversableTest :: forall (t :: * -> *) a. (Testable a, Typeable t) => (Proxy t -> a) -> Proxy t -> Test+makeTraversableTest a _ = testProperty (show (typeRep (Proxy :: Proxy t))) (a (Proxy :: Proxy t))++-- | A data type to store types which are instances of 'Traversable'.+data Traversables :: [* -> *] -> *++-- | A type class for induction on the type-level list containing the Traversables.+class GenTests a where+  genTraversableTests ::+    (forall (t :: * -> *). (Arbitrary (t Int), Show (t Int), Eq (t Int), Traversable t, Typeable t) => Proxy t -> Test) ->+    Proxy a ->+    [Test]++instance GenTests (Traversables '[]) where+  genTraversableTests _ _ = []++instance+  (GenTests (Traversables xs), Arbitrary (x Int), Show (x Int), Eq (x Int), Traversable x, Typeable x) =>+  GenTests (Traversables (x ': xs))+  where+  genTraversableTests f _ = f (Proxy :: Proxy x) : genTraversableTests f (Proxy :: Proxy (Traversables xs))++genTraversableTests' ::+  forall a.+  (GenTests a) =>+  String ->+  (forall (t :: * -> *). (Arbitrary (t Int), Show (t Int), Eq (t Int), Traversable t, Typeable t) => Proxy t -> Test) ->+  Test+genTraversableTests' message f = testGroup message $ genTraversableTests f (Proxy :: Proxy a)++instance (Arbitrary a, KnownNat n) => Arbitrary (V.Vector n a) where+  arbitrary = V.replicateM arbitrary+  shrink = V.mapM shrink

@@ -18,7 +18,7 @@ -- essence-of-live-coding import LiveCoding -constCell :: Monad m => Int -> Cell m () Int+constCell :: (Monad m) => Int -> Cell m () Int constCell cellState =   Cell     { cellStep = \state _ -> return (state, state)

@@ -72,13 +72,13 @@     runHandlingStateC $       handlingParametrised testParametrisedHandle >>> arrM (<$ lift action) -throwAfter2Steps :: Monad m => Cell (ExceptT () m) a Int+throwAfter2Steps :: (Monad m) => Cell (ExceptT () m) a Int throwAfter2Steps = arr (const 1) >>> sumC >>> throwIf_ (> 1)  data Tag (tag :: Nat) = Tag   deriving (Eq, Show) -testTypelevelHandle :: KnownNat tag => Handle (State Int) (Tag tag)+testTypelevelHandle :: (KnownNat tag) => Handle (State Int) (Tag tag) testTypelevelHandle =   Handle     { create = return Tag@@ -86,7 +86,7 @@     }  cellWithActionTypelevel ::-  KnownNat tag =>+  (KnownNat tag) =>   State Int b ->   Cell Identity a (Tag tag, Int) cellWithActionTypelevel action =

@@ -20,7 +20,7 @@ import qualified Cell import qualified Feedback import qualified Handle-import qualified Migrate.NoMigration+import qualified Migrate import qualified Monad import qualified Monad.Trans import qualified RuntimeIO.Launch@@ -68,6 +68,8 @@           \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+      , testProperty "Does not migrate for different types" $+          migrate Foo1.same Foo2.similar === Foo1.same       ]   , testGroup       "User migration"@@ -133,7 +135,7 @@           ]       , Cell.test       , Handle.test-      , Migrate.NoMigration.test+      , Migrate.test       , Monad.test       , Feedback.test       ]@@ -141,7 +143,7 @@   , RuntimeIO.Launch.test   ] -countFrom :: Monad m => Int -> Cell m () Int+countFrom :: (Monad m) => Int -> Cell m () Int countFrom n = arr (const 1) >>> sumC >>> arr (+ n)  fromEither (Left a) = a

@@ -0,0 +1,60 @@+module Migrate where++-- base+import Data.Data (dataTypeName, isAlgType)++-- QuickCheck+import Test.QuickCheck.Property ((===))++-- test-framework+import Test.Framework++-- test-framework-quickcheck2+import Test.Framework.Providers.QuickCheck2 (testProperty)++-- essence-of-live-coding+import LiveCoding (Data (dataTypeOf), castMigration, runSafeMigration)+import LiveCoding.Migrate++import Migrate.NoMigration+import qualified TestData.Foo1 as Foo1+import qualified TestData.Foo2 as Foo2++test =+  testGroup+    "Migrate"+    [ testGroup+        "Internal assumptions"+        [ testGroup+            "matchingAlgebraicDataTypes"+            [ testProperty "True for types with the same name" $+                matchingAlgebraicDataTypes Foo1.foo Foo2.foo+            , testGroup+                "debugging tests"+                [ testProperty "isAlgType" $ isAlgType $ dataTypeOf Foo1.foo+                ]+            ]+        ]+    , testGroup+        "standard migrations"+        [ testGroup+            "castMigration"+            [ testProperty "Migrates for same data type" $+                runSafeMigration castMigration Foo1.same Foo1.same == Foo1.same+            , testProperty "Does not migrate for different data types" $+                runSafeMigration castMigration Foo1.same Foo2.same == Foo1.same+            , testProperty "Migrates for same builtin type" $+                runSafeMigration castMigration (23 :: Int) (42 :: Int) == 42+            , testProperty "Does not migrate for different builtin types" $+                runSafeMigration castMigration (23 :: Int) (42 :: Integer) == 23+            ]+        , testGroup+            "sameConstructorMigration"+            [ testProperty "Migrates when constructor names and arity match" $+                runSafeMigration (sameConstructorMigration castMigration) Foo1.same Foo2.same == Foo1.same'+            , testProperty "Migrates for same data type" $+                runSafeMigration (sameConstructorMigration castMigration) Foo1.same Foo1.same' == Foo1.same'+            ]+        ]+    , Migrate.NoMigration.test+    ]

@@ -6,6 +6,12 @@ import Data.Data import Data.Typeable +data Same = Same String Int+  deriving (Show, Eq, Typeable, Data)++same = Same "same" 23+same' = Same "the same" 42+ data Foo = Foo Integer Bool   deriving (Show, Eq, Typeable, Data) 

@@ -6,6 +6,16 @@ import Data.Data import Data.Typeable +data Same = Same String Int+  deriving (Show, Eq, Typeable, Data)++same = Same "the same" 42++data Similar = Similar String Int+  deriving (Show, Eq, Typeable, Data)++similar = Similar "similar" 100+ data Foo   = Fooo Integer   | Foo Integer

@@ -47,7 +47,7 @@    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 :: (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   let cell2' = hotCodeSwapCell cell2 cell1'@@ -86,3 +86,20 @@         , output1 = output         , output2 = []         }++{- | Basic unit test for 'Cell' identities.+   Check whether one cell behaves the same as another cell.+-}+data CellIdentitySimulation a b = CellIdentitySimulation+  { cellL :: Cell Identity a b+  , cellR :: Cell Identity a b+  , joinInput :: [a]+  }++instance (Eq b, Show b) => Testable (CellIdentitySimulation a b) where+  property CellIdentitySimulation {..} =+    let+      Identity (outputa, _) = simulateCellMigration cellL cellR joinInput []+      Identity (outputb, _) = simulateCellMigration cellL cellR joinInput []+     in+      outputa === outputb

@@ -23,10 +23,10 @@   , output2 :: [b]   } -stepLiveProgramRWS :: Monoid b => LiveProgram (RWS a b s) -> a -> s -> (LiveProgram (RWS a b s), s, b)+stepLiveProgramRWS :: (Monoid b) => LiveProgram (RWS a b s) -> a -> s -> (LiveProgram (RWS a b s), s, b) stepLiveProgramRWS liveProg = runRWS (stepProgram liveProg) -stepsLiveProgramRWS :: Monoid b => LiveProgram (RWS a b s) -> s -> [a] -> (LiveProgram (RWS a b s), s, [b])+stepsLiveProgramRWS :: (Monoid b) => LiveProgram (RWS a b s) -> s -> [a] -> (LiveProgram (RWS a b s), s, [b]) stepsLiveProgramRWS liveProg s [] = (liveProg, s, []) stepsLiveProgramRWS liveProg s (a : as) =   let (liveProg', s', b) = stepLiveProgramRWS liveProg a s