\begin{comment}
\begin{code}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RankNTypes #-}
module LiveCoding.Migrate where

-- base
import Control.Arrow ((&&&))
import Control.Monad (guard)
import Data.Data
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Maybe
import Prelude hiding (GT)

-- transformers
import Control.Monad.Trans.Class
import Control.Monad.Trans.State

-- syb
import Data.Generics.Aliases
import Data.Generics.Twins

-- essence-of-live-coding
import LiveCoding.Migrate.Debugger
import LiveCoding.Migrate.Cell
import LiveCoding.Migrate.Monad.Trans
import LiveCoding.Migrate.Migration
\end{code}
\end{comment}

\begin{code}
-- | The standard migration solution, recursing into the data structure and applying 'standardMigration'.
migrate :: (Data a, Data b) => a -> b -> a
migrate :: a -> b -> a
migrate = Migration -> a -> b -> a
forall a b. (Data a, Data b) => Migration -> a -> b -> a
migrateWith Migration
standardMigration

-- | Still recurse into the data structure, but apply your own given migration.
--   Often you will want to call @migrateWith (standardMigration <> yourMigration)@.
migrateWith :: (Data a, Data b) => Migration -> a -> b -> a
migrateWith :: Migration -> a -> b -> a
migrateWith Migration
specific = Migration -> a -> b -> a
forall a b. (Data a, Data b) => Migration -> a -> b -> a
runSafeMigration (Migration -> a -> b -> a) -> Migration -> a -> b -> a
forall a b. (a -> b) -> a -> b
$ Migration -> Migration
treeMigration Migration
specific

-- | Covers standard cases such as matching types, to and from debuggers, to newtypes.
standardMigration :: Migration
standardMigration :: Migration
standardMigration
  =  Migration
castMigration
  Migration -> Migration -> Migration
forall a. Semigroup a => a -> a -> a
<> Migration
migrationDebugging
  Migration -> Migration -> Migration
forall a. Semigroup a => a -> a -> a
<> Migration
migrationCell
  Migration -> Migration -> Migration
forall a. Semigroup a => a -> a -> a
<> Migration
newtypeMigration
  Migration -> Migration -> Migration
forall a. Semigroup a => a -> a -> a
<> Migration
migrationState

-- | The standard migration working horse.
--   Tries to apply the given migration,
--   and if this fails, tries to recurse into the data structure.
treeMigration :: Migration -> Migration
treeMigration :: Migration -> Migration
treeMigration Migration
specific
-- Maybe the specified user migration works?
  = Migration
specific
-- Maybe it's an algebraic datatype.
-- Let's try and match the structure as well as possible.
  Migration -> Migration -> Migration
forall a. Semigroup a => a -> a -> a
<> Migration -> Migration
sameConstructorMigration Migration
specific
  Migration -> Migration -> Migration
forall a. Semigroup a => a -> a -> a
<> Migration -> Migration
constructorMigration Migration
specific

matchingAlgebraicDataTypes :: (Data a, Data b) => a -> b -> Bool
matchingAlgebraicDataTypes :: a -> b -> Bool
matchingAlgebraicDataTypes a
a b
b
  = DataType -> Bool
isAlgType DataType
typeA
  Bool -> Bool -> Bool
&& DataType -> Bool
isAlgType DataType
typeB
  Bool -> Bool -> Bool
&& DataType -> String
dataTypeName DataType
typeA String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== DataType -> String
dataTypeName DataType
typeB
  where
    typeA :: DataType
typeA = a -> DataType
forall a. Data a => a -> DataType
dataTypeOf a
a
    typeB :: DataType
typeB = b -> DataType
forall a. Data a => a -> DataType
dataTypeOf b
b

-- | Assuming that both are algebraic data types, possibly the constructor names match.
--   In that case, we will try and recursively migrate as much data as possible onto the new constructor.
sameConstructorMigration :: Migration -> Migration
sameConstructorMigration :: Migration -> Migration
sameConstructorMigration Migration
specific = (forall a b. (Data a, Data b) => a -> b -> Maybe a) -> Migration
Migration ((forall a b. (Data a, Data b) => a -> b -> Maybe a) -> Migration)
-> (forall a b. (Data a, Data b) => a -> b -> Maybe a) -> Migration
forall a b. (a -> b) -> a -> b
$ \a
a b
b -> do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ a -> b -> Bool
forall a b. (Data a, Data b) => a -> b -> Bool
matchingAlgebraicDataTypes a
a b
b
  let
    constrA :: Constr
constrA = a -> Constr
forall a. Data a => a -> Constr
toConstr a
a
    constrB :: Constr
constrB = b -> Constr
forall a. Data a => a -> Constr
toConstr b
b
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Constr -> String
showConstr Constr
constrA String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Constr -> String
showConstr Constr
constrB
  let
    constrFieldsA :: [String]
constrFieldsA = Constr -> [String]
constrFields Constr
constrA
    constrFieldsB :: [String]
constrFieldsB = Constr -> [String]
constrFields Constr
constrB
    migrateSameConstr :: a
migrateSameConstr
      -- We have records, we can match on the field labels
      |  (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
constrFieldsA)
      Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
constrFieldsB)
      = [GenericT'] -> a -> a
forall a. Data a => [GenericT'] -> a -> a
setChildren [GenericT']
getFieldSetters a
a
      -- One of the two is not a record, just try to match 1-1 as far as possible
      | Bool
otherwise = [GenericT'] -> a -> a
forall a. Data a => [GenericT'] -> a -> a
setChildren (Migration -> b -> [GenericT']
forall a. Data a => Migration -> a -> [GenericT']
getChildrenSetters Migration
specific b
b) a
a
    settersB :: [(String, GenericT')]
settersB = [String] -> [GenericT'] -> [(String, GenericT')]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
constrFieldsB ([GenericT'] -> [(String, GenericT')])
-> [GenericT'] -> [(String, GenericT')]
forall a b. (a -> b) -> a -> b
$ Migration -> b -> [GenericT']
forall a. Data a => Migration -> a -> [GenericT']
getChildrenSetters Migration
specific b
b
    getFieldSetters :: [GenericT']
getFieldSetters = [String]
constrFieldsA [String] -> (String -> GenericT') -> [GenericT']
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
      \String
field -> GenericT' -> Maybe GenericT' -> GenericT'
forall a. a -> Maybe a -> a
fromMaybe ((forall a. Data a => a -> a) -> GenericT'
GT forall a. a -> a
forall a. Data a => a -> a
id)
        (Maybe GenericT' -> GenericT') -> Maybe GenericT' -> GenericT'
forall a b. (a -> b) -> a -> b
$ String -> [(String, GenericT')] -> Maybe GenericT'
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
field [(String, GenericT')]
settersB
  a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return a
migrateSameConstr

-- | Still assuming that both are algebraic data types, but the constructor names don't match.
--   In that case, we will try and recursively fill all the fields new constructor.
--   If this doesn't work, fail.
constructorMigration :: Migration -> Migration
constructorMigration :: Migration -> Migration
constructorMigration Migration
specific = (forall a b. (Data a, Data b) => a -> b -> Maybe a) -> Migration
Migration ((forall a b. (Data a, Data b) => a -> b -> Maybe a) -> Migration)
-> (forall a b. (Data a, Data b) => a -> b -> Maybe a) -> Migration
forall a b. (a -> b) -> a -> b
$ \a
a b
b -> do
  let
    constrB :: Constr
constrB = b -> Constr
forall a. Data a => a -> Constr
toConstr b
b
    constrFieldsB :: [String]
constrFieldsB = Constr -> [String]
constrFields Constr
constrB
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ a -> b -> Bool
forall a b. (Data a, Data b) => a -> b -> Bool
matchingAlgebraicDataTypes a
a b
b
  Constr
matchingConstructor <- a -> DataType
forall a. Data a => a -> DataType
dataTypeOf a
a
    DataType -> (DataType -> [Constr]) -> [Constr]
forall a b. a -> (a -> b) -> b
& DataType -> [Constr]
dataTypeConstrs
    [Constr] -> ([Constr] -> [(String, Constr)]) -> [(String, Constr)]
forall a b. a -> (a -> b) -> b
& (Constr -> (String, Constr)) -> [Constr] -> [(String, Constr)]
forall a b. (a -> b) -> [a] -> [b]
map (Constr -> String
forall a. Show a => a -> String
show (Constr -> String)
-> (Constr -> Constr) -> Constr -> (String, Constr)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Constr -> Constr
forall a. a -> a
id)
    [(String, Constr)]
-> ([(String, Constr)] -> Maybe Constr) -> Maybe Constr
forall a b. a -> (a -> b) -> b
& String -> [(String, Constr)] -> Maybe Constr
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Constr -> String
showConstr Constr
constrB)
  let matchingConstructorFields :: [String]
matchingConstructorFields = Constr -> [String]
constrFields Constr
matchingConstructor
  [GenericR' Maybe]
fieldSetters <- if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
constrFieldsB Bool -> Bool -> Bool
|| [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
matchingConstructorFields
    -- We don't have record. Try to cast each field.
    then
      [GenericR' Maybe] -> Maybe [GenericR' Maybe]
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenericR' Maybe] -> Maybe [GenericR' Maybe])
-> [GenericR' Maybe] -> Maybe [GenericR' Maybe]
forall a b. (a -> b) -> a -> b
$ b -> [GenericR' Maybe]
forall a. Data a => a -> [GenericR' Maybe]
getChildrenMaybe b
b
    -- We have records. Sort by all field names and try to cast
    else
      b -> [GenericR' Maybe]
forall a. Data a => a -> [GenericR' Maybe]
getChildrenMaybe b
b
        [GenericR' Maybe]
-> ([GenericR' Maybe] -> [(String, GenericR' Maybe)])
-> [(String, GenericR' Maybe)]
forall a b. a -> (a -> b) -> b
& [String] -> [GenericR' Maybe] -> [(String, GenericR' Maybe)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
constrFieldsB
        [(String, GenericR' Maybe)]
-> ([(String, GenericR' Maybe)]
    -> String -> Maybe (GenericR' Maybe))
-> String
-> Maybe (GenericR' Maybe)
forall a b. a -> (a -> b) -> b
& (String -> [(String, GenericR' Maybe)] -> Maybe (GenericR' Maybe))
-> [(String, GenericR' Maybe)] -> String -> Maybe (GenericR' Maybe)
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> [(String, GenericR' Maybe)] -> Maybe (GenericR' Maybe)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup
        (String -> Maybe (GenericR' Maybe))
-> ((String -> Maybe (GenericR' Maybe))
    -> [Maybe (GenericR' Maybe)])
-> [Maybe (GenericR' Maybe)]
forall a b. a -> (a -> b) -> b
& ((String -> Maybe (GenericR' Maybe))
 -> [String] -> [Maybe (GenericR' Maybe)])
-> [String]
-> (String -> Maybe (GenericR' Maybe))
-> [Maybe (GenericR' Maybe)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> Maybe (GenericR' Maybe))
-> [String] -> [Maybe (GenericR' Maybe)]
forall a b. (a -> b) -> [a] -> [b]
map [String]
matchingConstructorFields
        [Maybe (GenericR' Maybe)]
-> ([Maybe (GenericR' Maybe)] -> Maybe [GenericR' Maybe])
-> Maybe [GenericR' Maybe]
forall a b. a -> (a -> b) -> b
& [Maybe (GenericR' Maybe)] -> Maybe [GenericR' Maybe]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  (StateT [GenericR' Maybe] Maybe a -> [GenericR' Maybe] -> Maybe a)
-> [GenericR' Maybe] -> StateT [GenericR' Maybe] Maybe a -> Maybe a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT [GenericR' Maybe] Maybe a -> [GenericR' Maybe] -> Maybe a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT [GenericR' Maybe]
fieldSetters (StateT [GenericR' Maybe] Maybe a -> Maybe a)
-> StateT [GenericR' Maybe] Maybe a -> Maybe a
forall a b. (a -> b) -> a -> b
$ (forall d. Data d => StateT [GenericR' Maybe] Maybe d)
-> Constr -> StateT [GenericR' Maybe] Maybe a
forall (m :: * -> *) a.
(Monad m, Data a) =>
(forall d. Data d => m d) -> Constr -> m a
fromConstrM forall d. Data d => StateT [GenericR' Maybe] Maybe d
tryOneField Constr
matchingConstructor

tryOneField :: Data a => StateT [GenericR' Maybe] Maybe a
tryOneField :: StateT [GenericR' Maybe] Maybe a
tryOneField = do
  (GenericR' Maybe
field : [GenericR' Maybe]
fields) <- StateT [GenericR' Maybe] Maybe [GenericR' Maybe]
forall (m :: * -> *) s. Monad m => StateT s m s
get
  [GenericR' Maybe] -> StateT [GenericR' Maybe] Maybe ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put [GenericR' Maybe]
fields
  Maybe a -> StateT [GenericR' Maybe] Maybe a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe a -> StateT [GenericR' Maybe] Maybe a)
-> Maybe a -> StateT [GenericR' Maybe] Maybe a
forall a b. (a -> b) -> a -> b
$ GenericR' Maybe -> forall a. Data a => Maybe a
forall (m :: * -> *). GenericR' m -> forall a. Data a => m a
unGR GenericR' Maybe
field --lift field

getChildrenSetters :: Data a => Migration -> a -> [GenericT']
getChildrenSetters :: Migration -> a -> [GenericT']
getChildrenSetters Migration
specific = (forall d. Data d => d -> GenericT') -> a -> [GenericT']
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ ((forall d. Data d => d -> GenericT') -> a -> [GenericT'])
-> (forall d. Data d => d -> GenericT') -> a -> [GenericT']
forall a b. (a -> b) -> a -> b
$ \d
child -> (forall a. Data a => a -> a) -> GenericT'
GT ((forall a. Data a => a -> a) -> GenericT')
-> (forall a. Data a => a -> a) -> GenericT'
forall a b. (a -> b) -> a -> b
$ (a -> d -> a) -> d -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Migration -> a -> d -> a
forall a b. (Data a, Data b) => Migration -> a -> b -> a
runSafeMigration (Migration -> a -> d -> a) -> Migration -> a -> d -> a
forall a b. (a -> b) -> a -> b
$ Migration -> Migration
treeMigration Migration
specific) d
child

newtype GenericR' m = GR { GenericR' m -> forall a. Data a => m a
unGR :: GenericR m }

getChildrenMaybe :: Data a => a -> [GenericR' Maybe]
getChildrenMaybe :: a -> [GenericR' Maybe]
getChildrenMaybe = (forall d. Data d => d -> GenericR' Maybe)
-> a -> [GenericR' Maybe]
forall a u. Data a => (forall d. Data d => d -> u) -> a -> [u]
gmapQ ((forall d. Data d => d -> GenericR' Maybe)
 -> a -> [GenericR' Maybe])
-> (forall d. Data d => d -> GenericR' Maybe)
-> a
-> [GenericR' Maybe]
forall a b. (a -> b) -> a -> b
$ \d
child -> (forall a. Data a => Maybe a) -> GenericR' Maybe
forall (m :: * -> *). (forall a. Data a => m a) -> GenericR' m
GR ((forall a. Data a => Maybe a) -> GenericR' Maybe)
-> (forall a. Data a => Maybe a) -> GenericR' Maybe
forall a b. (a -> b) -> a -> b
$ d -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast d
child

setChildren :: Data a => [GenericT'] -> a -> a
setChildren :: [GenericT'] -> a -> a
setChildren [GenericT']
updates a
a = ([GenericT'], a) -> a
forall a b. (a, b) -> b
snd (([GenericT'], a) -> a) -> ([GenericT'], a) -> a
forall a b. (a -> b) -> a -> b
$ (forall e. Data e => [GenericT'] -> e -> ([GenericT'], e))
-> [GenericT'] -> a -> ([GenericT'], a)
forall d a.
Data d =>
(forall e. Data e => a -> e -> (a, e)) -> a -> d -> (a, d)
gmapAccumT forall e. Data e => [GenericT'] -> e -> ([GenericT'], e)
f [GenericT']
updates a
a
  where
    f :: [GenericT'] -> a -> ([GenericT'], a)
f [] a
e = ([], a
e)
    f (GenericT'
update : [GenericT']
updates) a
e = ([GenericT']
updates, GenericT' -> forall a. Data a => a -> a
unGT GenericT'
update (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
e)
\end{code}