{-# LANGUAGE NamedFieldPuns #-} {-# 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.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) maybeMigrateToPair :: (t a b -> a) -> (t a b -> b) -> (a -> b -> t a b) -> t a b -> c -> Maybe (t a b) maybeMigrateToPair t a b -> a fst t a b -> b snd a -> b -> t a b cons t a b pair c c = do (a -> b -> t a b) -> b -> a -> t a b forall a b c. (a -> b -> c) -> b -> a -> c flip a -> b -> t a b cons (t a b -> b snd t a b pair) (a -> t a b) -> Maybe a -> Maybe (t a b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> c -> Maybe a forall a b. (Typeable a, Typeable b) => a -> Maybe b cast c c Maybe (t a b) -> Maybe (t a b) -> Maybe (t a b) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> a -> b -> t a b cons (t a b -> a fst t a b pair) (b -> t a b) -> Maybe b -> Maybe (t a b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> c -> Maybe b forall a b. (Typeable a, Typeable b) => a -> Maybe b cast c 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 maybeMigrateFromPair :: (t a b -> a) -> (t a b -> b) -> t a b -> Maybe c maybeMigrateFromPair t a b -> a fst t a b -> b snd t a b pair = a -> Maybe c forall a b. (Typeable a, Typeable b) => a -> Maybe b cast (t a b -> a fst t a b pair) Maybe c -> Maybe c -> Maybe c forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> b -> Maybe c forall a b. (Typeable a, Typeable b) => a -> Maybe b cast (t a b -> b snd t a b pair) -- ** Migrations involving sequential compositions of cells -- | Migrate @cell@ to @cell >>> cell'@, and if this fails, to @cell' >>> cell@. migrationToComposition :: Migration migrationToComposition :: Migration migrationToComposition = (forall a b c. (Typeable a, Typeable b, Typeable c) => Composition b c -> a -> Maybe (Composition b c)) -> Migration forall (t :: * -> * -> *). Typeable t => (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> a -> Maybe (t b c)) -> Migration migrationTo2 ((forall a b c. (Typeable a, Typeable b, Typeable c) => Composition b c -> a -> Maybe (Composition b c)) -> Migration) -> (forall a b c. (Typeable a, Typeable b, Typeable c) => Composition b c -> a -> Maybe (Composition b c)) -> Migration forall a b. (a -> b) -> a -> b $ (Composition b c -> b) -> (Composition b c -> c) -> (b -> c -> Composition b c) -> Composition b c -> a -> Maybe (Composition b c) forall a b c (t :: * -> * -> *). (Typeable a, Typeable b, Typeable c) => (t a b -> a) -> (t a b -> b) -> (a -> b -> t a b) -> t a b -> c -> Maybe (t a b) maybeMigrateToPair Composition b c -> b forall state1 state2. Composition state1 state2 -> state1 state1 Composition b c -> c forall state1 state2. Composition state1 state2 -> state2 state2 b -> c -> Composition b c forall state1 state2. state1 -> state2 -> Composition state1 state2 Composition -- | Migrate @cell1 >>> cell2@ to @cell1@, and if this fails, to @cell2@. migrationFromComposition :: Migration migrationFromComposition :: Migration migrationFromComposition = (forall a b c. (Typeable a, Typeable b, Typeable c) => Composition b c -> Maybe a) -> Migration forall (t :: * -> * -> *). Typeable t => (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> Maybe a) -> Migration constMigrationFrom2 ((forall a b c. (Typeable a, Typeable b, Typeable c) => Composition b c -> Maybe a) -> Migration) -> (forall a b c. (Typeable a, Typeable b, Typeable c) => Composition b c -> Maybe a) -> Migration forall a b. (a -> b) -> a -> b $ (Composition b c -> b) -> (Composition b c -> c) -> Composition b c -> Maybe a forall a b c (t :: * -> * -> *). (Typeable a, Typeable b, Typeable c) => (t a b -> a) -> (t a b -> b) -> t a b -> Maybe c maybeMigrateFromPair Composition b c -> b forall state1 state2. Composition state1 state2 -> state1 state1 Composition b c -> c forall state1 state2. Composition state1 state2 -> state2 state2 -- | Combines all migrations related to composition, favouring migration to compositions. migrationComposition :: Migration migrationComposition :: Migration migrationComposition = Migration migrationToComposition Migration -> Migration -> Migration forall a. Semigroup a => a -> a -> a <> Migration migrationFromComposition -- ** Migrations involving parallel compositions of cells -- | Migrate @cell@ to @cell *** cell'@, and if this fails, to @cell' *** cell@. migrationToParallel :: Migration migrationToParallel :: Migration migrationToParallel = (forall a b c. (Typeable a, Typeable b, Typeable c) => Parallel b c -> a -> Maybe (Parallel b c)) -> Migration forall (t :: * -> * -> *). Typeable t => (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> a -> Maybe (t b c)) -> Migration migrationTo2 ((forall a b c. (Typeable a, Typeable b, Typeable c) => Parallel b c -> a -> Maybe (Parallel b c)) -> Migration) -> (forall a b c. (Typeable a, Typeable b, Typeable c) => Parallel b c -> a -> Maybe (Parallel b c)) -> Migration forall a b. (a -> b) -> a -> b $ (Parallel b c -> b) -> (Parallel b c -> c) -> (b -> c -> Parallel b c) -> Parallel b c -> a -> Maybe (Parallel b c) forall a b c (t :: * -> * -> *). (Typeable a, Typeable b, Typeable c) => (t a b -> a) -> (t a b -> b) -> (a -> b -> t a b) -> t a b -> c -> Maybe (t a b) maybeMigrateToPair Parallel b c -> b forall stateP1 stateP2. Parallel stateP1 stateP2 -> stateP1 stateP1 Parallel b c -> c forall stateP1 stateP2. Parallel stateP1 stateP2 -> stateP2 stateP2 b -> c -> Parallel b c forall stateP1 stateP2. stateP1 -> stateP2 -> Parallel stateP1 stateP2 Parallel -- | Migrate from @cell1 *** cell2@ to @cell1@, and if this fails, to @cell2@. migrationFromParallel :: Migration migrationFromParallel :: Migration migrationFromParallel = (forall a b c. (Typeable a, Typeable b, Typeable c) => Parallel b c -> Maybe a) -> Migration forall (t :: * -> * -> *). Typeable t => (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> Maybe a) -> Migration constMigrationFrom2 ((forall a b c. (Typeable a, Typeable b, Typeable c) => Parallel b c -> Maybe a) -> Migration) -> (forall a b c. (Typeable a, Typeable b, Typeable c) => Parallel b c -> Maybe a) -> Migration forall a b. (a -> b) -> a -> b $ (Parallel b c -> b) -> (Parallel b c -> c) -> Parallel b c -> Maybe a forall a b c (t :: * -> * -> *). (Typeable a, Typeable b, Typeable c) => (t a b -> a) -> (t a b -> b) -> t a b -> Maybe c maybeMigrateFromPair Parallel b c -> b forall stateP1 stateP2. Parallel stateP1 stateP2 -> stateP1 stateP1 Parallel b c -> c forall stateP1 stateP2. Parallel stateP1 stateP2 -> stateP2 stateP2 -- | Combines all migrations related to parallel composition, favouring migration to parallel composition. migrationParallel :: Migration migrationParallel :: Migration migrationParallel = Migration migrationToParallel Migration -> Migration -> Migration forall a. Semigroup a => a -> a -> a <> Migration migrationFromParallel -- ** Migration involving 'ArrowChoice' -- | Migrate @cell@ to @cell ||| cell'@, and if this fails, to @cell' ||| cell@. migrationToChoice :: Migration migrationToChoice :: Migration migrationToChoice = (forall a b c. (Typeable a, Typeable b, Typeable c) => Choice b c -> a -> Maybe (Choice b c)) -> Migration forall (t :: * -> * -> *). Typeable t => (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> a -> Maybe (t b c)) -> Migration migrationTo2 ((forall a b c. (Typeable a, Typeable b, Typeable c) => Choice b c -> a -> Maybe (Choice b c)) -> Migration) -> (forall a b c. (Typeable a, Typeable b, Typeable c) => Choice b c -> a -> Maybe (Choice b c)) -> Migration forall a b. (a -> b) -> a -> b $ (Choice b c -> b) -> (Choice b c -> c) -> (b -> c -> Choice b c) -> Choice b c -> a -> Maybe (Choice b c) forall a b c (t :: * -> * -> *). (Typeable a, Typeable b, Typeable c) => (t a b -> a) -> (t a b -> b) -> (a -> b -> t a b) -> t a b -> c -> Maybe (t a b) maybeMigrateToPair Choice b c -> b forall stateL stateR. Choice stateL stateR -> stateL choiceLeft Choice b c -> c forall stateL stateR. Choice stateL stateR -> stateR choiceRight b -> c -> Choice b c forall stateL stateR. stateL -> stateR -> Choice stateL stateR Choice -- | Migrate from @cell1 ||| cell2@ to @cell1@, and if this fails, to @cell2@. migrationFromChoice :: Migration migrationFromChoice :: Migration migrationFromChoice = (forall a b c. (Typeable a, Typeable b, Typeable c) => Choice b c -> Maybe a) -> Migration forall (t :: * -> * -> *). Typeable t => (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> Maybe a) -> Migration constMigrationFrom2 ((forall a b c. (Typeable a, Typeable b, Typeable c) => Choice b c -> Maybe a) -> Migration) -> (forall a b c. (Typeable a, Typeable b, Typeable c) => Choice b c -> Maybe a) -> Migration forall a b. (a -> b) -> a -> b $ (Choice b c -> b) -> (Choice b c -> c) -> Choice b c -> Maybe a forall a b c (t :: * -> * -> *). (Typeable a, Typeable b, Typeable c) => (t a b -> a) -> (t a b -> b) -> t a b -> Maybe c maybeMigrateFromPair Choice b c -> b forall stateL stateR. Choice stateL stateR -> stateL choiceLeft Choice b c -> c forall stateL stateR. Choice stateL stateR -> stateR choiceRight -- | Combines all migrations related to choice, favouring migration to choice. migrationChoice :: Migration migrationChoice :: Migration migrationChoice = Migration migrationToChoice Migration -> Migration -> Migration forall a. Semigroup a => a -> a -> a <> Migration migrationFromChoice -- ** Feedback -- | Migrate from @cell@ to @feedback s cell@, and if this fails, to @feedback (cellState cell) cell'@. migrationToFeedback :: Migration migrationToFeedback :: Migration migrationToFeedback = (forall a b c. (Typeable a, Typeable b, Typeable c) => Feedback b c -> a -> Maybe (Feedback b c)) -> Migration forall (t :: * -> * -> *). Typeable t => (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> a -> Maybe (t b c)) -> Migration migrationTo2 ((forall a b c. (Typeable a, Typeable b, Typeable c) => Feedback b c -> a -> Maybe (Feedback b c)) -> Migration) -> (forall a b c. (Typeable a, Typeable b, Typeable c) => Feedback b c -> a -> Maybe (Feedback b c)) -> Migration forall a b. (a -> b) -> a -> b $ (Feedback b c -> b) -> (Feedback b c -> c) -> (b -> c -> Feedback b c) -> Feedback b c -> a -> Maybe (Feedback b c) forall a b c (t :: * -> * -> *). (Typeable a, Typeable b, Typeable c) => (t a b -> a) -> (t a b -> b) -> (a -> b -> t a b) -> t a b -> c -> Maybe (t a b) maybeMigrateToPair Feedback b c -> b forall sPrevious sAdditional. Feedback sPrevious sAdditional -> sPrevious sPrevious Feedback b c -> c forall sPrevious sAdditional. Feedback sPrevious sAdditional -> sAdditional sAdditional b -> c -> Feedback b c forall sPrevious sAdditional. sPrevious -> sAdditional -> Feedback sPrevious sAdditional Feedback -- | Migrate from @feedback s cell@ to @cell@, and if this fails, to @Cell { cellState = s, .. }@. migrationFromFeedback :: Migration migrationFromFeedback :: Migration migrationFromFeedback = (forall a b c. (Typeable a, Typeable b, Typeable c) => Feedback b c -> Maybe a) -> Migration forall (t :: * -> * -> *). Typeable t => (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> Maybe a) -> Migration constMigrationFrom2 ((forall a b c. (Typeable a, Typeable b, Typeable c) => Feedback b c -> Maybe a) -> Migration) -> (forall a b c. (Typeable a, Typeable b, Typeable c) => Feedback b c -> Maybe a) -> Migration forall a b. (a -> b) -> a -> b $ (Feedback b c -> b) -> (Feedback b c -> c) -> Feedback b c -> Maybe a forall a b c (t :: * -> * -> *). (Typeable a, Typeable b, Typeable c) => (t a b -> a) -> (t a b -> b) -> t a b -> Maybe c maybeMigrateFromPair Feedback b c -> b forall sPrevious sAdditional. Feedback sPrevious sAdditional -> sPrevious sPrevious Feedback b c -> c forall sPrevious sAdditional. Feedback sPrevious sAdditional -> sAdditional sAdditional -- | Combines all migrations related to feedback, favouring migration to feedback. migrationFeedback :: Migration migrationFeedback :: Migration migrationFeedback = Migration migrationToFeedback Migration -> Migration -> Migration forall a. Semigroup a => a -> a -> a <> Migration migrationFromFeedback -- * Control flow maybeMigrateToExceptState :: (Typeable state, Typeable state') => ExceptState state e -> state' -> Maybe (ExceptState state e) maybeMigrateToExceptState :: ExceptState state e -> state' -> Maybe (ExceptState state e) maybeMigrateToExceptState (NotThrown state _) state' state = state -> ExceptState state e forall state e. state -> ExceptState state e NotThrown (state -> ExceptState state e) -> Maybe state -> Maybe (ExceptState state e) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> state' -> Maybe state forall a b. (Typeable a, Typeable b) => a -> Maybe b cast state' state maybeMigrateToExceptState (Exception e e) state' _ = ExceptState state e -> Maybe (ExceptState state e) forall a. a -> Maybe a Just (ExceptState state e -> Maybe (ExceptState state e)) -> ExceptState state e -> Maybe (ExceptState state e) forall a b. (a -> b) -> a -> b $ e -> ExceptState state e forall state e. e -> ExceptState state e Exception e e -- | Migration from @cell2@ to @try cell1 >> safe cell2@ migrationToExceptState :: Migration migrationToExceptState :: Migration migrationToExceptState = (forall a b c. (Typeable a, Typeable b, Typeable c) => ExceptState b c -> a -> Maybe (ExceptState b c)) -> Migration forall (t :: * -> * -> *). Typeable t => (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> a -> Maybe (t b c)) -> Migration migrationTo2 forall a b c. (Typeable a, Typeable b, Typeable c) => ExceptState b c -> a -> Maybe (ExceptState b c) forall state state' e. (Typeable state, Typeable state') => ExceptState state e -> state' -> Maybe (ExceptState state e) maybeMigrateToExceptState maybeMigrateFromExceptState :: (Typeable state, Typeable state') => ExceptState state e -> Maybe state' maybeMigrateFromExceptState :: ExceptState state e -> Maybe state' maybeMigrateFromExceptState (NotThrown state state) = state -> Maybe state' forall a b. (Typeable a, Typeable b) => a -> Maybe b cast state state maybeMigrateFromExceptState (Exception e e) = Maybe state' forall a. Maybe a Nothing -- | Migration from @try cell1 >> safe cell2@ to @cell2@ migrationFromExceptState :: Migration migrationFromExceptState :: Migration migrationFromExceptState = (forall a b c. (Typeable a, Typeable b, Typeable c) => ExceptState b c -> Maybe a) -> Migration forall (t :: * -> * -> *). Typeable t => (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> Maybe a) -> Migration constMigrationFrom2 forall a b c. (Typeable a, Typeable b, Typeable c) => ExceptState b c -> Maybe a forall state state' e. (Typeable state, Typeable state') => ExceptState state e -> Maybe state' maybeMigrateFromExceptState -- | Combines all control flow related migrations migrationExceptState :: Migration migrationExceptState :: Migration migrationExceptState = Migration migrationToExceptState Migration -> Migration -> Migration forall a. Semigroup a => a -> a -> a <> Migration migrationFromExceptState -- * Overall migration -- | Combines all 'Cell'-related migrations. migrationCell :: Migration migrationCell :: Migration migrationCell = Migration migrationComposition Migration -> Migration -> Migration forall a. Semigroup a => a -> a -> a <> Migration migrationParallel Migration -> Migration -> Migration forall a. Semigroup a => a -> a -> a <> Migration migrationChoice Migration -> Migration -> Migration forall a. Semigroup a => a -> a -> a <> Migration migrationExceptState Migration -> Migration -> Migration forall a. Semigroup a => a -> a -> a <> Migration migrationFeedback