\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 :: forall a b. (Data a, Data b) => a -> b -> a
migrate = 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 :: forall a b. (Data a, Data b) => Migration -> a -> b -> a
migrateWith Migration
specific = forall a b. (Data a, Data b) => Migration -> a -> b -> a
runSafeMigration 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
  forall a. Semigroup a => a -> a -> a
<> Migration
migrationDebugging
  forall a. Semigroup a => a -> a -> a
<> Migration
migrationCell
  forall a. Semigroup a => a -> a -> a
<> Migration
newtypeMigration
  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.
  forall a. Semigroup a => a -> a -> a
<> Migration -> Migration
sameConstructorMigration Migration
specific
  forall a. Semigroup a => a -> a -> a
<> Migration -> Migration
constructorMigration Migration
specific

matchingAlgebraicDataTypes :: (Data a, Data b) => a -> b -> Bool
matchingAlgebraicDataTypes :: forall a b. (Data a, Data b) => 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 forall a. Eq a => a -> a -> Bool
== DataType -> String
dataTypeName DataType
typeB
  where
    typeA :: DataType
typeA = forall a. Data a => a -> DataType
dataTypeOf a
a
    typeB :: DataType
typeB = 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. (a -> b) -> a -> b
$ \a
a b
b -> do
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a b. (Data a, Data b) => a -> b -> Bool
matchingAlgebraicDataTypes a
a b
b
  let
    constrA :: Constr
constrA = forall a. Data a => a -> Constr
toConstr a
a
    constrB :: Constr
constrB = forall a. Data a => a -> Constr
toConstr b
b
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Constr -> String
showConstr Constr
constrA 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 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
constrFieldsA)
      Bool -> Bool -> Bool
&& (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
constrFieldsB)
      = 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 = forall a. Data a => [GenericT'] -> a -> a
setChildren (forall a. Data a => Migration -> a -> [GenericT']
getChildrenSetters Migration
specific b
b) a
a
    settersB :: [(String, GenericT')]
settersB = forall a b. [a] -> [b] -> [(a, b)]
zip [String]
constrFieldsB forall a b. (a -> b) -> a -> b
$ forall a. Data a => Migration -> a -> [GenericT']
getChildrenSetters Migration
specific b
b
    getFieldSetters :: [GenericT']
getFieldSetters = [String]
constrFieldsA forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
      \String
field -> forall a. a -> Maybe a -> a
fromMaybe ((forall a. Data a => a -> a) -> GenericT'
GT forall a. a -> a
id)
        forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
field [(String, GenericT')]
settersB
  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. (a -> b) -> a -> b
$ \a
a b
b -> do
  let
    constrB :: Constr
constrB = forall a. Data a => a -> Constr
toConstr b
b
    constrFieldsB :: [String]
constrFieldsB = Constr -> [String]
constrFields Constr
constrB
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a b. (Data a, Data b) => a -> b -> Bool
matchingAlgebraicDataTypes a
a b
b
  Constr
matchingConstructor <- forall a. Data a => a -> DataType
dataTypeOf a
a
    forall a b. a -> (a -> b) -> b
& DataType -> [Constr]
dataTypeConstrs
    forall a b. a -> (a -> b) -> b
& forall a b. (a -> b) -> [a] -> [b]
map (forall a. Show a => a -> String
show forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall a. a -> a
id)
    forall a b. a -> (a -> b) -> b
& 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 forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
constrFieldsB Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
matchingConstructorFields
    -- We don't have record. Try to cast each field.
    then
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> [GenericR' Maybe]
getChildrenMaybe b
b
    -- We have records. Sort by all field names and try to cast
    else
      forall a. Data a => a -> [GenericR' Maybe]
getChildrenMaybe b
b
        forall a b. a -> (a -> b) -> b
& forall a b. [a] -> [b] -> [(a, b)]
zip [String]
constrFieldsB
        forall a b. a -> (a -> b) -> b
& forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup
        forall a b. a -> (a -> b) -> b
& forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [String]
matchingConstructorFields
        forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT [GenericR' Maybe]
fieldSetters forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(Monad m, Data a) =>
(forall d. Data d => m d) -> Constr -> m a
fromConstrM forall a. Data a => StateT [GenericR' Maybe] Maybe a
tryOneField Constr
matchingConstructor

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

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

newtype GenericR' m = GR { forall (m :: * -> *). GenericR' m -> GenericR m
unGR :: GenericR m }

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

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