{-# 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