{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
-- |Module containing shared types and functions used for implementing the various commands.
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)

-- |Reader context for all command execution which contains the command line options, database connection and connection information, and known migrations.
data Context = Context
  { Context -> Opts
contextOptions    :: Opts
  -- ^The 'Opts' structure parsed from the command line by @Refurb.Cli@.
  , Context -> Connection
contextDbConn     :: PG.Connection
  -- ^The open database 'PG.Connection'.
  , Context -> ConnInfo
contextDbConnInfo :: ConnInfo
  -- ^The information used to connect to the database, required for running command line tools like @pg_dump@ against the same database.
  , Context -> [Migration]
contextMigrations :: [Migration]
  -- ^The known migrations passed in to 'Refurb.refurbMain'.
  }

-- |Constraint of actions for command execution, including access to the 'Context', logging, and underlying IO.
type MonadRefurb m = (MonadBaseControl IO m, MonadFail m, MonadMask m, MonadReader Context m, MonadLogger m, MonadLoggerIO m)

-- |Given the configuration implicitly available to 'MonadRefurb', produce a function which possibly strips ANSI colorization from a 'Doc' if the user
-- requested colorless output.
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)

-- |Given the configuration implicitly available to 'MonadRefurb', produce a function which emits a 'Doc' on stdout that is colored unless the user requested
-- colorless output.
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
""

-- |Produce a colorized 'Doc' with @success@ or @failure@, based on which 'MigrationResult' value was passed.
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")