content: {-# 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
    {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 = fromMaybe a $ runMigration migration a b
  
  -- | If both migrations would succeed, the result from the first is used.
  instance Semigroup Migration where
    migration1 <> migration2 = Migration $ \a b ->
      getFirst $
        (First $ runMigration migration1 a b)
          <> (First $ runMigration migration2 a b)
  
  instance Monoid Migration where
    mempty = Migration $ const $ const Nothing
  
  -- | Try to migrate by casting the first type into the second
  castMigration :: Migration
  castMigration = Migration $ const cast
  
  -- | Migrate a value into a newtype wrapping
  newtypeMigration :: Migration
  newtypeMigration = Migration $ \a b -> do
    -- Is it an algebraic datatype with a single constructor?
    AlgRep [_constr] <- return $ dataTypeRep $ dataTypeOf a
    -- Does the constructor have a single argument?
    guard $ glength a == 1
    -- Try to cast the single child to b
    gmapM (const $ cast b) 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 specific = Migration $ \_a b -> cast =<< specific <$> cast b
  
  migrationTo2 ::
    (Typeable t) =>
    (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> a -> Maybe (t b c)) ->
    Migration
  migrationTo2 f = Migration $ \t a -> ext2M (const Nothing) (flip f a) t
  
  constMigrationFrom2 ::
    (Typeable t) =>
    (forall a b c. (Typeable a, Typeable b, Typeable c) => t b c -> Maybe a) ->
    Migration
  constMigrationFrom2 f = Migration $ \_ t -> ext2Q (const Nothing) f t
  
  migrationTo1 ::
    (Typeable t) =>
    (forall a b. (Typeable a, Typeable b) => t b -> a -> Maybe (t b)) ->
    Migration
  migrationTo1 f = Migration $ \t a -> ext1M (const Nothing) (flip f a) t
  