essence-of-live-coding 0.1.0.1 → 0.1.0.2

raw patch · 10 files changed

+513/−75 lines, 10 filesdep ~vector-sizedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: vector-sized

API changes (from Hackage documentation)

Files

• essence-of-live-coding.cabal +4/−3
• src/LiveCoding/Cell.lhs +70/−15
• src/LiveCoding/Migrate.lhs +71/−21
• src/LiveCoding/Migrate/Cell.hs +220/−0
• src/LiveCoding/Migrate/Debugger.hs +16/−19
• src/LiveCoding/Migrate/Migration.hs +13/−0
• src/LiveCoding/RuntimeIO.lhs +1/−1
• test/Main.hs +104/−13
• test/TestData/Foo1.hs +6/−1
• test/TestData/Foo2.hs +8/−2

@@ -1,5 +1,5 @@ name:                essence-of-live-coding-version:             0.1.0.1+version:             0.1.0.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.1.0.1+  tag:      v0.1.0.2   library@@ -52,6 +52,7 @@     , LiveCoding.LiveProgram     , LiveCoding.LiveProgram.HotCodeSwap     , LiveCoding.Migrate+    , LiveCoding.Migrate.Cell     , LiveCoding.Migrate.Migration     , LiveCoding.Migrate.Debugger     , LiveCoding.RuntimeIO@@ -70,7 +71,7 @@       base >= 4.11 && <4.13     , transformers == 0.5.*     , syb == 0.7.*-    , vector-sized == 1.2.*+    , vector-sized == 1.4.*     , foreign-store   hs-source-dirs:      src   default-language:    Haskell2010

@@ -7,6 +7,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}@@ -18,7 +19,7 @@ import Control.Arrow import Control.Category import Control.Concurrent (threadDelay)-import Control.Monad ((>=>)) -- Only for rewrite rule+import Control.Monad import Control.Monad.Fix import Data.Data import Prelude hiding ((.), id)@@ -80,7 +81,9 @@   { cellState :: s   , cellStep  :: s -> a -> m (b, s)   }+  | ArrM { runArrM :: a -> m b } \end{code}+\fxfatal{I've added, to improve performance and migration, the ArrM constructor. Add to LiveProgram as well and explain in both places.} Such a cell may progress by one step, consuming an \mintinline{haskell}{a} as input, and producing, by means of an effect in some monad \mintinline{haskell}{m},@@ -95,6 +98,7 @@ step Cell { .. } a = do   (b, cellState') <- cellStep cellState a   return (b, Cell { cellState = cellState', .. })+step cell@ArrM { .. } a = ( , cell) <$> runArrM a \end{code}  \begin{comment}@@ -131,6 +135,10 @@   { liveState = cellState   , liveStep  = fmap snd . flip cellStep ()   }+liveCell ArrM { .. } = LiveProgram+  { liveState = ()+  , liveStep  = runArrM+  } \end{code} \begin{comment} \begin{code}@@ -164,6 +172,9 @@   { cellStep = \s a -> morph $ cellStep s a   , ..   }+hoistCell morph ArrM { .. } = ArrM+  { runArrM = morph . runArrM+  } \end{code} \end{comment} @@ -189,11 +200,17 @@ getState2 (Composition (state1, state2)) = state2  instance Monad m => Category (Cell m) where-  id = Cell-    { cellState = ()-    , cellStep  = \() a -> return (a, ())-    }+  id = ArrM return +  ArrM f . ArrM g = ArrM $ f <=< g+  Cell { .. } . ArrM { .. } = Cell+    { cellStep = \state -> cellStep state <=< runArrM+    , ..+    }+  ArrM { .. } . Cell { .. } = Cell+    { cellStep = \state -> (runKleisli $ first $ Kleisli runArrM) <=< cellStep state -- first runArrM <=< +    , ..+    }   Cell state2 step2 . Cell state1 step1 = Cell { .. }     where       cellState = Composition (state1, state2)@@ -352,11 +369,23 @@   deriving Data  instance Monad m => Arrow (Cell m) where-  arr f = Cell-    { cellState = ()-    , cellStep  = \() a -> return (f a, ())-    }+  arr = arrM . (return .) +  ArrM f *** ArrM g = ArrM $ runKleisli $ Kleisli f *** Kleisli g+  ArrM { .. } *** Cell { .. } = Cell+    { cellStep = \state (a, c) -> do+      b <- runArrM a+      (d, state') <- cellStep state c+      return ((b, d), state')+    , ..+    }+  Cell { .. } *** ArrM { .. } = Cell+    { cellStep = \state (a, c) -> do+      (b, state') <- cellStep state a+      d <- runArrM c+      return ((b, d), state')+    , ..+    }   Cell state1 step1 *** Cell state2 step2 = Cell { .. }     where       cellState = Parallel (state1, state2)@@ -365,20 +394,25 @@         (d, state2') <- step2 state2 c         return ((b, d), Parallel (state1', state2')) -arrM :: Functor m => (a -> m b) -> Cell m a b-arrM f = Cell-  { cellState = ()-  , cellStep  = \() a -> (, ()) <$> f a-  }+arrM :: (a -> m b) -> Cell m a b+arrM = ArrM -constM :: Functor m => m b -> Cell m a b+constM :: m b -> Cell m a b constM = arrM . const++constC :: Monad m => b -> Cell m a b+constC = constM . return \end{code} \end{comment}  \begin{comment} \begin{code} instance MonadFix m => ArrowLoop (Cell m) where+  loop ArrM { .. } = ArrM+    { runArrM = \a -> do+        rec (b, c) <- (\c' -> runArrM (a, c')) c+        return b+    }   loop (Cell state step) = Cell { .. }     where       cellState = state@@ -508,6 +542,27 @@         return (Left b, cellState')       cellStep cellState (Right b) = return (Right b, cellState)       -}+  ArrM f +++ ArrM g = ArrM $ runKleisli $ Kleisli f +++ Kleisli g+  ArrM { .. } +++ Cell { .. } = Cell+    { cellStep = \state -> \case+        Left a -> do+          b <- runArrM a+          return (Left b, state)+        Right c -> do+          (d, state') <- cellStep state c+          return (Right d, state')+    , ..+    }+  Cell { .. } +++ ArrM { .. } = Cell+    { cellStep = \state -> \case+        Left a -> do+          (b, state') <- cellStep state a+          return (Left b, state')+        Right c -> do+          d <- runArrM c+          return (Right d, state)+    , ..+    }   (Cell stateL stepL) +++ (Cell stateR stepR) = Cell { .. }     where       cellState = Choice stateL stateR

@@ -5,17 +5,25 @@ module LiveCoding.Migrate where  -- base+import Control.Arrow ((&&&))+import Control.Monad (guard) import Data.Data+import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Maybe import Prelude hiding (GT) +-- transformers+import Control.Monad.Trans.Class+import Control.Monad.Trans.State+ -- syb import Data.Generics.Aliases import Data.Generics.Twins  -- essence-of-live-coding import LiveCoding.Migrate.Debugger+import LiveCoding.Migrate.Cell import LiveCoding.Migrate.Migration \end{code} \end{comment}@@ -32,37 +40,43 @@  -- | Covers standard cases such as matching types, to and from debuggers, to newtypes. standardMigration :: Migration-standardMigration = castMigration <> migrationDebugging <> newtypeMigration---- | Wrapping 'treeMigrateWith' in the newtype.-treeMigration :: Migration -> Migration-treeMigration migration = Migration $ treeMigrateWith migration+standardMigration+  =  castMigration+  <> migrationDebugging+  <> migrationCell+  <> newtypeMigration  -- | The standard migration working horse. --   Tries to apply the given migration, --   and if this fails, tries to recurse into the data structure.-treeMigrateWith-  :: (Data a, Data b)-  => Migration-  -> a -> b -> Maybe a-+treeMigration :: Migration -> Migration+treeMigration specific -- Maybe the specified user migration works?-treeMigrateWith specific a b-  | Just a' <- runMigration specific a b-  = Just a'-+  = specific -- Maybe it's an algebraic datatype. -- Let's try and match the structure as well as possible.-treeMigrateWith specific a b-  |  isAlgType typeA  && isAlgType typeB-  && show typeA == show typeB-  && showConstr constrA == showConstr constrB-  = Just migrateSameConstr+  <> sameConstructorMigration specific+  <> constructorMigration specific++matchingAlgebraicDataTypes :: (Data a, Data b) => a -> b -> Bool+matchingAlgebraicDataTypes a b+  = isAlgType typeA+  && isAlgType typeB+  && dataTypeName typeA == dataTypeName typeB   where     typeA = dataTypeOf a     typeB = dataTypeOf b++-- | 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.+sameConstructorMigration :: Migration -> Migration+sameConstructorMigration specific = Migration $ \a b -> do+  guard $ matchingAlgebraicDataTypes a b+  let     constrA = toConstr a     constrB = toConstr b+  guard $ showConstr constrA == showConstr constrB+  let     constrFieldsA = constrFields constrA     constrFieldsB = constrFields constrB     migrateSameConstr@@ -76,12 +90,48 @@     getFieldSetters = constrFieldsA <&>       \field -> fromMaybe (GT id)         $ lookup field settersB+  return migrateSameConstr --- Defeat. No migration worked.-treeMigrateWith _ _ _ = Nothing+-- | Still assuming that both are algebraic data types, but the constructor names don't match.+--   In that case, we will try and recursively fill all the fields new constructor.+--   If this doesn't work, fail.+constructorMigration :: Migration -> Migration+constructorMigration specific = Migration $ \a b -> do+  let+    constrB = toConstr b+    constrFieldsB = constrFields constrB+  guard $ matchingAlgebraicDataTypes a b+  matchingConstructor <- dataTypeOf a+    & dataTypeConstrs+    & map (show &&& id)+    & lookup (showConstr constrB)+  let matchingConstructorFields = constrFields matchingConstructor+  fieldSetters <- if null constrFieldsB || null matchingConstructorFields+    -- We don't have record. Try to cast each field.+    then+      return $ getChildrenMaybe b+    -- We have records. Sort by all field names and try to cast+    else+      getChildrenMaybe b+        & zip constrFieldsB+        & flip lookup+        & flip map matchingConstructorFields+        & sequence+  flip evalStateT fieldSetters $ fromConstrM tryOneField matchingConstructor +tryOneField :: Data a => StateT [GenericR' Maybe] Maybe a+tryOneField = do+  (field : fields) <- get+  put fields+  lift $ unGR field --lift field+ getChildrenSetters :: Data a => Migration -> a -> [GenericT'] getChildrenSetters specific = gmapQ $ \child -> GT $ flip (runSafeMigration $ treeMigration specific) child++newtype GenericR' m = GR { unGR :: GenericR m }++getChildrenMaybe :: Data a => a -> [GenericR' Maybe]+getChildrenMaybe = gmapQ $ \child -> GR $ cast child  setChildren :: Data a => [GenericT'] -> a -> a setChildren updates a = snd $ gmapAccumT f updates a

@@ -0,0 +1,220 @@+{-# LANGUAGE RecordWildCards #-}+module LiveCoding.Migrate.Cell where++-- base+import Data.Data++-- syb+import Data.Generics.Aliases++-- essence-of-live-coding+import LiveCoding.Cell+import LiveCoding.Exceptions+import LiveCoding.Migrate.Migration++-- * Migrations involving sequential compositions of cells++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)++-- | Migrate @cell1@ to @cell1 >>> cell2@.+migrationToComposition1 :: Migration+migrationToComposition1 = migrationTo2 maybeMigrateToComposition1++maybeMigrateFromComposition1+  :: (Typeable state1', Typeable state1)+  => Composition state1 state2+  -> Maybe       state1'+maybeMigrateFromComposition1 (Composition (state1, _)) = cast state1++-- | Migrate to @cell1@ from @cell1 >>> cell2@.+migrationFromComposition1 :: Migration+migrationFromComposition1 = constMigrationFrom2 maybeMigrateFromComposition1++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 @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++-- | Combines all migrations related to composition, favouring the first argument.+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)++-- | Migrate @cell2@ to @cell1 *** cell2@.+migrationToParallel2 :: Migration+migrationToParallel2 = migrationTo2 maybeMigrateToParallel2++maybeMigrateFromParallel2+  :: (Typeable state2', Typeable state2)+  => Parallel state1 state2+  -> Maybe           state2'+maybeMigrateFromParallel2 (Parallel (_, state2)) = cast state2++-- | Migrate to @cell2@ from @cell1 *** cell2@.+migrationFromParallel2 :: Migration+migrationFromParallel2 = constMigrationFrom2 maybeMigrateFromParallel2++-- | Combines all migrations related to parallel composition, favouring the first argument.+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 { .. }++-- | Migrate @cell1@ to @cell1 ||| cell2@.+migrationToChoice1 :: Migration+migrationToChoice1 = migrationTo2 maybeMigrateToChoice1++maybeMigrateFromChoice1+  :: (Typeable stateLeft', Typeable stateLeft)+  => Choice stateLeft stateRight+  -> Maybe  stateLeft'+maybeMigrateFromChoice1 Choice { .. } = cast choiceLeft++-- | Migrate to @cell1@ from @cell1 ||| cell2@.+migrationFromChoice1 :: Migration+migrationFromChoice1 = constMigrationFrom2 maybeMigrateFromChoice1++maybeMigrateToChoice2+  :: (Typeable stateRight', Typeable stateRight)+  => Choice stateLeft stateRight+  -> stateRight'+  -> Maybe (Choice stateLeft stateRight)+maybeMigrateToChoice2 Choice { .. } choiceRight' = do+  choiceRight <- cast choiceRight'+  return Choice { .. }++-- | Migrate @cell2@ to @cell1 ||| cell2@.+migrationToChoice2 :: Migration+migrationToChoice2 = migrationTo2 maybeMigrateToChoice2++maybeMigrateFromChoice2+  :: (Typeable stateRight', Typeable stateRight)+  => Choice stateLeft stateRight+  -> Maybe            stateRight'+maybeMigrateFromChoice2 Choice { .. } = cast choiceRight++-- | Migrate to @cell2@ from @cell1 ||| cell2@.+migrationFromChoice2 :: Migration+migrationFromChoice2 = constMigrationFrom2 maybeMigrateFromChoice2++-- | Combines all migrations related to choice.+migrationChoice :: Migration+migrationChoice+  =  migrationToChoice1+  <> migrationFromChoice1+  <> migrationToChoice2+  <> migrationFromChoice2++-- * Control flow++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++-- | Migration from @cell2@ to @try cell1 >> safe cell2@+migrationToExceptState :: Migration+migrationToExceptState = migrationTo2 maybeMigrateToExceptState++maybeMigrateFromExceptState+  :: (Typeable state, Typeable state')+  => ExceptState state e+  -> Maybe       state'+maybeMigrateFromExceptState (NotThrown state) = cast state+maybeMigrateFromExceptState (Exception e) = Nothing++-- | Migration from @try cell1 >> safe cell2@ to @cell2@+migrationFromExceptState :: Migration+migrationFromExceptState = constMigrationFrom2 maybeMigrateFromExceptState++-- | Combines all control flow related migrations+migrationExceptState :: Migration+migrationExceptState = migrationToExceptState <> migrationFromExceptState++-- * Overall migration++-- | Combines all 'Cell'-related migrations.+migrationCell :: Migration+migrationCell+  =  migrationComposition+  <> migrationParallel+  <> migrationChoice+  <> migrationExceptState

@@ -3,38 +3,35 @@ module LiveCoding.Migrate.Debugger where  -- base-import Control.Monad (guard) import Data.Data-import Data.Maybe  -- essence-of-live-coding import LiveCoding.Debugger import LiveCoding.Migrate.Migration -migrateToDebugging-  :: Debugging dbgState state-  ->                    state-  -> Debugging dbgState state-migrateToDebugging Debugging { dbgState } state = Debugging { .. }+maybeMigrateToDebugging+  :: (Typeable state', Typeable state)+  => Debugging dbgState state+  -> state'+  -> Maybe (Debugging dbgState state)+maybeMigrateToDebugging Debugging { dbgState } state' = do+  state <- cast state'+  return Debugging { .. }  -- | Tries to cast the current state into the joint state of debugger and program. --   Will cast to the program state if possible, or else try to cast to the debugger state. migrationToDebugging :: Migration-migrationToDebugging = Migration $ \a b -> do-  guard $ ("Debugging" ==) $ dataTypeName $ dataTypeOf a-  gmapMo (const $ cast b) a+migrationToDebugging = migrationTo2 maybeMigrateToDebugging +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-migrationFromDebugging = Migration $ \_ b -> do-  guard $ ("Debugging" ==) $ dataTypeName $ dataTypeOf b-  listToMaybe $ catMaybes $ (gmapQ cast) b--migrateFromDebugging-  ::                    state-  -> Debugging dbgState state-  ->                    state-migrateFromDebugging _state Debugging { state } = state+migrationFromDebugging = constMigrationFrom2 maybeMigrateFromDebugging  -- | Combines 'migrationToDebugging' and 'migrationFromDebugging'. migrationDebugging :: Migration

@@ -9,6 +9,7 @@ import Data.Monoid  -- syb+import Data.Generics.Aliases import Data.Generics.Schemes (glength)  data Migration = Migration@@ -50,3 +51,15 @@   => (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 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 f = Migration $ \_ t -> ext2Q (const Nothing) f t

@@ -99,7 +99,7 @@ The package \texttt{foreign-store} \cite{foreign-store} offers a remedy: \mintinline{haskell}{var} can be stored persistently across reloads. To facilitate its usage, GHCi macros are defined for the initialisation and reload operations (Figure \ref{fig:ghci}).-\input{../essence-of-live-coding-ghci/src/LiveCoding/GHCi.lhs}+\input{../essence-of-live-coding/src/LiveCoding/GHCi.lhs} They assume the main live program and the \mintinline{haskell}{MVar} to be called \mintinline{haskell}{liveProgram} and \mintinline{haskell}{var}, respectively, but this can of course be generalised.

@@ -1,5 +1,13 @@+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TupleSections #-} +-- base+import Control.Arrow+import Data.Functor.Identity+import System.IO.Unsafe (unsafePerformIO)+ -- test-framework import Test.Framework @@ -21,25 +29,108 @@  tests =   [ testGroup "Builtin types"-    [ testProperty "Same" $ \(x :: Integer) (y :: Integer) -> x === migrate y x-    , testProperty "Different" $ \(x :: Integer) (y :: Bool) -> y === migrate y x+    [ 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 "" $ Foo1.foo' === migrate Foo1.foo Foo2.foo-    , testProperty "" $ Foo2.foo' === migrate Foo2.foo Foo1.foo-    , testProperty "" $ Foo2.bar' === migrate Foo2.bar Foo1.bar-    , testProperty "" $ Foo2.baz' === migrate Foo2.baz Foo1.baz+    [ 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 "" $ Foo2.frob' === migrateWith (userMigration intToInteger) Foo2.frob Foo1.frob+    [ testProperty "Can add migration from Int to Integer"+      $ Foo2.frob' === migrateWith (userMigration intToInteger) Foo2.frob Foo1.frob     ]-  , testGroup "Newtype wrapping"-    [ testProperty "" $ \(x :: Integer) -> Foo2.Frob x === migrate Foo2.frob x+  , 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 }+    [ 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]+        }+      ]+    ]   ]++withEvilDebugger :: Cell IO a b -> Cell Identity a b+withEvilDebugger cell = hoistCell (Identity . unsafePerformIO) $ withDebuggerC cell statePrint++countFrom :: Monad m => Int -> Cell m () Int+countFrom n = arr (const 1) >>> sumC >>> arr (+ n)++fromEither (Left  a) = a+fromEither (Right a) = a++data CellMigrationSimulation a b = CellMigrationSimulation+  { cell1 :: Cell Identity a b+  , cell2 :: Cell Identity a b+  , input1 :: [a]+  , input2 :: [a]+  , output1 :: [b]+  , output2 :: [b]+  }++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'++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'+  (bs2, _) <- steps cell2' as2+  return (bs1, bs2)

@@ -11,10 +11,15 @@ foo = Foo 1 False foo' = Foo 2 False -data Bar = Bar+data Bar+  = Bar   { barA :: Integer   , barD :: Integer   , barC :: Bool+  }+  | Baar+  { baarB :: Bool+  , baarA :: Int   }   deriving (Show, Eq, Typeable, Data) 

@@ -5,16 +5,22 @@ import Data.Data import Data.Typeable -data Foo = Foo Integer+data Foo+  = Fooo Integer+  | Foo  Integer   deriving (Show, Eq, Typeable, Data)  foo = Foo 2 foo' = Foo 1 -data Bar = Bar+data Bar+  = Bar   { barB :: Integer   , barA :: Integer   , barC :: String+  }+  | Baar+  { baarA :: Int   }   deriving (Show, Eq, Typeable, Data)