essence-of-live-coding-0.2.7: src/LiveCoding/Migrate/Cell.hs

{-# 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 fst snd cons pair c = do
  flip cons (snd pair) <$> cast c <|> cons (fst pair) <$> cast 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 fst snd pair = cast (fst pair) <|> cast (snd pair)

-- ** Migrations involving sequential compositions of cells

-- | Migrate @cell@ to @cell >>> cell'@, and if this fails, to @cell' >>> cell@.
migrationToComposition :: Migration
migrationToComposition = migrationTo2 $ maybeMigrateToPair state1 state2 Composition

-- | Migrate @cell1 >>> cell2@ to @cell1@, and if this fails, to @cell2@.
migrationFromComposition :: Migration
migrationFromComposition = constMigrationFrom2 $ maybeMigrateFromPair state1 state2

-- | Combines all migrations related to composition, favouring migration to compositions.
migrationComposition :: Migration
migrationComposition =
  migrationToComposition
    <> migrationFromComposition

-- ** Migrations involving parallel compositions of cells

-- | Migrate @cell@ to @cell *** cell'@, and if this fails, to @cell' *** cell@.
migrationToParallel :: Migration
migrationToParallel = migrationTo2 $ maybeMigrateToPair stateP1 stateP2 Parallel

-- | Migrate from @cell1 *** cell2@ to @cell1@, and if this fails, to @cell2@.
migrationFromParallel :: Migration
migrationFromParallel = constMigrationFrom2 $ maybeMigrateFromPair stateP1 stateP2

-- | Combines all migrations related to parallel composition, favouring migration to parallel composition.
migrationParallel :: Migration
migrationParallel =
  migrationToParallel
    <> migrationFromParallel

-- ** Migration involving 'ArrowChoice'

-- | Migrate @cell@ to @cell ||| cell'@, and if this fails, to @cell' ||| cell@.
migrationToChoice :: Migration
migrationToChoice = migrationTo2 $ maybeMigrateToPair choiceLeft choiceRight Choice

-- | Migrate from @cell1 ||| cell2@ to @cell1@, and if this fails, to @cell2@.
migrationFromChoice :: Migration
migrationFromChoice = constMigrationFrom2 $ maybeMigrateFromPair choiceLeft choiceRight

-- | Combines all migrations related to choice, favouring migration to choice.
migrationChoice :: Migration
migrationChoice =
  migrationToChoice
    <> migrationFromChoice

-- ** Feedback

-- | Migrate from @cell@ to @feedback s cell@, and if this fails, to @feedback (cellState cell) cell'@.
migrationToFeedback :: Migration
migrationToFeedback = migrationTo2 $ maybeMigrateToPair sPrevious sAdditional Feedback

-- | Migrate from @feedback s cell@ to @cell@, and if this fails, to @Cell { cellState = s, .. }@.
migrationFromFeedback :: Migration
migrationFromFeedback = constMigrationFrom2 $ maybeMigrateFromPair sPrevious sAdditional

-- | Combines all migrations related to feedback, favouring migration to feedback.
migrationFeedback :: Migration
migrationFeedback = migrationToFeedback <> migrationFromFeedback

-- * 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
    <> migrationFeedback