\begin{comment}
\begin{code}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE RankNTypes #-}
module LiveCoding.Migrate where
import Control.Arrow ((&&&))
import Control.Monad (guard)
import Data.Data
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Maybe
import Prelude hiding (GT)
import Control.Monad.Trans.Class
import Control.Monad.Trans.State
import Data.Generics.Aliases
import Data.Generics.Twins
import LiveCoding.Migrate.Debugger
import LiveCoding.Migrate.Cell
import LiveCoding.Migrate.Monad.Trans
import LiveCoding.Migrate.Migration
\end{code}
\end{comment}
\begin{code}
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
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
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
treeMigration :: Migration -> Migration
treeMigration :: Migration -> Migration
treeMigration Migration
specific
= Migration
specific
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
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
| (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
| 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
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
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
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
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}