{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

module LiveCoding.Migrate.Cell where

-- base
import Data.Data

-- syb
import Data.Generics.Aliases

-- essence-of-live-coding

import Control.Applicative (Alternative ((<|>)))
import LiveCoding.Cell
import LiveCoding.Cell.Feedback
import LiveCoding.Exceptions
import LiveCoding.Migrate.Migration

-- * 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) =>
  -- | The accessor of the first element
  (t a b -> a) ->
  -- | The accessor of the second element
  (t a b -> b) ->
  -- | The constructor
  (a -> b -> t a b) ->
  -- | The pair
  t a b ->
  -- | The new value for the first or second element
  c ->
  Maybe (t a b)
maybeMigrateToPair :: 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 t a b -> a
fst t a b -> b
snd a -> b -> t a b
cons t a b
pair c
c = do
  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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast c
c 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) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f 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) =>
  -- | The accessor of the first element
  (t a b -> a) ->
  -- | The accessor of the second element
  (t a b -> b) ->
  t a b ->
  Maybe c
maybeMigrateFromPair :: 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 t a b -> a
fst t a b -> b
snd t a b
pair = forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (t a b -> a
fst t a b
pair) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> 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 (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. (a -> b) -> a -> b
$ 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 forall state1 state2. Composition state1 state2 -> state1
state1 forall state1 state2. Composition state1 state2 -> state2
state2 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 (t :: * -> * -> *).
Typeable t =>
(forall a b c.
 (Typeable a, Typeable b, Typeable c) =>
 t b c -> Maybe a)
-> Migration
constMigrationFrom2 forall a b. (a -> b) -> a -> b
$ 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 forall state1 state2. Composition state1 state2 -> state1
state1 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
    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 (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. (a -> b) -> a -> b
$ 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 forall stateP1 stateP2. Parallel stateP1 stateP2 -> stateP1
stateP1 forall stateP1 stateP2. Parallel stateP1 stateP2 -> stateP2
stateP2 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 (t :: * -> * -> *).
Typeable t =>
(forall a b c.
 (Typeable a, Typeable b, Typeable c) =>
 t b c -> Maybe a)
-> Migration
constMigrationFrom2 forall a b. (a -> b) -> a -> b
$ 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 forall stateP1 stateP2. Parallel stateP1 stateP2 -> stateP1
stateP1 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
    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 (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. (a -> b) -> a -> b
$ 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 forall stateL stateR. Choice stateL stateR -> stateL
choiceLeft forall stateL stateR. Choice stateL stateR -> stateR
choiceRight 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 (t :: * -> * -> *).
Typeable t =>
(forall a b c.
 (Typeable a, Typeable b, Typeable c) =>
 t b c -> Maybe a)
-> Migration
constMigrationFrom2 forall a b. (a -> b) -> a -> b
$ 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 forall stateL stateR. Choice stateL stateR -> stateL
choiceLeft 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
    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 (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. (a -> b) -> a -> b
$ 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 forall sPrevious sAdditional.
Feedback sPrevious sAdditional -> sPrevious
sPrevious forall sPrevious sAdditional.
Feedback sPrevious sAdditional -> sAdditional
sAdditional 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 (t :: * -> * -> *).
Typeable t =>
(forall a b c.
 (Typeable a, Typeable b, Typeable c) =>
 t b c -> Maybe a)
-> Migration
constMigrationFrom2 forall a b. (a -> b) -> a -> b
$ 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 forall sPrevious sAdditional.
Feedback sPrevious sAdditional -> sPrevious
sPrevious 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 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 :: forall state state' e.
(Typeable state, Typeable state') =>
ExceptState state e -> state' -> Maybe (ExceptState state e)
maybeMigrateToExceptState (NotThrown state
_) state'
state = forall state e. state -> ExceptState state e
NotThrown forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast state'
state
maybeMigrateToExceptState (Exception e
e) state'
_ = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall state e. e -> ExceptState state e
Exception e
e

-- | Migration from @cell2@ to @try cell1 >> safe cell2@
migrationToExceptState :: Migration
migrationToExceptState :: Migration
migrationToExceptState = 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 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 :: forall state state' e.
(Typeable state, Typeable state') =>
ExceptState state e -> Maybe state'
maybeMigrateFromExceptState (NotThrown state
state) = forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast state
state
maybeMigrateFromExceptState (Exception e
e) = forall a. Maybe a
Nothing

-- | Migration from @try cell1 >> safe cell2@ to @cell2@
migrationFromExceptState :: Migration
migrationFromExceptState :: Migration
migrationFromExceptState = forall (t :: * -> * -> *).
Typeable t =>
(forall a b c.
 (Typeable a, Typeable b, Typeable c) =>
 t b c -> Maybe a)
-> Migration
constMigrationFrom2 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 forall a. Semigroup a => a -> a -> a
<> Migration
migrationFromExceptState

-- * Overall migration

-- | Combines all 'Cell'-related migrations.
migrationCell :: Migration
migrationCell :: Migration
migrationCell =
  Migration
migrationComposition
    forall a. Semigroup a => a -> a -> a
<> Migration
migrationParallel
    forall a. Semigroup a => a -> a -> a
<> Migration
migrationChoice
    forall a. Semigroup a => a -> a -> a
<> Migration
migrationExceptState
    forall a. Semigroup a => a -> a -> a
<> Migration
migrationFeedback