{-# 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 τ -> TimeStamp
startTimeFrom :: 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. So you're best off putting your
-- top-level 'Program' actions in a separate modules so you can refer to them
-- from test suites and example snippets.
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
  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
-> 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 :: TimeStamp
startTimeFrom = TimeStamp
start,
        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