{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}

-- This is an Internal module, hidden from Haddock
module Core.Program.Context (
    Context (..),
    None (..),
    isNone,
    configure,
    Message (..),
    Verbosity (..),
    Program (..),
    unProgram,
    getContext,
    fmapContext,
    subProgram,
) where

import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds)
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar)
import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO)
import qualified Control.Exception.Safe as Safe (catch, throw)
import Control.Monad.Catch (MonadCatch (catch), MonadThrow (throwM))
import Control.Monad.Reader.Class (MonadReader (..))
import Control.Monad.Trans.Reader (ReaderT (..))
import Core.Data.Structures
import Core.Program.Arguments
import Core.Program.Metadata
import Core.System.Base hiding (catch, throw)
import Core.Text.Rope
import Data.Foldable (foldrM)
import Data.Text.Prettyprint.Doc (LayoutOptions (..), PageWidth (..), layoutPretty)
import Data.Text.Prettyprint.Doc.Render.Text (renderIO)
import qualified System.Console.Terminal.Size as Terminal (Window (..), size)
import System.Environment (getArgs, getProgName, lookupEnv)
import System.Exit (ExitCode (..), exitWith)
import Prelude hiding (log)

{- |
Internal context for a running program. You access this via actions in the
'Program' monad. The principal item here is the user-supplied top-level
application data of type @τ@ which can be retrieved with
'Core.Program.Execute.getApplicationState' and updated with
'Core.Program.Execute.setApplicationState'.
-}

--
-- The fieldNameFrom idiom is an experiment. Looks very strange,
-- certainly, here in the record type definition and when setting
-- fields, but for the common case of getting a value out of the
-- record, a call like
--
--     fieldNameFrom context
--
-- isn't bad at all, and no worse than the leading underscore
-- convention.
--
--     _fieldName context
--
-- (I would argue better, since _ is already so overloaded as the
-- wildcard symbol in Haskell). Either way, the point is to avoid a
-- bare fieldName because so often you have want to be able to use
-- that field name as a local variable name.
--
data Context τ = Context
    { Context τ -> MVar Rope
programNameFrom :: MVar Rope
    , Context τ -> Version
versionFrom :: Version
    , Context τ -> Parameters
commandLineFrom :: Parameters
    , Context τ -> MVar ExitCode
exitSemaphoreFrom :: MVar ExitCode
    , Context τ -> MVar TimeStamp
startTimeFrom :: MVar TimeStamp
    , Context τ -> Int
terminalWidthFrom :: Int
    , Context τ -> MVar Verbosity
verbosityLevelFrom :: MVar Verbosity
    , Context τ -> TQueue Rope
outputChannelFrom :: TQueue Rope
    , Context τ -> TQueue Message
loggerChannelFrom :: TQueue Message
    , Context τ -> MVar τ
applicationDataFrom :: MVar τ
    }

-- I would happily accept critique as to whether this is safe or not. I think
-- so? The only way to get to the underlying top-level application data is
-- through 'getApplicationState' which is in Program monad so the fact that it
-- is implemented within an MVar should be irrelevant.
instance Functor Context where
    fmap :: (a -> b) -> Context a -> Context b
fmap a -> b
f = IO (Context b) -> Context b
forall a. IO a -> a
unsafePerformIO (IO (Context b) -> Context b)
-> (Context a -> IO (Context b)) -> Context a -> Context b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Context a -> IO (Context b)
forall τ1 τ2. (τ1 -> τ2) -> Context τ1 -> IO (Context τ2)
fmapContext a -> b
f

{- |
Map a function over the underlying user-data inside the 'Context', changing
it from type@τ1@ to @τ2@.
-}
fmapContext :: (τ1 -> τ2) -> Context τ1 -> IO (Context τ2)
fmapContext :: (τ1 -> τ2) -> Context τ1 -> IO (Context τ2)
fmapContext τ1 -> τ2
f Context τ1
context = do
    τ1
state <- MVar τ1 -> IO τ1
forall a. MVar a -> IO a
readMVar (Context τ1 -> MVar τ1
forall τ. Context τ -> MVar τ
applicationDataFrom Context τ1
context)
    let state' :: τ2
state' = τ1 -> τ2
f τ1
state
    MVar τ2
u <- τ2 -> IO (MVar τ2)
forall a. a -> IO (MVar a)
newMVar τ2
state'
    Context τ2 -> IO (Context τ2)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context τ1
context{applicationDataFrom :: MVar τ2
applicationDataFrom = MVar τ2
u})

{- |
A 'Program' with no user-supplied state to be threaded throughout the
computation.

The "Core.Program.Execute" framework makes your top-level application state
available at the outer level of your process. While this is a feature that
most substantial programs rely on, it is /not/ needed for many simple tasks or
when first starting out what will become a larger project.

This is effectively the unit type, but this alias is here to clearly signal a
user-data type is not a part of the program semantics.
-}

-- Bids are open for a better name for this
data None = None
    deriving (Int -> None -> ShowS
[None] -> ShowS
None -> String
(Int -> None -> ShowS)
-> (None -> String) -> ([None] -> ShowS) -> Show None
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [None] -> ShowS
$cshowList :: [None] -> ShowS
show :: None -> String
$cshow :: None -> String
showsPrec :: Int -> None -> ShowS
$cshowsPrec :: Int -> None -> ShowS
Show, None -> None -> Bool
(None -> None -> Bool) -> (None -> None -> Bool) -> Eq None
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: None -> None -> Bool
$c/= :: None -> None -> Bool
== :: None -> None -> Bool
$c== :: None -> None -> Bool
Eq)

isNone :: None -> Bool
isNone :: None -> Bool
isNone None
_ = Bool
True

data Message = Message TimeStamp Verbosity Rope (Maybe Rope)

{- |
The verbosity level of the logging subsystem. You can override the level
specified on the command-line using 'Core.Program.Execute.setVerbosityLevel'
from within the 'Program' monad.
-}
data Verbosity = Output | Event | Debug
    deriving (Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show)

{- |
The type of a top-level program.

You would use this by writing:

@
module Main where

import "Core.Program"

main :: 'IO' ()
main = 'Core.Program.Execute.execute' program
@

and defining a program that is the top level of your application:

@
program :: 'Program' 'None' ()
@

Such actions are combinable; you can sequence them (using bind in do-notation)
or run them in parallel, but basically you should need one such object at the
top of your application.

/Type variables/

A 'Program' has a user-supplied application state and a return type.

The first type variable, @τ@, is your application's state. This is an object
that will be threaded through the computation and made available to your code
in the 'Program' monad. While this is a common requirement of the outer code
layer in large programs, it is often /not/ necessary in small programs or when
starting new projects. You can mark that there is no top-level application
state required using 'None' and easily change it later if your needs evolve.

The return type, @α@, is usually unit as this effectively being called
directly from @main@ and Haskell programs have type @'IO' ()@. That is, they
don't return anything; I/O having already happened as side effects.

/Programs in separate modules/

One of the quirks of Haskell is that it is difficult to refer to code in the
Main module when you've got a number of programs kicking around in a project
each with a @main@ function. One way of dealing with this is to put your
top-level 'Program' actions in a separate modules so you can refer to them
from test suites and example snippets.

/Interoperating with the rest of the Haskell ecosystem/

The 'Program' monad is a wrapper over 'IO'; at any point when you need to move
to another package's entry point, just use 'liftIO'. It's re-exported by
"Core.System.Base" for your convenience. Later, you might be interested in
unlifting back to Program; see "Core.Program.Unlift".
-}
newtype Program τ α = Program (ReaderT (Context τ) IO α)
    deriving (a -> Program τ b -> Program τ a
(a -> b) -> Program τ a -> Program τ b
(forall a b. (a -> b) -> Program τ a -> Program τ b)
-> (forall a b. a -> Program τ b -> Program τ a)
-> Functor (Program τ)
forall a b. a -> Program τ b -> Program τ a
forall a b. (a -> b) -> Program τ a -> Program τ b
forall τ a b. a -> Program τ b -> Program τ a
forall τ a b. (a -> b) -> Program τ a -> Program τ b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Program τ b -> Program τ a
$c<$ :: forall τ a b. a -> Program τ b -> Program τ a
fmap :: (a -> b) -> Program τ a -> Program τ b
$cfmap :: forall τ a b. (a -> b) -> Program τ a -> Program τ b
Functor, Functor (Program τ)
a -> Program τ a
Functor (Program τ)
-> (forall a. a -> Program τ a)
-> (forall a b. Program τ (a -> b) -> Program τ a -> Program τ b)
-> (forall a b c.
    (a -> b -> c) -> Program τ a -> Program τ b -> Program τ c)
-> (forall a b. Program τ a -> Program τ b -> Program τ b)
-> (forall a b. Program τ a -> Program τ b -> Program τ a)
-> Applicative (Program τ)
Program τ a -> Program τ b -> Program τ b
Program τ a -> Program τ b -> Program τ a
Program τ (a -> b) -> Program τ a -> Program τ b
(a -> b -> c) -> Program τ a -> Program τ b -> Program τ c
forall τ. Functor (Program τ)
forall a. a -> Program τ a
forall τ a. a -> Program τ a
forall a b. Program τ a -> Program τ b -> Program τ a
forall a b. Program τ a -> Program τ b -> Program τ b
forall a b. Program τ (a -> b) -> Program τ a -> Program τ b
forall τ a b. Program τ a -> Program τ b -> Program τ a
forall τ a b. Program τ a -> Program τ b -> Program τ b
forall τ a b. Program τ (a -> b) -> Program τ a -> Program τ b
forall a b c.
(a -> b -> c) -> Program τ a -> Program τ b -> Program τ c
forall τ a b c.
(a -> b -> c) -> Program τ a -> Program τ b -> Program τ c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Program τ a -> Program τ b -> Program τ a
$c<* :: forall τ a b. Program τ a -> Program τ b -> Program τ a
*> :: Program τ a -> Program τ b -> Program τ b
$c*> :: forall τ a b. Program τ a -> Program τ b -> Program τ b
liftA2 :: (a -> b -> c) -> Program τ a -> Program τ b -> Program τ c
$cliftA2 :: forall τ a b c.
(a -> b -> c) -> Program τ a -> Program τ b -> Program τ c
<*> :: Program τ (a -> b) -> Program τ a -> Program τ b
$c<*> :: forall τ a b. Program τ (a -> b) -> Program τ a -> Program τ b
pure :: a -> Program τ a
$cpure :: forall τ a. a -> Program τ a
$cp1Applicative :: forall τ. Functor (Program τ)
Applicative, Applicative (Program τ)
a -> Program τ a
Applicative (Program τ)
-> (forall a b. Program τ a -> (a -> Program τ b) -> Program τ b)
-> (forall a b. Program τ a -> Program τ b -> Program τ b)
-> (forall a. a -> Program τ a)
-> Monad (Program τ)
Program τ a -> (a -> Program τ b) -> Program τ b
Program τ a -> Program τ b -> Program τ b
forall τ. Applicative (Program τ)
forall a. a -> Program τ a
forall τ a. a -> Program τ a
forall a b. Program τ a -> Program τ b -> Program τ b
forall a b. Program τ a -> (a -> Program τ b) -> Program τ b
forall τ a b. Program τ a -> Program τ b -> Program τ b
forall τ a b. Program τ a -> (a -> Program τ b) -> Program τ b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Program τ a
$creturn :: forall τ a. a -> Program τ a
>> :: Program τ a -> Program τ b -> Program τ b
$c>> :: forall τ a b. Program τ a -> Program τ b -> Program τ b
>>= :: Program τ a -> (a -> Program τ b) -> Program τ b
$c>>= :: forall τ a b. Program τ a -> (a -> Program τ b) -> Program τ b
$cp1Monad :: forall τ. Applicative (Program τ)
Monad, Monad (Program τ)
Monad (Program τ)
-> (forall a. IO a -> Program τ a) -> MonadIO (Program τ)
IO a -> Program τ a
forall τ. Monad (Program τ)
forall a. IO a -> Program τ a
forall τ a. IO a -> Program τ a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> Program τ a
$cliftIO :: forall τ a. IO a -> Program τ a
$cp1MonadIO :: forall τ. Monad (Program τ)
MonadIO, MonadReader (Context τ))

unProgram :: Program τ α -> ReaderT (Context τ) IO α
unProgram :: Program τ α -> ReaderT (Context τ) IO α
unProgram (Program ReaderT (Context τ) IO α
r) = ReaderT (Context τ) IO α
r

{- |
Get the internal @Context@ of the running @Program@. There is ordinarily no
reason to use this; to access your top-level application data @τ@ within the
@Context@ use 'Core.Program.Execute.getApplicationState'.
-}
getContext :: Program τ (Context τ)
getContext :: Program τ (Context τ)
getContext = do
    Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
    Context τ -> Program τ (Context τ)
forall (m :: * -> *) a. Monad m => a -> m a
return Context τ
context

{- |
Run a subprogram from within a lifted @IO@ block.
-}
subProgram :: Context τ -> Program τ α -> IO α
subProgram :: Context τ -> Program τ α -> IO α
subProgram Context τ
context (Program ReaderT (Context τ) IO α
r) = do
    ReaderT (Context τ) IO α -> Context τ -> IO α
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Context τ) IO α
r Context τ
context

{-
This is complicated. The **safe-exceptions** library exports a `throwM` which
is not the `throwM` class method from MonadThrow. See
https://github.com/fpco/safe-exceptions/issues/31 for discussion. In any
event, the re-exports flow back to Control.Monad.Catch from **exceptions** and
Control.Exceptions in **base**. In the execute actions, we need to catch
everything (including asynchronous exceptions); elsewhere we will use and
wrap/export **safe-exceptions**'s variants of the functions.
-}
instance MonadThrow (Program τ) where
    throwM :: e -> Program τ a
throwM = IO a -> Program τ a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Program τ a) -> (e -> IO a) -> e -> Program τ a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw

unHandler :: (ε -> Program τ α) -> (ε -> ReaderT (Context τ) IO α)
unHandler :: (ε -> Program τ α) -> ε -> ReaderT (Context τ) IO α
unHandler = (Program τ α -> ReaderT (Context τ) IO α)
-> (ε -> Program τ α) -> ε -> ReaderT (Context τ) IO α
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Program τ α -> ReaderT (Context τ) IO α
forall τ α. Program τ α -> ReaderT (Context τ) IO α
unProgram

instance MonadCatch (Program τ) where
    catch :: Exception ε => (Program τ) α -> (ε -> (Program τ) α) -> (Program τ) α
    catch :: Program τ α -> (ε -> Program τ α) -> Program τ α
catch Program τ α
program ε -> Program τ α
handler =
        let r :: ReaderT (Context τ) IO α
r = Program τ α -> ReaderT (Context τ) IO α
forall τ α. Program τ α -> ReaderT (Context τ) IO α
unProgram Program τ α
program
            h :: ε -> ReaderT (Context τ) IO α
h = (ε -> Program τ α) -> ε -> ReaderT (Context τ) IO α
forall ε τ α. (ε -> Program τ α) -> ε -> ReaderT (Context τ) IO α
unHandler ε -> Program τ α
handler
         in do
                Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
                IO α -> Program τ α
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO α -> Program τ α) -> IO α -> Program τ α
forall a b. (a -> b) -> a -> b
$ do
                    IO α -> (ε -> IO α) -> IO α
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
                        (ReaderT (Context τ) IO α -> Context τ -> IO α
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Context τ) IO α
r Context τ
context)
                        (\ε
e -> ReaderT (Context τ) IO α -> Context τ -> IO α
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ε -> ReaderT (Context τ) IO α
h ε
e) Context τ
context)

{- |
Initialize the programs's execution context. This takes care of various
administrative actions, including setting up output channels, parsing
command-line arguments (according to the supplied configuration), and putting
in place various semaphores for internal program communication. See
"Core.Program.Arguments" for details.

This is also where you specify the initial {blank, empty, default) value for
the top-level user-defined application state, if you have one. Specify 'None'
if you aren't using this feature.
-}
configure :: Version -> τ -> Config -> IO (Context τ)
configure :: Version -> τ -> Config -> IO (Context τ)
configure Version
version τ
t Config
config = do
    TimeStamp
start <- IO TimeStamp
getCurrentTimeNanoseconds

    String
arg0 <- IO String
getProgName
    MVar Rope
n <- Rope -> IO (MVar Rope)
forall a. a -> IO (MVar a)
newMVar (String -> Rope
forall α. Textual α => α -> Rope
intoRope String
arg0)
    Parameters
p <- Version -> Config -> IO Parameters
handleCommandLine Version
version Config
config
    MVar ExitCode
q <- IO (MVar ExitCode)
forall a. IO (MVar a)
newEmptyMVar
    MVar TimeStamp
i <- TimeStamp -> IO (MVar TimeStamp)
forall a. a -> IO (MVar a)
newMVar TimeStamp
start
    Int
columns <- IO Int
getConsoleWidth
    TQueue Rope
out <- IO (TQueue Rope)
forall a. IO (TQueue a)
newTQueueIO
    TQueue Message
log <- IO (TQueue Message)
forall a. IO (TQueue a)
newTQueueIO
    MVar τ
u <- τ -> IO (MVar τ)
forall a. a -> IO (MVar a)
newMVar τ
t

    MVar Verbosity
l <- Parameters -> IO (MVar Verbosity)
handleVerbosityLevel Parameters
p

    Context τ -> IO (Context τ)
forall (m :: * -> *) a. Monad m => a -> m a
return
        (Context τ -> IO (Context τ)) -> Context τ -> IO (Context τ)
forall a b. (a -> b) -> a -> b
$! Context :: forall τ.
MVar Rope
-> Version
-> Parameters
-> MVar ExitCode
-> MVar TimeStamp
-> Int
-> MVar Verbosity
-> TQueue Rope
-> TQueue Message
-> MVar τ
-> Context τ
Context
            { programNameFrom :: MVar Rope
programNameFrom = MVar Rope
n
            , versionFrom :: Version
versionFrom = Version
version
            , commandLineFrom :: Parameters
commandLineFrom = Parameters
p
            , exitSemaphoreFrom :: MVar ExitCode
exitSemaphoreFrom = MVar ExitCode
q
            , startTimeFrom :: MVar TimeStamp
startTimeFrom = MVar TimeStamp
i
            , terminalWidthFrom :: Int
terminalWidthFrom = Int
columns
            , verbosityLevelFrom :: MVar Verbosity
verbosityLevelFrom = MVar Verbosity
l
            , outputChannelFrom :: TQueue Rope
outputChannelFrom = TQueue Rope
out
            , loggerChannelFrom :: TQueue Message
loggerChannelFrom = TQueue Message
log
            , applicationDataFrom :: MVar τ
applicationDataFrom = MVar τ
u
            }

--

{- |
Probe the width of the terminal, in characters. If it fails to retrieve, for
whatever reason, return a default of 80 characters wide.
-}
getConsoleWidth :: IO (Int)
getConsoleWidth :: IO Int
getConsoleWidth = do
    Maybe (Window Int)
window <- IO (Maybe (Window Int))
forall n. Integral n => IO (Maybe (Window n))
Terminal.size
    let columns :: Int
columns = case Maybe (Window Int)
window of
            Just (Terminal.Window Int
_ Int
w) -> Int
w
            Maybe (Window Int)
Nothing -> Int
80
    Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
columns

--

{- |
Process the command line options and arguments. If an invalid option is
encountered or a [mandatory] argument is missing, then the program will
terminate here.
-}

{-
    We came back here with the error case so we can pass config in to
    buildUsage (otherwise we could have done it all in displayException and
    called that in Core.Program.Arguments). And, returning here lets us set
    up the layout width to match (one off the) actual width of console.
-}
handleCommandLine :: Version -> Config -> IO Parameters
handleCommandLine :: Version -> Config -> IO Parameters
handleCommandLine Version
version Config
config = do
    [String]
argv <- IO [String]
getArgs
    let result :: Either InvalidCommandLine Parameters
result = Config -> [String] -> Either InvalidCommandLine Parameters
parseCommandLine Config
config [String]
argv
    case Either InvalidCommandLine Parameters
result of
        Right Parameters
parameters -> do
            Map LongName ParameterValue
pairs <- Config -> Parameters -> IO (Map LongName ParameterValue)
lookupEnvironmentVariables Config
config Parameters
parameters
            Parameters -> IO Parameters
forall (m :: * -> *) a. Monad m => a -> m a
return Parameters
parameters{environmentValuesFrom :: Map LongName ParameterValue
environmentValuesFrom = Map LongName ParameterValue
pairs}
        Left InvalidCommandLine
e -> case InvalidCommandLine
e of
            HelpRequest Maybe LongName
mode -> do
                Doc Any -> IO ()
forall ann. Doc ann -> IO ()
render (Config -> Maybe LongName -> Doc Any
forall ann. Config -> Maybe LongName -> Doc ann
buildUsage Config
config Maybe LongName
mode)
                ExitCode -> IO Parameters
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
            InvalidCommandLine
VersionRequest -> do
                Doc Any -> IO ()
forall ann. Doc ann -> IO ()
render (Version -> Doc Any
forall ann. Version -> Doc ann
buildVersion Version
version)
                ExitCode -> IO Parameters
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
            InvalidCommandLine
_ -> do
                String -> IO ()
putStr String
"error: "
                String -> IO ()
putStrLn (InvalidCommandLine -> String
forall e. Exception e => e -> String
displayException InvalidCommandLine
e)
                Handle -> IO ()
hFlush Handle
stdout
                ExitCode -> IO Parameters
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
  where
    render :: Doc ann -> IO ()
render Doc ann
message = do
        Int
columns <- IO Int
getConsoleWidth
        let options :: LayoutOptions
options = PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine (Int
columns Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Double
1.0)
        Handle -> SimpleDocStream ann -> IO ()
forall ann. Handle -> SimpleDocStream ann -> IO ()
renderIO Handle
stdout (LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
options Doc ann
message)
        Handle -> IO ()
hFlush Handle
stdout

lookupEnvironmentVariables :: Config -> Parameters -> IO (Map LongName ParameterValue)
lookupEnvironmentVariables :: Config -> Parameters -> IO (Map LongName ParameterValue)
lookupEnvironmentVariables Config
config Parameters
params = do
    let mode :: Maybe LongName
mode = Parameters -> Maybe LongName
commandNameFrom Parameters
params
    let valids :: Set LongName
valids = Maybe LongName -> Config -> Set LongName
extractValidEnvironments Maybe LongName
mode Config
config

    Map LongName ParameterValue
result <- (LongName
 -> Map LongName ParameterValue -> IO (Map LongName ParameterValue))
-> Map LongName ParameterValue
-> Set LongName
-> IO (Map LongName ParameterValue)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM LongName
-> Map LongName ParameterValue -> IO (Map LongName ParameterValue)
f Map LongName ParameterValue
forall κ ν. Map κ ν
emptyMap Set LongName
valids
    Map LongName ParameterValue -> IO (Map LongName ParameterValue)
forall (m :: * -> *) a. Monad m => a -> m a
return Map LongName ParameterValue
result
  where
    f :: LongName -> (Map LongName ParameterValue) -> IO (Map LongName ParameterValue)
    f :: LongName
-> Map LongName ParameterValue -> IO (Map LongName ParameterValue)
f name :: LongName
name@(LongName String
var) Map LongName ParameterValue
acc = do
        Maybe String
result <- String -> IO (Maybe String)
lookupEnv String
var
        Map LongName ParameterValue -> IO (Map LongName ParameterValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map LongName ParameterValue -> IO (Map LongName ParameterValue))
-> Map LongName ParameterValue -> IO (Map LongName ParameterValue)
forall a b. (a -> b) -> a -> b
$ case Maybe String
result of
            Just String
value -> LongName
-> ParameterValue
-> Map LongName ParameterValue
-> Map LongName ParameterValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue LongName
name (String -> ParameterValue
Value String
value) Map LongName ParameterValue
acc
            Maybe String
Nothing -> Map LongName ParameterValue
acc

handleVerbosityLevel :: Parameters -> IO (MVar Verbosity)
handleVerbosityLevel :: Parameters -> IO (MVar Verbosity)
handleVerbosityLevel Parameters
params = do
    let result :: Either ExitCode Verbosity
result = Parameters -> Either ExitCode Verbosity
queryVerbosityLevel Parameters
params
    case Either ExitCode Verbosity
result of
        Right Verbosity
level -> do
            Verbosity -> IO (MVar Verbosity)
forall a. a -> IO (MVar a)
newMVar Verbosity
level
        Left ExitCode
exit -> do
            String -> IO ()
putStrLn String
"error: To set logging level use --verbose or --debug; neither take values."
            Handle -> IO ()
hFlush Handle
stdout
            ExitCode -> IO (MVar Verbosity)
forall a. ExitCode -> IO a
exitWith ExitCode
exit

queryVerbosityLevel :: Parameters -> Either ExitCode Verbosity
queryVerbosityLevel :: Parameters -> Either ExitCode Verbosity
queryVerbosityLevel Parameters
params =
    let debug :: Maybe ParameterValue
debug = LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
"debug" (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params)
        verbose :: Maybe ParameterValue
verbose = LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
"verbose" (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params)
     in case Maybe ParameterValue
debug of
            Just ParameterValue
value -> case ParameterValue
value of
                ParameterValue
Empty -> Verbosity -> Either ExitCode Verbosity
forall a b. b -> Either a b
Right Verbosity
Debug
                Value String
_ -> ExitCode -> Either ExitCode Verbosity
forall a b. a -> Either a b
Left (Int -> ExitCode
ExitFailure Int
2)
            Maybe ParameterValue
Nothing -> case Maybe ParameterValue
verbose of
                Just ParameterValue
value -> case ParameterValue
value of
                    ParameterValue
Empty -> Verbosity -> Either ExitCode Verbosity
forall a b. b -> Either a b
Right Verbosity
Event
                    Value String
_ -> ExitCode -> Either ExitCode Verbosity
forall a b. a -> Either a b
Left (Int -> ExitCode
ExitFailure Int
2)
                Maybe ParameterValue
Nothing -> Verbosity -> Either ExitCode Verbosity
forall a b. b -> Either a b
Right Verbosity
Output