{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
module LiveCoding.Migrate.Cell where
import Data.Data
import Data.Generics.Aliases
import LiveCoding.Cell
import LiveCoding.Cell.Feedback
import LiveCoding.Exceptions
import LiveCoding.Migrate.Migration
import Control.Applicative (Alternative((<|>)))
maybeMigrateToPair
:: (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 fst snd cons pair c = do
flip cons (snd pair) <$> cast c <|> cons (fst pair) <$> cast c
maybeMigrateFromPair
:: (Typeable a, Typeable b, Typeable c)
=> (t a b -> a)
-> (t a b -> b)
-> t a b
-> Maybe c
maybeMigrateFromPair fst snd pair = cast (fst pair) <|> cast (snd pair)
migrationToComposition :: Migration
migrationToComposition = migrationTo2 $ maybeMigrateToPair state1 state2 Composition
migrationFromComposition :: Migration
migrationFromComposition = constMigrationFrom2 $ maybeMigrateFromPair state1 state2
migrationComposition :: Migration
migrationComposition
= migrationToComposition
<> migrationFromComposition
migrationToParallel :: Migration
migrationToParallel = migrationTo2 $ maybeMigrateToPair stateP1 stateP2 Parallel
migrationFromParallel :: Migration
migrationFromParallel = constMigrationFrom2 $ maybeMigrateFromPair stateP1 stateP2
migrationParallel :: Migration
migrationParallel
= migrationToParallel
<> migrationFromParallel
migrationToChoice :: Migration
migrationToChoice = migrationTo2 $ maybeMigrateToPair choiceLeft choiceRight Choice
migrationFromChoice :: Migration
migrationFromChoice = constMigrationFrom2 $ maybeMigrateFromPair choiceLeft choiceRight
migrationChoice :: Migration
migrationChoice
= migrationToChoice
<> migrationFromChoice
migrationToFeedback :: Migration
migrationToFeedback = migrationTo2 $ maybeMigrateToPair sPrevious sAdditional Feedback
migrationFromFeedback :: Migration
migrationFromFeedback = constMigrationFrom2 $ maybeMigrateFromPair sPrevious sAdditional
migrationFeedback :: Migration
migrationFeedback = migrationToFeedback <> migrationFromFeedback
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
migrationToExceptState :: Migration
migrationToExceptState = migrationTo2 maybeMigrateToExceptState
maybeMigrateFromExceptState
:: (Typeable state, Typeable state')
=> ExceptState state e
-> Maybe state'
maybeMigrateFromExceptState (NotThrown state) = cast state
maybeMigrateFromExceptState (Exception e) = Nothing
migrationFromExceptState :: Migration
migrationFromExceptState = constMigrationFrom2 maybeMigrateFromExceptState
migrationExceptState :: Migration
migrationExceptState = migrationToExceptState <> migrationFromExceptState
migrationCell :: Migration
migrationCell
= migrationComposition
<> migrationParallel
<> migrationChoice
<> migrationExceptState
<> migrationFeedback