{-# 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 :: forall a b. (Data a, Data b) => Migration -> a -> b -> a
runSafeMigration Migration
migration a
a b
b = forall a. a -> Maybe a -> a
fromMaybe a
a forall a b. (a -> b) -> a -> b
$ 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. (a -> b) -> a -> b
$ \a
a b
b ->
    forall a. First a -> Maybe a
getFirst forall a b. (a -> b) -> a -> b
$
      (forall a. Maybe a -> First a
First forall a b. (a -> b) -> a -> b
$ Migration -> forall a b. (Data a, Data b) => a -> b -> Maybe a
runMigration Migration
migration1 a
a b
b)
        forall a. Semigroup a => a -> a -> a
<> (forall a. Maybe a -> First a
First forall a b. (a -> b) -> a -> b
$ 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. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const 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. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const 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. (a -> b) -> a -> b
$ \a
a b
b -> do
  -- Is it an algebraic datatype with a single constructor?
  AlgRep [Constr
_constr] <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DataType -> DataRep
dataTypeRep forall a b. (a -> b) -> a -> b
$ forall a. Data a => a -> DataType
dataTypeOf a
a
  -- Does the constructor have a single argument?
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ GenericQ Int
glength a
a forall a. Eq a => a -> a -> Bool
== Int
1
  -- Try to cast the single child to b
  forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> a -> m a
gmapM (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ 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 :: forall c d. (Typeable c, Typeable d) => (c -> d) -> Migration
userMigration c -> d
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 -> forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< c -> d
specific forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (t :: * -> * -> *).
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)
f = (forall a b. (Data a, Data b) => a -> b -> Maybe a) -> Migration
Migration forall a b. (a -> b) -> a -> b
$ \a
t b
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 (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 (t :: * -> * -> *).
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
f = (forall a b. (Data a, Data b) => a -> b -> Maybe a) -> Migration
Migration forall a b. (a -> b) -> a -> b
$ \a
_ b
t -> forall d (t :: * -> * -> *) q.
(Data d, Typeable t) =>
(d -> q)
-> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q) -> d -> q
ext2Q (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) 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 (t :: * -> *).
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)
f = (forall a b. (Data a, Data b) => a -> b -> Maybe a) -> Migration
Migration forall a b. (a -> b) -> a -> b
$ \a
t b
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 (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (Typeable a, Typeable b) => t b -> a -> Maybe (t b)
f b
a) a
t