{-# 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