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