{-# LANGUAGE RankNTypes #-}

module LiveCoding.Migrate.Migration where

-- base
import Control.Monad (guard)
import Data.Data
import Data.Maybe (fromMaybe)
import Data.Monoid

-- syb
import Data.Generics.Aliases
import Data.Generics.Schemes (glength)

data Migration = Migration
  { Migration -> forall a b. (Data a, Data b) => a -> b -> Maybe a
runMigration :: forall a b . (Data a, Data b) => a -> b -> Maybe a }

-- | Run a migration and insert the new initial state in case of failure.
runSafeMigration
  :: (Data a, Data b)
  => Migration
  -> a -> b -> a
runSafeMigration :: Migration -> a -> b -> a
runSafeMigration Migration
migration a
a b
b = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
a (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ Migration -> a -> b -> Maybe a
Migration -> forall a b. (Data a, Data b) => a -> b -> Maybe a
runMigration Migration
migration a
a b
b

-- | If both migrations would succeed, the result from the first is used.
instance Semigroup Migration where
  Migration
migration1 <> :: Migration -> Migration -> Migration
<> Migration
migration2 = (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 -> First a -> Maybe a
forall a. First a -> Maybe a
getFirst
    (First a -> Maybe a) -> First a -> Maybe a
forall a b. (a -> b) -> a -> b
$  (Maybe a -> First a
forall a. Maybe a -> First a
First (Maybe a -> First a) -> Maybe a -> First a
forall a b. (a -> b) -> a -> b
$ Migration -> a -> b -> Maybe a
Migration -> forall a b. (Data a, Data b) => a -> b -> Maybe a
runMigration Migration
migration1 a
a b
b)
    First a -> First a -> First a
forall a. Semigroup a => a -> a -> a
<> (Maybe a -> First a
forall a. Maybe a -> First a
First (Maybe a -> First a) -> Maybe a -> First a
forall a b. (a -> b) -> a -> b
$ Migration -> a -> b -> Maybe a
Migration -> forall a b. (Data a, Data b) => a -> b -> Maybe a
runMigration Migration
migration2 a
a b
b)

instance Monoid Migration where
  mempty :: Migration
mempty = (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
$ (b -> Maybe a) -> a -> b -> Maybe a
forall a b. a -> b -> a
const ((b -> Maybe a) -> a -> b -> Maybe a)
-> (b -> Maybe a) -> a -> b -> Maybe a
forall a b. (a -> b) -> a -> b
$ Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing

-- | Try to migrate by casting the first type into the second
castMigration :: Migration
castMigration :: Migration
castMigration = (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
$ (b -> Maybe a) -> a -> b -> Maybe a
forall a b. a -> b -> a
const b -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast

-- | Migrate a value into a newtype wrapping
newtypeMigration :: Migration
newtypeMigration :: Migration
newtypeMigration = (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
  -- Is it an algebraic datatype with a single constructor?
  AlgRep [Constr
_constr] <- DataRep -> Maybe DataRep
forall (m :: * -> *) a. Monad m => a -> m a
return (DataRep -> Maybe DataRep) -> DataRep -> Maybe DataRep
forall a b. (a -> b) -> a -> b
$ DataType -> DataRep
dataTypeRep (DataType -> DataRep) -> DataType -> DataRep
forall a b. (a -> b) -> a -> b
$ a -> DataType
forall a. Data a => a -> DataType
dataTypeOf a
a
  -- Does the constructor have a single argument?
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ a -> Int
GenericQ Int
glength a
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
  -- Try to cast the single child to b
  (forall d. Data d => d -> Maybe d) -> a -> Maybe a
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapM (Maybe d -> d -> Maybe d
forall a b. a -> b -> a
const (Maybe d -> d -> Maybe d) -> Maybe d -> d -> Maybe d
forall a b. (a -> b) -> a -> b
$ b -> Maybe d
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
b) a
a

-- | If you have a specific type that you would like to be migrated to a specific other type,
--   you can create a migration for this.
--   For example: @userMigration (toInteger :: Int -> Integer)@
userMigration
  :: (Typeable c, Typeable d)
  => (c -> d)
  -> Migration
userMigration :: (c -> d) -> Migration
userMigration c -> d
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 -> d -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast (d -> Maybe a) -> Maybe d -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< c -> d
specific (c -> d) -> Maybe c -> Maybe d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> Maybe c
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast b
b

migrationTo2
  :: Typeable t
  => (forall a b c . (Typeable a, Typeable b, Typeable c) => t b c -> a -> Maybe (t b c))
  -> Migration
migrationTo2 :: (forall a b c.
 (Typeable a, Typeable b, Typeable c) =>
 t b c -> a -> Maybe (t b c))
-> Migration
migrationTo2 forall a b c.
(Typeable a, Typeable b, Typeable c) =>
t b c -> a -> Maybe (t b c)
f = (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
t b
a -> (forall d. Data d => d -> Maybe d)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> Maybe (t d1 d2))
-> a
-> Maybe a
forall (m :: * -> *) d (t :: * -> * -> *).
(Monad m, Data d, Typeable t) =>
(forall e. Data e => e -> m e)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2))
-> d
-> m d
ext2M (Maybe e -> e -> Maybe e
forall a b. a -> b -> a
const Maybe e
forall a. Maybe a
Nothing) ((t d1 d2 -> b -> Maybe (t d1 d2))
-> b -> t d1 d2 -> Maybe (t d1 d2)
forall a b c. (a -> b -> c) -> b -> a -> c
flip t d1 d2 -> b -> Maybe (t d1 d2)
forall a b c.
(Typeable a, Typeable b, Typeable c) =>
t b c -> a -> Maybe (t b c)
f b
a) a
t

constMigrationFrom2
  :: Typeable t
  => (forall a b c . (Typeable a, Typeable b, Typeable c) => t b c -> Maybe a)
  -> Migration
constMigrationFrom2 :: (forall a b c.
 (Typeable a, Typeable b, Typeable c) =>
 t b c -> Maybe a)
-> Migration
constMigrationFrom2 forall a b c.
(Typeable a, Typeable b, Typeable c) =>
t b c -> Maybe a
f = (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
_ b
t -> (b -> Maybe a)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> Maybe a)
-> b
-> Maybe a
forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
ext2Q (Maybe a -> b -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) forall d1 d2. (Data d1, Data d2) => t d1 d2 -> Maybe a
forall a b c.
(Typeable a, Typeable b, Typeable c) =>
t b c -> Maybe a
f b
t

migrationTo1
  :: Typeable t
  => (forall a b . (Typeable a, Typeable b) => t b -> a -> Maybe (t b))
  -> Migration
migrationTo1 :: (forall a b. (Typeable a, Typeable b) => t b -> a -> Maybe (t b))
-> Migration
migrationTo1 forall a b. (Typeable a, Typeable b) => t b -> a -> Maybe (t b)
f = (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
t b
a -> (forall d. Data d => d -> Maybe d)
-> (forall f. Data f => t f -> Maybe (t f)) -> a -> Maybe a
forall (m :: * -> *) d (t :: * -> *).
(Monad m, Data d, Typeable t) =>
(forall e. Data e => e -> m e)
-> (forall f. Data f => t f -> m (t f)) -> d -> m d
ext1M (Maybe e -> e -> Maybe e
forall a b. a -> b -> a
const Maybe e
forall a. Maybe a
Nothing) ((t f -> b -> Maybe (t f)) -> b -> t f -> Maybe (t f)
forall a b c. (a -> b -> c) -> b -> a -> c
flip t f -> b -> Maybe (t f)
forall a b. (Typeable a, Typeable b) => t b -> a -> Maybe (t b)
f b
a) a
t