{-# LANGUAGE RankNTypes #-}
module LiveCoding.Migrate.Migration where
import Control.Monad (guard)
import Data.Data
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Generics.Aliases
import Data.Generics.Schemes (glength)
data Migration = Migration
{ runMigration :: forall a b . (Data a, Data b) => a -> b -> Maybe a }
runSafeMigration
:: (Data a, Data b)
=> Migration
-> a -> b -> a
runSafeMigration migration a b = fromMaybe a $ runMigration migration a b
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
castMigration :: Migration
castMigration = Migration $ const cast
newtypeMigration :: Migration
newtypeMigration = Migration $ \a b -> do
AlgRep [_constr] <- return $ dataTypeRep $ dataTypeOf a
guard $ glength a == 1
gmapM (const $ cast b) a
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