    -- | This module handles all display of output to the console when
    -- propellor is ensuring Properties.
    --
    -- When two threads both try to display a message concurrently,
    -- the messages will be displayed sequentially.

    module Propellor.Message (
    	Trace(..),
    	parseTrace,
    	getMessageHandle,
    	isConsole,
    	forceConsole,
    	actionMessage,
    	actionMessageOn,
    	warningMessage,
    	infoMessage,
    	errorMessage,
    	stopPropellorMessage,
    	messagesDone,
    	createProcessConcurrent,
    	withConcurrentOutput,
    ) where

    import System.Console.ANSI
    import System.IO
    import Control.Monad.IfElse
    import Control.Monad.IO.Class (liftIO, MonadIO)
    import System.IO.Unsafe (unsafePerformIO)
    import Control.Concurrent
    import System.Console.Concurrent
    import Control.Applicative
    import Prelude

    import Propellor.Types
    import Propellor.Types.Exception
    import Utility.Monad
    import Utility.Env
    import Utility.Exception
    import Utility.PartialPrelude

    -- | Serializable tracing. Export `PROPELLOR_TRACE=1` in the environment to
    -- make propellor emit these to stdout, in addition to its other output.
    data Trace
    	= ActionStart (Maybe HostName) Desc
    	| ActionEnd (Maybe HostName) Desc Result
    	deriving (ReadPrec [Trace]
    ReadPrec Trace
    Int -> ReadS Trace
    ReadS [Trace]
    (Int -> ReadS Trace)
    -> ReadS [Trace]
    -> ReadPrec Trace
    -> ReadPrec [Trace]
    -> Read Trace
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    readListPrec :: ReadPrec [Trace]
    $creadListPrec :: ReadPrec [Trace]
    readPrec :: ReadPrec Trace
    $creadPrec :: ReadPrec Trace
    readList :: ReadS [Trace]
    $creadList :: ReadS [Trace]
    readsPrec :: Int -> ReadS Trace
    $creadsPrec :: Int -> ReadS Trace
    Read, Int -> Trace -> ShowS
    [Trace] -> ShowS
    Trace -> String
    (Int -> Trace -> ShowS)
    -> (Trace -> String) -> ([Trace] -> ShowS) -> Show Trace
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    showList :: [Trace] -> ShowS
    $cshowList :: [Trace] -> ShowS
    show :: Trace -> String
    $cshow :: Trace -> String
    showsPrec :: Int -> Trace -> ShowS
    $cshowsPrec :: Int -> Trace -> ShowS
    Show)

    -- | Given a line read from propellor, if it's a serialized Trace,
    -- parses it.
    parseTrace :: String -> Maybe Trace
    parseTrace :: String -> Maybe Trace
    parseTrace = String -> Maybe Trace
    forall a. Read a => String -> Maybe a
    readish

    data MessageHandle = MessageHandle
    	{ MessageHandle -> Bool
    isConsole :: Bool
    	, MessageHandle -> Bool
    traceEnabled :: Bool
    	}

    -- | A shared global variable for the MessageHandle.
    {-# NOINLINE globalMessageHandle #-}
    globalMessageHandle :: MVar MessageHandle
    globalMessageHandle :: MVar MessageHandle
    globalMessageHandle = IO (MVar MessageHandle) -> MVar MessageHandle
    forall a. IO a -> a
    unsafePerformIO (IO (MVar MessageHandle) -> MVar MessageHandle)
    -> IO (MVar MessageHandle) -> MVar MessageHandle
    forall a b. (a -> b) -> a -> b
    $
    	MessageHandle -> IO (MVar MessageHandle)
    forall a. a -> IO (MVar a)
    newMVar (MessageHandle -> IO (MVar MessageHandle))
    -> IO MessageHandle -> IO (MVar MessageHandle)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< Bool -> Bool -> MessageHandle
    MessageHandle
    		(Bool -> Bool -> MessageHandle)
    -> IO Bool -> IO (Bool -> MessageHandle)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Bool -> IO Bool -> IO Bool
    forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
    catchDefaultIO Bool
    False (Handle -> IO Bool
    hIsTerminalDevice Handle
    stdout)
    		IO (Bool -> MessageHandle) -> IO Bool -> IO MessageHandle
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> ((Maybe String -> Maybe String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String -> Maybe String
    forall a. a -> Maybe a
    Just "1") (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> IO (Maybe String)
    getEnv "PROPELLOR_TRACE")

    -- | Gets the global MessageHandle.
    getMessageHandle :: IO MessageHandle
    getMessageHandle :: IO MessageHandle
    getMessageHandle = MVar MessageHandle -> IO MessageHandle
    forall a. MVar a -> IO a
    readMVar MVar MessageHandle
    globalMessageHandle

    trace :: Trace -> IO ()
    trace :: Trace -> IO ()
    trace t :: Trace
    t = IO Bool -> IO () -> IO ()
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
    whenM (MessageHandle -> Bool
    traceEnabled (MessageHandle -> Bool) -> IO MessageHandle -> IO Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO MessageHandle
    getMessageHandle) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
    	String -> IO ()
    putStrLn (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Trace -> String
    forall a. Show a => a -> String
    show Trace
    t

    -- | Force console output. This can be used when stdout is not directly
    -- connected to a console, but is eventually going to be displayed at a
    -- console.
    forceConsole :: IO ()
    forceConsole :: IO ()
    forceConsole = MVar MessageHandle -> (MessageHandle -> IO MessageHandle) -> IO ()
    forall a. MVar a -> (a -> IO a) -> IO ()
    modifyMVar_ MVar MessageHandle
    globalMessageHandle ((MessageHandle -> IO MessageHandle) -> IO ())
    -> (MessageHandle -> IO MessageHandle) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \mh :: MessageHandle
    mh ->
    	MessageHandle -> IO MessageHandle
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (MessageHandle
    mh { isConsole :: Bool
    isConsole = Bool
    True })

    whenConsole :: String -> IO String
    whenConsole :: String -> IO String
    whenConsole s :: String
    s = IO Bool -> (IO String, IO String) -> IO String
    forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
    ifM (MessageHandle -> Bool
    isConsole (MessageHandle -> Bool) -> IO MessageHandle -> IO Bool
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO MessageHandle
    getMessageHandle)
    	( String -> IO String
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure String
    s
    	, String -> IO String
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure ""
    	)

    -- | Shows a message while performing an action, with a colored status
    -- display.
    actionMessage :: (MonadIO m, MonadMask m, ActionResult r, ToResult r) => Desc -> m r -> m r
    actionMessage :: String -> m r -> m r
    actionMessage = Maybe String -> String -> m r -> m r
    forall (m :: * -> *) r.
    (MonadIO m, ActionResult r, ToResult r) =>
    Maybe String -> String -> m r -> m r
    actionMessage' Maybe String
    forall a. Maybe a
    Nothing

    -- | Shows a message while performing an action on a specified host,
    -- with a colored status display.
    actionMessageOn :: (MonadIO m, MonadMask m, ActionResult r, ToResult r) => HostName -> Desc -> m r -> m r
    actionMessageOn :: String -> String -> m r -> m r
    actionMessageOn = Maybe String -> String -> m r -> m r
    forall (m :: * -> *) r.
    (MonadIO m, ActionResult r, ToResult r) =>
    Maybe String -> String -> m r -> m r
    actionMessage' (Maybe String -> String -> m r -> m r)
    -> (String -> Maybe String) -> String -> String -> m r -> m r
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Maybe String
    forall a. a -> Maybe a
    Just

    actionMessage' :: (MonadIO m, ActionResult r, ToResult r) => Maybe HostName -> Desc -> m r -> m r
    actionMessage' :: Maybe String -> String -> m r -> m r
    actionMessage' mhn :: Maybe String
    mhn desc :: String
    desc a :: m r
    a = do
    	IO () -> m ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ Trace -> IO ()
    trace (Trace -> IO ()) -> Trace -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Maybe String -> String -> Trace
    ActionStart Maybe String
    mhn String
    desc
    	IO () -> m ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    forall v. Outputable v => v -> IO ()
    outputConcurrent
    		(String -> IO ()) -> IO String -> IO ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> IO String
    whenConsole (ShowS
    setTitleCode ShowS -> ShowS
    forall a b. (a -> b) -> a -> b
    $ "propellor: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    desc)

    	r
    r <- m r
    a

    	IO () -> m ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    forall v. Outputable v => v -> IO ()
    outputConcurrent (String -> IO ()) -> ([String] -> String) -> [String] -> IO ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([String] -> IO ()) -> IO [String] -> IO ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< [IO String] -> IO [String]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence
    		[ String -> IO String
    whenConsole (String -> IO String) -> String -> IO String
    forall a b. (a -> b) -> a -> b
    $
    			ShowS
    setTitleCode "propellor: running"
    		, Maybe String -> IO String
    showhn Maybe String
    mhn
    		, String -> IO String
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (String -> IO String) -> String -> IO String
    forall a b. (a -> b) -> a -> b
    $ String
    desc String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ " ... "
    		, let (msg :: String
    msg, intensity :: ColorIntensity
    intensity, color :: Color
    color) = r -> (String, ColorIntensity, Color)
    forall a. ActionResult a => a -> (String, ColorIntensity, Color)
    getActionResult r
    r
    		  in ColorIntensity -> Color -> String -> IO String
    colorLine ColorIntensity
    intensity Color
    color String
    msg
    		]
    	IO () -> m ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ Trace -> IO ()
    trace (Trace -> IO ()) -> Trace -> IO ()
    forall a b. (a -> b) -> a -> b
    $ Maybe String -> String -> Result -> Trace
    ActionEnd Maybe String
    mhn String
    desc (r -> Result
    forall t. ToResult t => t -> Result
    toResult r
    r)

    	r -> m r
    forall (m :: * -> *) a. Monad m => a -> m a
    return r
    r
      where
    	showhn :: Maybe String -> IO String
    showhn Nothing = String -> IO String
    forall (m :: * -> *) a. Monad m => a -> m a
    return ""
    	showhn (Just hn :: String
    hn) = [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([String] -> String) -> IO [String] -> IO String
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [IO String] -> IO [String]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence
    		[ String -> IO String
    whenConsole (String -> IO String) -> String -> IO String
    forall a b. (a -> b) -> a -> b
    $
    			[SGR] -> String
    setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
    SetColor ConsoleLayer
    Foreground ColorIntensity
    Dull Color
    Cyan]
    		, String -> IO String
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (String
    hn String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ " ")
    		, String -> IO String
    whenConsole (String -> IO String) -> String -> IO String
    forall a b. (a -> b) -> a -> b
    $
    			[SGR] -> String
    setSGRCode []
    		]

    warningMessage :: MonadIO m => String -> m ()
    warningMessage :: String -> m ()
    warningMessage s :: String
    s = IO () -> m ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $
    	String -> IO ()
    forall v. Outputable v => v -> IO ()
    errorConcurrent (String -> IO ()) -> IO String -> IO ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< ColorIntensity -> Color -> String -> IO String
    colorLine ColorIntensity
    Vivid Color
    Magenta ("** warning: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    s)

    infoMessage :: MonadIO m => [String] -> m ()
    infoMessage :: [String] -> m ()
    infoMessage ls :: [String]
    ls = IO () -> m ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> m ()) -> IO () -> m ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    forall v. Outputable v => v -> IO ()
    outputConcurrent (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ShowS -> [String] -> String
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ "\n") [String]
    ls

    -- | Displays the error message in red, and throws an exception.
    --
    -- When used inside a property, the exception will make the current
    -- property fail. Propellor will continue to the next property.
    errorMessage :: MonadIO m => String -> m a
    errorMessage :: String -> m a
    errorMessage s :: String
    s = IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO a -> m a) -> IO a -> m a
    forall a b. (a -> b) -> a -> b
    $ do
    	String -> IO ()
    forall v. Outputable v => v -> IO ()
    errorConcurrent (String -> IO ()) -> IO String -> IO ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< ColorIntensity -> Color -> String -> IO String
    colorLine ColorIntensity
    Vivid Color
    Red ("** error: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    s)
    	-- Normally this exception gets caught and is not displayed,
    	-- and propellor continues. So it's only displayed if not
    	-- caught, and so we say, cannot continue.
    	String -> IO a
    forall a. HasCallStack => String -> a
    error "Cannot continue!"

    -- | Like `errorMessage`, but throws a `StopPropellorException`,
    -- preventing propellor from continuing to the next property.
    --
    -- Think twice before using this. Is the problem so bad that propellor
    -- cannot try to ensure other properties? If not, use `errorMessage`
    -- instead.
    stopPropellorMessage :: MonadIO m => String -> m a
    stopPropellorMessage :: String -> m a
    stopPropellorMessage s :: String
    s = IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO a -> m a) -> IO a -> m a
    forall a b. (a -> b) -> a -> b
    $ do
    	String -> IO ()
    forall v. Outputable v => v -> IO ()
    outputConcurrent (String -> IO ()) -> IO String -> IO ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< ColorIntensity -> Color -> String -> IO String
    colorLine ColorIntensity
    Vivid Color
    Red ("** fatal error: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    s)
    	StopPropellorException -> IO a
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
    throwM (StopPropellorException -> IO a) -> StopPropellorException -> IO a
    forall a b. (a -> b) -> a -> b
    $ String -> StopPropellorException
    StopPropellorException "Cannot continue!"

    colorLine :: ColorIntensity -> Color -> String -> IO String
    colorLine :: ColorIntensity -> Color -> String -> IO String
    colorLine intensity :: ColorIntensity
    intensity color :: Color
    color msg :: String
    msg = [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([String] -> String) -> IO [String] -> IO String
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [IO String] -> IO [String]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    sequence
    	[ String -> IO String
    whenConsole (String -> IO String) -> String -> IO String
    forall a b. (a -> b) -> a -> b
    $
    		[SGR] -> String
    setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
    SetColor ConsoleLayer
    Foreground ColorIntensity
    intensity Color
    color]
    	, String -> IO String
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure String
    msg
    	, String -> IO String
    whenConsole (String -> IO String) -> String -> IO String
    forall a b. (a -> b) -> a -> b
    $
    		[SGR] -> String
    setSGRCode []
    	-- Note this comes after the color is reset, so that
    	-- the color set and reset happen in the same line.
    	, String -> IO String
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure "\n"
    	]

    -- | Called when all messages about properties have been printed.
    messagesDone :: IO ()
    messagesDone :: IO ()
    messagesDone = String -> IO ()
    forall v. Outputable v => v -> IO ()
    outputConcurrent
    	(String -> IO ()) -> IO String -> IO ()
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> IO String
    whenConsole (ShowS
    setTitleCode "propellor: done")