{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Refurb.Run.Internal where
import ClassyPrelude
import Control.Monad (MonadFail)
import Control.Monad.Base (liftBase)
import Control.Monad.Catch (MonadMask)
import Control.Monad.Logger (MonadLogger, MonadLoggerIO)
import Control.Monad.Trans.Control (MonadBaseControl)
import qualified Database.PostgreSQL.Simple as PG
import Refurb.Cli (Opts, colorize)
import Refurb.Store (MigrationResult(MigrationSuccess, MigrationFailure))
import Refurb.Types (ConnInfo, Migration)
import Text.PrettyPrint.ANSI.Leijen (Doc, green, red, plain, text, putDoc)
data Context = Context
{ Context -> Opts
contextOptions :: Opts
, Context -> Connection
contextDbConn :: PG.Connection
, Context -> ConnInfo
contextDbConnInfo :: ConnInfo
, Context -> [Migration]
contextMigrations :: [Migration]
}
type MonadRefurb m = (MonadBaseControl IO m, MonadFail m, MonadMask m, MonadReader Context m, MonadLogger m, MonadLoggerIO m)
optionallyColorM :: MonadRefurb m => m (Doc -> Doc)
optionallyColorM :: m (Doc -> Doc)
optionallyColorM =
(Doc -> Doc) -> (Doc -> Doc) -> Bool -> Doc -> Doc
forall a. a -> a -> Bool -> a
bool Doc -> Doc
plain Doc -> Doc
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Bool -> Doc -> Doc) -> m Bool -> m (Doc -> Doc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Context -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Opts -> Bool
colorize (Opts -> Bool) -> (Context -> Opts) -> Context -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Context -> Opts
contextOptions)
optionallyColoredM :: MonadRefurb m => m (Doc -> m ())
optionallyColoredM :: m (Doc -> m ())
optionallyColoredM = do
Doc -> Doc
maybePlain <- m (Doc -> Doc)
forall (m :: * -> *). MonadRefurb m => m (Doc -> Doc)
optionallyColorM
(Doc -> m ()) -> m (Doc -> m ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Doc -> m ()) -> m (Doc -> m ()))
-> (Doc -> m ()) -> m (Doc -> m ())
forall a b. (a -> b) -> a -> b
$ \ Doc
doc -> do
IO () -> m ()
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
putDoc (Doc -> Doc
maybePlain Doc
doc)
Text -> m ()
forall (m :: * -> *). MonadIO m => Text -> m ()
putStrLn Text
""
migrationResultDoc :: MigrationResult -> Doc
migrationResultDoc :: MigrationResult -> Doc
migrationResultDoc = \ case
MigrationResult
MigrationSuccess -> Doc -> Doc
green (String -> Doc
text String
"success")
MigrationResult
MigrationFailure -> Doc -> Doc
red (String -> Doc
text String
"failure")