{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK prune #-}

{- |
Embelish a Haskell command-line program with useful behaviours.

/Runtime/

Sets number of capabilities (heavy-weight operating system threads used by
the GHC runtime to run Haskell green threads) to the number of CPU cores
available (for some reason the default is 1 capability only, which is a bit
silly on a multicore system).

Install signal handlers to properly terminate the program performing
cleanup as necessary.

Encoding is set to UTF-8, working around confusing bugs that sometimes
occur when applications are running in Docker containers.

/Logging and output/

The 'Program' monad provides functions for both normal output and debug
logging. A common annoyance when building command line tools and daemons is
getting program output to @stdout@ and debug messages interleaved, made
even worse when error messages written to @stderr@ land in the same
console. To avoid this, when all output is sent through a single channel.
This includes both normal output and log messages.

/Exceptions/

Ideally your code should handle (and not leak) exceptions, as is good
practice anywhere in the Haskell ecosystem. As a measure of last resort
however, if an exception is thrown (and not caught) by your program it will
be caught at the outer 'execute' entrypoint, logged for debugging, and then
your program will exit.

/Customizing the execution context/

The 'execute' function will run your 'Program' in a basic 'Context'
initialized with appropriate defaults. Most settings can be changed at
runtime, but to specify the allowed command-line options and expected
arguments you can initialize your program using 'configure' and then run
with 'executeWith'.
-}
module Core.Program.Execute (
    Program (),

    -- * Running programs
    configure,
    execute,
    executeWith,

    -- * Exiting a program
    terminate,

    -- * Accessing program context
    getCommandLine,
    queryCommandName,
    queryOptionFlag,
    queryOptionValue,
    queryOptionValue',
    queryArgument,
    queryRemaining,
    queryEnvironmentValue,
    getProgramName,
    setProgramName,
    getVerbosityLevel,
    setVerbosityLevel,
    getConsoleWidth,
    getApplicationState,
    setApplicationState,

    -- * Useful actions
    outputEntire,
    inputEntire,
    execProcess,
    sleepThread,
    resetTimer,
    trap_,

    -- * Exception handling
    catch,
    throw,
    try,

    -- * Internals
    Context,
    None (..),
    isNone,
    unProgram,
    invalid,
    Boom (..),
    loopForever,
    lookupOptionFlag,
    lookupOptionValue,
    lookupArgument,
    lookupEnvironmentValue,
) where

import Control.Concurrent (
    forkFinally,
    forkIO,
    killThread,
    myThreadId,
    threadDelay,
 )
import Control.Concurrent.MVar (
    MVar,
    modifyMVar_,
    newEmptyMVar,
    putMVar,
    readMVar,
    tryPutMVar,
 )
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TQueue (
    TQueue,
    readTQueue,
    tryReadTQueue,
    unGetTQueue,
    writeTQueue,
 )
import Control.Concurrent.STM.TVar (
    readTVarIO,
 )
import Control.Exception qualified as Base (throwIO)
import Control.Exception.Safe qualified as Safe (
    catch,
    throw,
 )
import Control.Monad (
    forM_,
    forever,
    void,
    when,
 )
import Control.Monad.Reader.Class (MonadReader (ask))
import Core.Data.Clock
import Core.Data.Structures
import Core.Encoding.External
import Core.Program.Arguments
import Core.Program.Context
import Core.Program.Exceptions
import Core.Program.Logging
import Core.Program.Signal
import Core.System.Base (
    Exception,
    Handle,
    SomeException,
    displayException,
    hFlush,
    liftIO,
    stdout,
 )
import Core.Text.Bytes
import Core.Text.Rope
import Data.ByteString qualified as B (hPut)
import Data.ByteString.Char8 qualified as C (singleton)
import Data.List qualified as List (intersperse)
import GHC.Conc (getNumProcessors, numCapabilities, setNumCapabilities)
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import System.Directory (
    findExecutable,
 )
import System.Exit (ExitCode (..))
import System.Process.Typed (nullStream, proc, readProcess, setStdin)
import Prelude hiding (log)

{- |
Trap any exceptions coming out of the given Program action, and discard them.
The one and only time you want this is inside an endless loop:

@
    'Conrol.Monad.forever' $ do
        'trap_'
            ( 'bracket'
                obtainResource
                releaseResource
                useResource
            )
@

This function really will swollow expcetions, which means that you'd better
have handled any synchronous checked errors already with a 'catch' and/or have
released resources with 'bracket' or 'finally' as shown above.

A warning level message will be sent to the log channel indicating that an
uncaught exception was trapped along with a debug level message showing the
exception text, if any.

@since 0.2.11
-}
trap_ :: Program τ α -> Program τ ()
trap_ :: forall τ α. Program τ α -> Program τ ()
trap_ Program τ α
action =
    forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
        (forall (f :: * -> *) a. Functor f => f a -> f ()
void Program τ α
action)
        ( \(SomeException
e :: SomeException) ->
            let text :: Rope
text = forall α. Textual α => α -> Rope
intoRope (forall e. Exception e => e -> String
displayException SomeException
e)
             in do
                    forall τ. Rope -> Program τ ()
warn Rope
"Trapped uncaught exception"
                    forall τ. Rope -> Rope -> Program τ ()
debug Rope
"e" Rope
text
        )

{- |
Embelish a program with useful behaviours. See module header
"Core.Program.Execute" for a detailed description. Internally this function
calls 'configure' with an appropriate default when initializing.
-}
execute :: Program None α -> IO ()
execute :: forall α. Program None α -> IO ()
execute Program None α
program = do
    Context None
context <- forall τ. Version -> τ -> Config -> IO (Context τ)
configure Version
"" None
None ([Options] -> Config
simpleConfig [])
    forall τ α. Context τ -> Program τ α -> IO ()
executeActual Context None
context Program None α
program

{- |
Embelish a program with useful behaviours, supplying a configuration
for command-line options & argument parsing and an initial value for
the top-level application state, if appropriate.
-}
executeWith :: Context τ -> Program τ α -> IO ()
executeWith :: forall τ α. Context τ -> Program τ α -> IO ()
executeWith = forall τ α. Context τ -> Program τ α -> IO ()
executeActual

executeActual :: Context τ -> Program τ α -> IO ()
executeActual :: forall τ α. Context τ -> Program τ α -> IO ()
executeActual Context τ
context0 Program τ α
program = do
    -- command line +RTS -Nn -RTS value
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numCapabilities forall a. Eq a => a -> a -> Bool
== Int
1) (IO Int
getNumProcessors forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO ()
setNumCapabilities)

    -- force UTF-8 working around bad VMs
    TextEncoding -> IO ()
setLocaleEncoding TextEncoding
utf8

    Context τ
context1 <- forall τ. Context τ -> IO (Context τ)
handleCommandLine Context τ
context0
    Context τ
context <- forall τ. Context τ -> IO (Context τ)
handleTelemetryChoice Context τ
context1

    MVar Verbosity
level <- forall τ. Context τ -> IO (MVar Verbosity)
handleVerbosityLevel Context τ
context

    let quit :: MVar ExitCode
quit = forall τ. Context τ -> MVar ExitCode
exitSemaphoreFrom Context τ
context
        out :: TQueue (Maybe Rope)
out = forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom Context τ
context
        tel :: TQueue (Maybe Datum)
tel = forall τ. Context τ -> TQueue (Maybe Datum)
telemetryChannelFrom Context τ
context
        forwarder :: Maybe Forwarder
forwarder = forall τ. Context τ -> Maybe Forwarder
telemetryForwarderFrom Context τ
context

    -- set up signal handlers
    ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
        MVar ExitCode -> MVar Verbosity -> IO ()
setupSignalHandlers MVar ExitCode
quit MVar Verbosity
level

    -- set up standard output
    MVar ()
vo <- forall a. IO (MVar a)
newEmptyMVar
    ThreadId
_ <-
        forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally
            (TQueue (Maybe Rope) -> IO ()
processStandardOutput TQueue (Maybe Rope)
out)
            (\Either SomeException ()
_ -> forall a. MVar a -> a -> IO ()
putMVar MVar ()
vo ())

    -- set up debug logger
    MVar ()
vl <- forall a. IO (MVar a)
newEmptyMVar
    ThreadId
_ <-
        forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally
            (Maybe Forwarder
-> MVar Verbosity
-> TQueue (Maybe Rope)
-> TQueue (Maybe Datum)
-> IO ()
processTelemetryMessages Maybe Forwarder
forwarder MVar Verbosity
level TQueue (Maybe Rope)
out TQueue (Maybe Datum)
tel)
            (\Either SomeException ()
_ -> forall a. MVar a -> a -> IO ()
putMVar MVar ()
vl ())

    -- run actual program, ensuring to grab any otherwise uncaught exceptions.
    ThreadId
t1 <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
            ( do
                --
                -- execute actual "main". Note that we're not passing the
                -- Scope into the program's Context; it stays the default
                -- Nothing because the outer Scope is none of the
                -- program's business and we absolutely don't want an
                -- awaitAll to sit there and block on our machinery
                -- threads.
                --
                -- We use tryPutMVar here (rather than putMVar) because we
                -- might already be on the way out and need to not block.
                --
                α
_ <- forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context Program τ α
program
                Bool
_ <- forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ExitCode
quit ExitCode
ExitSuccess
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            )
            ( \(SomeException
e :: SomeException) -> do
                let text :: Rope
text = forall α. Textual α => α -> Rope
intoRope (forall e. Exception e => e -> String
displayException SomeException
e)
                forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context forall a b. (a -> b) -> a -> b
$ do
                    forall τ. Verbosity -> Program τ ()
setVerbosityLevel Verbosity
Debug
                    forall τ. Rope -> Program τ ()
critical Rope
text
                Bool
_ <- forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ExitCode
quit (Int -> ExitCode
ExitFailure Int
127)
                forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            )

    -- wait for indication to terminate
    ExitCode
code <- forall a. MVar a -> IO a
readMVar MVar ExitCode
quit

    -- kill main thread
    ThreadId -> IO ()
killThread ThreadId
t1

    -- instruct handlers to finish, and wait for the message queues to
    -- drain. Allow 10 seconds, then timeout, in case something has gone
    -- wrong and queues don't empty.

    ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
        Int -> IO ()
threadDelay Int
10000000
        String -> IO ()
putStrLn String
"error: Timeout"
        forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw (Int -> ExitCode
ExitFailure Int
99)

    ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
        let scope :: TVar (Set ThreadId)
scope = forall τ. Context τ -> TVar (Set ThreadId)
currentScopeFrom Context τ
context
        Set ThreadId
pointers <- forall a. TVar a -> IO a
readTVarIO TVar (Set ThreadId)
scope
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set ThreadId
pointers ThreadId -> IO ()
killThread

    forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Datum)
tel forall a. Maybe a
Nothing

    forall a. MVar a -> IO a
readMVar MVar ()
vl

    forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out forall a. Maybe a
Nothing

    forall a. MVar a -> IO a
readMVar MVar ()
vo

    Handle -> IO ()
hFlush Handle
stdout

    -- exiting this way avoids "Exception: ExitSuccess" noise in GHCi
    if ExitCode
code forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
        then forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else (forall e a. Exception e => e -> IO a
Base.throwIO ExitCode
code)

processStandardOutput :: TQueue (Maybe Rope) -> IO ()
processStandardOutput :: TQueue (Maybe Rope) -> IO ()
processStandardOutput TQueue (Maybe Rope)
out =
    IO ()
loop
  where
    loop :: IO ()
    loop :: IO ()
loop = do
        Maybe Rope
probable <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            forall a. TQueue a -> STM a
readTQueue TQueue (Maybe Rope)
out

        case Maybe Rope
probable of
            Maybe Rope
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just Rope
text -> do
                Handle -> Rope -> IO ()
hWrite Handle
stdout Rope
text
                Handle -> ByteString -> IO ()
B.hPut Handle
stdout (Char -> ByteString
C.singleton Char
'\n')
                Handle -> IO ()
hFlush Handle
stdout
                IO ()
loop

--
-- I'm embarrased how long it took to get here. At one point we were firing
-- off an Async.race of two threads for every item coming down the queue. And
-- you know what? That didn't work either. After all of that, realized that
-- the technique used   by **io-streams** to just pass along a stream of Maybes,
-- with Nothing signalling end-of-stream is exactly good enough for our needs.
--
processTelemetryMessages :: Maybe Forwarder -> MVar Verbosity -> TQueue (Maybe Rope) -> TQueue (Maybe Datum) -> IO ()
processTelemetryMessages :: Maybe Forwarder
-> MVar Verbosity
-> TQueue (Maybe Rope)
-> TQueue (Maybe Datum)
-> IO ()
processTelemetryMessages Maybe Forwarder
Nothing MVar Verbosity
_ TQueue (Maybe Rope)
_ TQueue (Maybe Datum)
tel = do
    forall {a}. TQueue (Maybe a) -> IO ()
ignoreForever TQueue (Maybe Datum)
tel
  where
    ignoreForever :: TQueue (Maybe a) -> IO ()
ignoreForever TQueue (Maybe a)
queue = do
        Maybe a
possibleItem <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
            forall a. TQueue a -> STM a
readTQueue TQueue (Maybe a)
queue -- blocks
        case Maybe a
possibleItem of
            -- time to shutdown
            Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            -- otherwise igonore
            Just a
_ -> do
                TQueue (Maybe a) -> IO ()
ignoreForever TQueue (Maybe a)
queue
processTelemetryMessages (Just Forwarder
processor) MVar Verbosity
v TQueue (Maybe Rope)
out TQueue (Maybe Datum)
tel = do
    forall a.
([a] -> IO ())
-> MVar Verbosity
-> TQueue (Maybe Rope)
-> TQueue (Maybe a)
-> IO ()
loopForever [Datum] -> IO ()
action MVar Verbosity
v TQueue (Maybe Rope)
out TQueue (Maybe Datum)
tel
  where
    action :: [Datum] -> IO ()
action = Forwarder -> [Datum] -> IO ()
telemetryHandlerFrom Forwarder
processor

loopForever :: ([a] -> IO ()) -> MVar Verbosity -> TQueue (Maybe Rope) -> TQueue (Maybe a) -> IO ()
loopForever :: forall a.
([a] -> IO ())
-> MVar Verbosity
-> TQueue (Maybe Rope)
-> TQueue (Maybe a)
-> IO ()
loopForever [a] -> IO ()
action MVar Verbosity
v TQueue (Maybe Rope)
out TQueue (Maybe a)
queue = do
    -- block waiting for an item
    Maybe [a]
possibleItems <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        Int -> [a] -> STM (Maybe [a])
cycleOverQueue Int
0 []

    case Maybe [a]
possibleItems of
        -- we're done!
        Maybe [a]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        -- handle it and loop
        Just [a]
items -> do
            Time
start <- IO Time
getCurrentTimeNanoseconds
            forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
                ( do
                    [a] -> IO ()
action (forall a. [a] -> [a]
reverse [a]
items)
                    forall {p}. (Eq p, Num p, Show p) => Time -> p -> IO ()
reportStatus Time
start (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
items)
                )
                ( \(SomeException
e :: SomeException) -> do
                    forall {p}. Show p => Time -> p -> IO ()
reportProblem Time
start SomeException
e
                )
            forall a.
([a] -> IO ())
-> MVar Verbosity
-> TQueue (Maybe Rope)
-> TQueue (Maybe a)
-> IO ()
loopForever [a] -> IO ()
action MVar Verbosity
v TQueue (Maybe Rope)
out TQueue (Maybe a)
queue
  where
    cycleOverQueue :: Int -> [a] -> STM (Maybe [a])
cycleOverQueue !Int
count [a]
items =
        if Int
count forall a. Ord a => a -> a -> Bool
>= (Int
1024 :: Int)
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just [a]
items)
            else Int -> [a] -> STM (Maybe [a])
cycleOverQueue' Int
count [a]
items

    cycleOverQueue' :: Int -> [a] -> STM (Maybe [a])
cycleOverQueue' !Int
count [a]
items =
        case [a]
items of
            [] -> do
                Maybe a
possibleItem <- forall a. TQueue a -> STM a
readTQueue TQueue (Maybe a)
queue -- blocks
                case Maybe a
possibleItem of
                    -- we're finished! time to shutdown
                    Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                    -- otherwise start accumulating
                    Just a
item -> do
                        Int -> [a] -> STM (Maybe [a])
cycleOverQueue Int
1 (a
item forall a. a -> [a] -> [a]
: [])
            [a]
_ -> do
                Maybe (Maybe a)
pending <- forall a. TQueue a -> STM (Maybe a)
tryReadTQueue TQueue (Maybe a)
queue -- doesn't block
                case Maybe (Maybe a)
pending of
                    -- nothing left in the queue
                    Maybe (Maybe a)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just [a]
items)
                    -- otherwise we get one of our Maybe Datum, and consider it
                    Just Maybe a
possibleItem -> do
                        case Maybe a
possibleItem of
                            -- oh, time to stop! We put the Nothing back into
                            -- the queue, then let the accumulated items get
                            -- processed. The next loop will read the
                            -- Nothing and shutdown.
                            Maybe a
Nothing -> do
                                forall a. TQueue a -> a -> STM ()
unGetTQueue TQueue (Maybe a)
queue forall a. Maybe a
Nothing
                                forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just [a]
items)
                            -- continue accumulating!
                            Just a
item -> do
                                Int -> [a] -> STM (Maybe [a])
cycleOverQueue (Int
count forall a. Num a => a -> a -> a
+ Int
1) (a
item forall a. a -> [a] -> [a]
: [a]
items)

    reportStatus :: Time -> p -> IO ()
reportStatus Time
start p
num = do
        Verbosity
level <- forall a. MVar a -> IO a
readMVar MVar Verbosity
v
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isInternal Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
            Time
now <- IO Time
getCurrentTimeNanoseconds
            let desc :: Rope
desc = case p
num of
                    p
1 -> Rope
"1 event"
                    p
_ -> forall α. Textual α => α -> Rope
intoRope (forall a. Show a => a -> String
show p
num) forall a. Semigroup a => a -> a -> a
<> Rope
" events"
                message :: Rope
message =
                    Time -> Time -> Bool -> Severity -> Rope -> Rope
formatLogMessage
                        Time
start
                        Time
now
                        Bool
True
                        Severity
SeverityInternal
                        (Rope
"Sent " forall a. Semigroup a => a -> a -> a
<> Rope
desc)
            forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
                forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out (forall a. a -> Maybe a
Just Rope
message)

    reportProblem :: Time -> p -> IO ()
reportProblem Time
start p
e = do
        Verbosity
level <- forall a. MVar a -> IO a
readMVar MVar Verbosity
v
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity -> Bool
isEvent Verbosity
level) forall a b. (a -> b) -> a -> b
$ do
            Time
now <- IO Time
getCurrentTimeNanoseconds
            let message :: Rope
message =
                    Time -> Time -> Bool -> Severity -> Rope -> Rope
formatLogMessage
                        Time
start
                        Time
now
                        Bool
True
                        Severity
SeverityWarn
                        (Rope
"Sending telemetry failed (Exception: " forall a. Semigroup a => a -> a -> a
<> forall α. Textual α => α -> Rope
intoRope (forall a. Show a => a -> String
show p
e) forall a. Semigroup a => a -> a -> a
<> Rope
"); Restarting exporter.")
            forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
                forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Rope)
out (forall a. a -> Maybe a
Just Rope
message)

{- |
Safely exit the program with the supplied exit code. Current output and debug
queues will be flushed, and then the process will terminate. This function
does not return.
-}

-- putting to the quit MVar initiates the cleanup and exit sequence, but
-- throwing the asynchronous exception to self also aborts execution and
-- starts unwinding back up the stack.
--
-- forever is used here to get an IO α as the return type.
terminate :: Int -> Program τ α
terminate :: forall τ α. Int -> Program τ α
terminate Int
code = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let quit :: MVar ExitCode
quit = forall τ. Context τ -> MVar ExitCode
exitSemaphoreFrom Context τ
context

    let exit :: ExitCode
exit = case Int
code of
            Int
0 -> ExitCode
ExitSuccess
            Int
_ -> Int -> ExitCode
ExitFailure Int
code

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        forall a. MVar a -> a -> IO ()
putMVar MVar ExitCode
quit ExitCode
exit
        ThreadId
self <- IO ThreadId
myThreadId
        ThreadId -> IO ()
killThread ThreadId
self
        forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
            Int -> IO ()
threadDelay forall a. Bounded a => a
maxBound

-- undocumented
getVerbosityLevel :: Program τ Verbosity
getVerbosityLevel :: forall τ. Program τ Verbosity
getVerbosityLevel = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Verbosity
level <- forall a. MVar a -> IO a
readMVar (forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
        forall (m :: * -> *) a. Monad m => a -> m a
return Verbosity
level

{- |
Change the verbosity level of the program's logging output. This changes
whether 'info' and the 'debug' family of functions emit to the logging
stream; they do /not/ affect 'write'ing to the terminal on the standard
output stream.
-}
setVerbosityLevel :: Verbosity -> Program τ ()
setVerbosityLevel :: forall τ. Verbosity -> Program τ ()
setVerbosityLevel Verbosity
level = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        let v :: MVar Verbosity
v = forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context
        forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Verbosity
v (\Verbosity
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Verbosity
level)

{- |
Override the program name used for logging, etc. At least, that was the
idea. Nothing makes use of this at the moment. @:/@
-}
setProgramName :: Rope -> Program τ ()
setProgramName :: forall τ. Rope -> Program τ ()
setProgramName Rope
name = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        let v :: MVar Rope
v = forall τ. Context τ -> MVar Rope
programNameFrom Context τ
context
        forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Rope
v (\Rope
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Rope
name)

{- |
Get the program name as invoked from the command-line (or as overridden by
'setProgramName').
-}
getProgramName :: Program τ Rope
getProgramName :: forall τ. Program τ Rope
getProgramName = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        let v :: MVar Rope
v = forall τ. Context τ -> MVar Rope
programNameFrom Context τ
context
        forall a. MVar a -> IO a
readMVar MVar Rope
v

{- |
Retreive the current terminal's width, in characters.

If you are outputting an object with a 'Core.Text.Untilities.Render'
instance then you may not need this; you can instead use 'writeR' which is
aware of the width of your terminal and will reflow (in as much as the
underlying type's @Render@ instance lets it).
-}
getConsoleWidth :: Program τ Int
getConsoleWidth :: forall τ. Program τ Int
getConsoleWidth = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let width :: Int
width = forall τ. Context τ -> Int
terminalWidthFrom Context τ
context
    forall (m :: * -> *) a. Monad m => a -> m a
return Int
width

{- |
Get the user supplied application state as originally supplied to
'configure' and modified subsequntly by replacement with
'setApplicationState'.

@
    settings <- 'getApplicationState'
@
-}
getApplicationState :: Program τ τ
getApplicationState :: forall τ. Program τ τ
getApplicationState = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        let v :: MVar τ
v = forall τ. Context τ -> MVar τ
applicationDataFrom Context τ
context
        forall a. MVar a -> IO a
readMVar MVar τ
v

{- |
Update the user supplied top-level application state.

@
    let settings' = settings { answer = 42 }
    'setApplicationState' settings'
@
-}
setApplicationState :: τ -> Program τ ()
setApplicationState :: forall τ. τ -> Program τ ()
setApplicationState τ
user = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        let v :: MVar τ
v = forall τ. Context τ -> MVar τ
applicationDataFrom Context τ
context
        forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar τ
v (\τ
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure τ
user)

{- |
Write the supplied @Bytes@ to the given @Handle@. Note that in contrast to
'write' we don't output a trailing newline.

@
    'outputEntire' h b
@

Do /not/ use this to output to @stdout@ as that would bypass the mechanism
used by the 'write'*, 'info', and 'debug'* functions to sequence output
correctly. If you wish to write to the terminal use:

@
    'write' ('intoRope' b)
@

(which is not /unsafe/, but will lead to unexpected results if the binary
blob you pass in is other than UTF-8 text).
-}
outputEntire :: Handle -> Bytes -> Program τ ()
outputEntire :: forall τ. Handle -> Bytes -> Program τ ()
outputEntire Handle
handle Bytes
contents = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> Bytes -> IO ()
hOutput Handle
handle Bytes
contents)

{- |
Read the (entire) contents of the specified @Handle@.
-}
inputEntire :: Handle -> Program τ Bytes
inputEntire :: forall τ. Handle -> Program τ Bytes
inputEntire Handle
handle = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Handle -> IO Bytes
hInput Handle
handle)

data ProcessProblem
    = CommandNotFound Rope
    deriving (Int -> ProcessProblem -> ShowS
[ProcessProblem] -> ShowS
ProcessProblem -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProcessProblem] -> ShowS
$cshowList :: [ProcessProblem] -> ShowS
show :: ProcessProblem -> String
$cshow :: ProcessProblem -> String
showsPrec :: Int -> ProcessProblem -> ShowS
$cshowsPrec :: Int -> ProcessProblem -> ShowS
Show)

instance Exception ProcessProblem

{- |
Execute an external child process and wait for its output and result. The
command is specified first and and subsequent arguments as elements of the
list. This helper then logs the command being executed to the debug output,
which can be useful when you're trying to find out what exactly what program
is being invoked.

Keep in mind that this isn't invoking a shell; arguments and their values have
to be enumerated separately:

@
    'execProcess' [\"\/usr\/bin\/ssh\", \"-l\", \"admin\", \"203.0.113.42\", \"\\\'remote command here\\\'\"]
@

having to write out the individual options and arguments and deal with
escaping is a bit of an annoyance but that's /execvp(3)/ for you.

The return tuple is the exit code from the child process, its entire @stdout@
and its entire @stderr@, if any. Note that this is not a streaming interface,
so if you're doing something that returns huge amounts of output you'll want
to use something like __io-streams__ instead.

(this wraps __typed-process__'s 'readProcess')
-}
execProcess :: [Rope] -> Program τ (ExitCode, Rope, Rope)
execProcess :: forall τ. [Rope] -> Program τ (ExitCode, Rope, Rope)
execProcess [] = forall a. HasCallStack => String -> a
error String
"No command provided"
execProcess (Rope
cmd : [Rope]
args) =
    let cmd' :: String
cmd' = forall α. Textual α => Rope -> α
fromRope Rope
cmd
        args' :: [String]
args' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall α. Textual α => Rope -> α
fromRope [Rope]
args
        task :: ProcessConfig () () ()
task = String -> [String] -> ProcessConfig () () ()
proc String
cmd' [String]
args'
        task1 :: ProcessConfig () () ()
task1 = forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream ProcessConfig () () ()
task
        command :: Rope
command = forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
List.intersperse (Char -> Rope
singletonRope Char
' ') (Rope
cmd forall a. a -> [a] -> [a]
: [Rope]
args))
     in do
            forall τ. Rope -> Rope -> Program τ ()
debug Rope
"command" Rope
command

            Maybe String
probe <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                String -> IO (Maybe String)
findExecutable String
cmd'
            case Maybe String
probe of
                Maybe String
Nothing -> do
                    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw (Rope -> ProcessProblem
CommandNotFound Rope
cmd)
                Just String
_ -> do
                    (ExitCode
exit, ByteString
out, ByteString
err) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
                        forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
readProcess ProcessConfig () () ()
task1

                    forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExitCode
exit, forall α. Textual α => α -> Rope
intoRope ByteString
out, forall α. Textual α => α -> Rope
intoRope ByteString
err)

{- |
Reset the start time (used to calculate durations shown in event- and
debug-level logging) held in the @Context@ to zero. This is useful if you want
to see the elapsed time taken by a specific worker rather than seeing log
entries relative to the program start time which is the default.

If you want to start time held on your main program thread to maintain a count
of the total elapsed program time, then fork a new thread for your worker and
reset the timer there.

@
    'Core.Program.Threads.forkThread' $ do
        'resetTimer'
        ...
@

then times output in the log messages will be relative to that call to
'resetTimer', not the program start.

@since 0.2.7
-}
resetTimer :: Program τ ()
resetTimer :: forall τ. Program τ ()
resetTimer = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Time
start <- IO Time
getCurrentTimeNanoseconds
        let v :: MVar Time
v = forall τ. Context τ -> MVar Time
startTimeFrom Context τ
context
        forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Time
v (\Time
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Time
start)

{- |
Pause the current thread for the given number of seconds. For
example, to delay a second and a half, do:

@
    'sleepThread' 1.5
@

(this wraps __base__'s 'threadDelay')
-}

--
-- FIXME is this the right type, given we want to avoid type default warnings?
--
sleepThread :: Rational -> Program τ ()
sleepThread :: forall τ. Rational -> Program τ ()
sleepThread Rational
seconds =
    let us :: Int
us = forall a b. (RealFrac a, Integral b) => a -> b
floor (forall a. Real a => a -> Rational
toRational (Rational
seconds forall a. Num a => a -> a -> a
* Rational
1e6))
     in forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
us

{- |
Retrieve the values of parameters parsed from options and arguments supplied
by the user on the command-line.

The command-line parameters are returned in a 'Map', mapping from from the
option or argument name to the supplied value. You can query this map
directly:

@
program = do
    params <- 'getCommandLine'
    let result = 'lookupKeyValue' \"silence\" (paramterValuesFrom params)
    case result of
        'Nothing' -> 'return' ()
        'Just' quiet = case quiet of
            'Value' _ -> 'throw' NotQuiteRight                 -- complain that flag doesn't take value
            'Empty'   -> 'write' \"You should be quiet now\"   -- much better
    ...
@

which is pattern matching to answer "was this option specified by the user?"
or "what was the value of this [mandatory] argument?", and then "if so, did
the parameter have a value?"

This is available should you need to differentiate between a @Value@ and an
@Empty@ 'ParameterValue', but for many cases as a convenience you can use the
'queryOptionFlag', 'queryOptionValue', and 'queryArgument' functions below.
-}
getCommandLine :: Program τ (Parameters)
getCommandLine :: forall τ. Program τ Parameters
getCommandLine = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall τ. Context τ -> Parameters
commandLineFrom Context τ
context)

{- |
Arguments are mandatory, so by the time your program is running a value
has already been identified. This retreives the value for that parameter.

@
program = do
    file <- 'queryArgument' \"filename\"
    ...
@

@since 0.2.7
-}
queryArgument :: LongName -> Program τ Rope
queryArgument :: forall τ. LongName -> Program τ Rope
queryArgument LongName
name = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let params :: Parameters
params = forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
    case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> forall a. HasCallStack => String -> a
error String
"Attempted lookup of unconfigured argument"
        Just ParameterValue
argument -> case ParameterValue
argument of
            ParameterValue
Empty -> forall a. HasCallStack => String -> a
error String
"Invalid State"
            Value String
value -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall α. Textual α => α -> Rope
intoRope String
value)

lookupArgument :: LongName -> Parameters -> Maybe String
lookupArgument :: LongName -> Parameters -> Maybe String
lookupArgument LongName
name Parameters
params =
    case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> forall a. Maybe a
Nothing
        Just ParameterValue
argument -> case ParameterValue
argument of
            ParameterValue
Empty -> forall a. HasCallStack => String -> a
error String
"Invalid State"
            Value String
value -> forall a. a -> Maybe a
Just String
value
{-# DEPRECATED lookupArgument "Use queryArgument instead" #-}

{- |
In other applications, you want to gather up the remaining arguments on the
command-line. You need to have specified 'Remaining' in the configuration.

@
program = do
    files \<- 'queryRemaining'
    ...
@

@since 0.3.5
-}
queryRemaining :: Program τ [Rope]
queryRemaining :: forall τ. Program τ [Rope]
queryRemaining = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let params :: Parameters
params = forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
    let remaining :: [String]
remaining = Parameters -> [String]
remainingArgumentsFrom Parameters
params
    forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall α. Textual α => α -> Rope
intoRope [String]
remaining)

{- |
Look to see if the user supplied a valued option and if so, what its value
was. Use of the @LambdaCase@ extension makes accessing the option (and
specifying a default if it is absent) reasonably nice:

@
program = do
    region \<- 'queryOptionValue' \"region\" '>>=' \\case
        'Nothing' -> 'pure' \"us-west-2\" -- Oregon, not a bad default
        'Just' value -> 'pure' value
@

If you require something other than the text value as entered by the user
you'll need to do something to parse the returned value and convert it to an
appropriate type  See 'queryOptionValue'' for an alternative that does this
automatically in many common cases, i.e. for options that take numberic
values.

@since 0.3.5
-}
queryOptionValue :: LongName -> Program τ (Maybe Rope)
queryOptionValue :: forall τ. LongName -> Program τ (Maybe Rope)
queryOptionValue LongName
name = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let params :: Parameters
params = forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
    case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just ParameterValue
argument -> case ParameterValue
argument of
            ParameterValue
Empty -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Rope
emptyRope)
            Value String
value -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall α. Textual α => α -> Rope
intoRope String
value))

lookupOptionValue :: LongName -> Parameters -> Maybe String
lookupOptionValue :: LongName -> Parameters -> Maybe String
lookupOptionValue LongName
name Parameters
params =
    case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> forall a. Maybe a
Nothing
        Just ParameterValue
argument -> case ParameterValue
argument of
            ParameterValue
Empty -> forall a. Maybe a
Nothing
            Value String
value -> forall a. a -> Maybe a
Just String
value
{-# DEPRECATED lookupOptionValue "Use queryOptionValue instead" #-}

data QueryParameterError
    = OptionValueMissing LongName
    | UnableParseValue LongName
    deriving (Int -> QueryParameterError -> ShowS
[QueryParameterError] -> ShowS
QueryParameterError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [QueryParameterError] -> ShowS
$cshowList :: [QueryParameterError] -> ShowS
show :: QueryParameterError -> String
$cshow :: QueryParameterError -> String
showsPrec :: Int -> QueryParameterError -> ShowS
$cshowsPrec :: Int -> QueryParameterError -> ShowS
Show)

instance Exception QueryParameterError where
    displayException :: QueryParameterError -> String
displayException QueryParameterError
e = case QueryParameterError
e of
        OptionValueMissing (LongName String
name) -> String
"Option --" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" specified but without a value."
        UnableParseValue (LongName String
name) -> String
"Unable to parse the value supplied to --" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"."

{- |
Look to see if the user supplied a valued option and if so, what its value
was. This covers the common case of wanting to read a numeric argument from an
option:

@
program = do
    count \<- 'queryOptionValue'' \"count\" '>>=' \\case
        'Nothing' -> 'pure' (0 :: 'Int')
        'Just' value -> 'pure' value
    ...
@

The return type of this function has the same semantics as 'queryOptionValue':
if the option is absent you get 'Nothing' back (and in the example above we
specify a default in that case) and 'Just' if a value is present. Unlike the
original function, however, here we assume success in reading the value! If
the value is unable to be parsed into the nominated Haskell type using
'parseExternal' then an exception with an appropriate error message will be
thrown­—which is what you want if the user specifies something that can't be
parsed.

Note that the return type is polymorphic so you'll need to ensure the concrete
type you actually want is specified either via type inference or by adding a
type annotation somewhere.

@since 0.5.1
-}
queryOptionValue' :: Externalize ξ => LongName -> Program τ (Maybe ξ)
queryOptionValue' :: forall ξ τ. Externalize ξ => LongName -> Program τ (Maybe ξ)
queryOptionValue' LongName
name = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let params :: Parameters
params = forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
    case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
        Just ParameterValue
parameter -> case ParameterValue
parameter of
            ParameterValue
Empty -> forall ε τ α. Exception ε => ε -> Program τ α
throw (LongName -> QueryParameterError
OptionValueMissing LongName
name)
            Value String
value -> case forall ξ. Externalize ξ => Rope -> Maybe ξ
parseExternal (String -> Rope
packRope String
value) of
                Maybe ξ
Nothing -> forall ε τ α. Exception ε => ε -> Program τ α
throw (LongName -> QueryParameterError
UnableParseValue LongName
name)
                Just ξ
actual -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just ξ
actual)

{- |
Returns @True@ if the option is present, and @False@ if it is not.

@
program = do
    overwrite \<- 'queryOptionFlag' \"overwrite\"
    ...
@

@since 0.3.5
-}
queryOptionFlag :: LongName -> Program τ Bool
queryOptionFlag :: forall τ. LongName -> Program τ Bool
queryOptionFlag LongName
name = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let params :: Parameters
params = forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
    case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Just ParameterValue
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

lookupOptionFlag :: LongName -> Parameters -> Maybe Bool
lookupOptionFlag :: LongName -> Parameters -> Maybe Bool
lookupOptionFlag LongName
name Parameters
params =
    case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> forall a. Maybe a
Nothing
        Just ParameterValue
argument -> case ParameterValue
argument of
            ParameterValue
_ -> forall a. a -> Maybe a
Just Bool
True -- nom, nom
{-# DEPRECATED lookupOptionFlag "Use queryOptionFlag instead" #-}

{- |
Look to see if the user supplied the named environment variable and if so,
return what its value was.

@since 0.3.5
-}
queryEnvironmentValue :: LongName -> Program τ (Maybe Rope)
queryEnvironmentValue :: forall τ. LongName -> Program τ (Maybe Rope)
queryEnvironmentValue LongName
name = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let params :: Parameters
params = forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
    case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
environmentValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> forall a. HasCallStack => String -> a
error String
"Attempted lookup of unconfigured environment variable"
        Just ParameterValue
param -> case ParameterValue
param of
            ParameterValue
Empty -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Value String
str -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall α. Textual α => α -> Rope
intoRope String
str))

lookupEnvironmentValue :: LongName -> Parameters -> Maybe String
lookupEnvironmentValue :: LongName -> Parameters -> Maybe String
lookupEnvironmentValue LongName
name Parameters
params =
    case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
environmentValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> forall a. Maybe a
Nothing
        Just ParameterValue
param -> case ParameterValue
param of
            ParameterValue
Empty -> forall a. Maybe a
Nothing
            Value String
str -> forall a. a -> Maybe a
Just String
str
{-# DEPRECATED lookupEnvironmentValue "Use queryEnvironment instead" #-}

{- |
Retreive the sub-command mode selected by the user. This assumes your program
was set up to take sub-commands via 'complexConfig'.

@
    mode <- queryCommandName
@

@since 0.3.5
-}
queryCommandName :: Program τ Rope
queryCommandName :: forall τ. Program τ Rope
queryCommandName = do
    Context τ
context <- forall r (m :: * -> *). MonadReader r m => m r
ask
    let params :: Parameters
params = forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
    case Parameters -> Maybe LongName
commandNameFrom Parameters
params of
        Just (LongName String
name) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall α. Textual α => α -> Rope
intoRope String
name)
        Maybe LongName
Nothing -> forall a. HasCallStack => String -> a
error String
"Attempted lookup of command but not a Complex Config"

{- |
Illegal internal state resulting from what should be unreachable code or
otherwise a programmer error.
-}
invalid :: Program τ α
invalid :: forall τ α. Program τ α
invalid = forall a. HasCallStack => String -> a
error String
"Invalid State"