{-# LANGUAGE BangPatterns #-}
{-# 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,
    queryArgument,
    queryRemaining,
    queryEnvironmentValue,
    getProgramName,
    setProgramName,
    getVerbosityLevel,
    setVerbosityLevel,
    getConsoleWidth,
    getApplicationState,
    setApplicationState,

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

    -- * Re-exports from safe-exports
    Safe.catch,
    Safe.catchesAsync,
    Safe.throw,
    Safe.try,
    Safe.tryAsync,

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

import Chrono.TimeStamp (getCurrentTimeNanoseconds)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (
    ExceptionInLinkedThread (..),
 )
import qualified Control.Concurrent.Async as Async (
    async,
    cancel,
    race,
    race_,
    wait,
 )
import Control.Concurrent.MVar (
    MVar,
    modifyMVar_,
    putMVar,
    readMVar,
 )
import Control.Concurrent.STM (
    atomically,
 )
import Control.Concurrent.STM.TQueue (
    TQueue,
    readTQueue,
    tryReadTQueue,
    unGetTQueue,
    writeTQueue,
 )
import qualified Control.Exception as Base (throwIO)
import qualified Control.Exception.Safe as Safe (catch, catchesAsync, throw, try, tryAsync)
import Control.Monad (
    void,
    when,
 )
import Control.Monad.Catch (Handler (..))
import Control.Monad.Reader.Class (MonadReader (ask))
import Core.Data.Structures
import Core.Program.Arguments
import Core.Program.Context
import Core.Program.Logging
import Core.Program.Signal
import Core.System.Base
import Core.Text.Bytes
import Core.Text.Rope
import qualified Data.ByteString as B (hPut)
import qualified Data.ByteString.Char8 as C (singleton)
import qualified Data.List as List (intersperse)
import GHC.Conc (getNumProcessors, numCapabilities, setNumCapabilities)
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import System.Directory (
    findExecutable,
 )
import System.Exit (ExitCode (..))
import qualified System.Posix.Process as Posix (exitImmediately)
import System.Process.Typed (closed, proc, readProcess, setStdin)
import Prelude hiding (log)

--
-- If an exception escapes, we'll catch it here. The displayException value
-- for some exceptions is really quit unhelpful, so we pattern match the
-- wrapping gumpf away for cases as we encounter them. The final entry is the
-- catch-all.
--
-- Note this is called via Safe.catchesAsync because we want to be able to
-- strip out ExceptionInLinkedThread (which is asynchronous and otherwise
-- reasonably special) from the final output message.
--
escapeHandlers :: Context c -> [Handler IO ExitCode]
escapeHandlers :: Context c -> [Handler IO ExitCode]
escapeHandlers Context c
context =
    [ (ExitCode -> IO ExitCode) -> Handler IO ExitCode
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(ExitCode
code :: ExitCode) -> ExitCode -> IO ExitCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
code)
    , (ExceptionInLinkedThread -> IO ExitCode) -> Handler IO ExitCode
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(ExceptionInLinkedThread Async a
_ SomeException
e) -> SomeException -> IO ExitCode
forall e. Exception e => e -> IO ExitCode
bail SomeException
e)
    , (SomeException -> IO ExitCode) -> Handler IO ExitCode
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(SomeException
e :: SomeException) -> SomeException -> IO ExitCode
forall e. Exception e => e -> IO ExitCode
bail SomeException
e)
    ]
  where
    bail :: Exception e => e -> IO ExitCode
    bail :: e -> IO ExitCode
bail e
e =
        let text :: Rope
text = String -> Rope
forall α. Textual α => α -> Rope
intoRope (e -> String
forall e. Exception e => e -> String
displayException e
e)
         in do
                Context c -> Program c () -> IO ()
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context c
context (Program c () -> IO ()) -> Program c () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    Verbosity -> Program c ()
forall τ. Verbosity -> Program τ ()
setVerbosityLevel Verbosity
Debug
                    Rope -> Program c ()
forall τ. Rope -> Program τ ()
critical Rope
text
                ExitCode -> IO ExitCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> ExitCode
ExitFailure Int
127)

--
-- If an exception occurs in one of the output handlers, its failure causes
-- a subsequent race condition when the program tries to clean up and drain
-- the queues. So we use `exitImmediately` (which we normally avoid, as it
-- unhelpfully destroys the parent process if you're in ghci) because we
-- really need the process to go down and we're in an inconsistent state
-- where debug or console output is no longer possible.
--
collapseHandler :: String -> SomeException -> IO ()
collapseHandler :: String -> SomeException -> IO ()
collapseHandler String
problem SomeException
e = do
    String -> IO ()
putStr String
"error: "
    String -> IO ()
putStrLn String
problem
    SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
e
    ExitCode -> IO ()
Posix.exitImmediately (Int -> ExitCode
ExitFailure Int
99)

{- |
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.

An info 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_ :: Program τ α -> Program τ ()
trap_ Program τ α
action =
    Program τ () -> (SomeException -> Program τ ()) -> Program τ ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
        (Program τ α -> Program τ ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Program τ α
action)
        ( \(SomeException
e :: SomeException) ->
            let text :: Rope
text = String -> Rope
forall α. Textual α => α -> Rope
intoRope (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e)
             in do
                    Rope -> Program τ ()
forall τ. Rope -> Program τ ()
warn Rope
"Trapped uncaught exception"
                    Rope -> Rope -> Program τ ()
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 :: Program None α -> IO ()
execute Program None α
program = do
    Context None
context <- Version -> None -> Config -> IO (Context None)
forall τ. Version -> τ -> Config -> IO (Context τ)
configure Version
"" None
None ([Options] -> Config
simpleConfig [])
    Context None -> Program None α -> IO ()
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 :: Context τ -> Program τ α -> IO ()
executeWith = Context τ -> Program τ α -> IO ()
forall τ α. Context τ -> Program τ α -> IO ()
executeActual

executeActual :: Context τ -> Program τ α -> IO ()
executeActual :: Context τ -> Program τ α -> IO ()
executeActual Context τ
context0 Program τ α
program = do
    -- command line +RTS -Nn -RTS value
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numCapabilities Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (IO Int
getNumProcessors IO Int -> (Int -> IO ()) -> IO ()
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 <- Context τ -> IO (Context τ)
forall τ. Context τ -> IO (Context τ)
handleCommandLine Context τ
context0
    Context τ
context <- Context τ -> IO (Context τ)
forall τ. Context τ -> IO (Context τ)
handleTelemetryChoice Context τ
context1

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

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

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

    -- set up standard output
    Async ()
o <-
        IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
            TQueue (Maybe Rope) -> IO ()
processStandardOutput TQueue (Maybe Rope)
out

    -- set up debug logger
    Async ()
l <-
        IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
            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

    -- run actual program, ensuring to grab any otherwise uncaught exceptions.
    ExitCode
code <-
        IO ExitCode -> [Handler IO ExitCode] -> IO ExitCode
forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
Safe.catchesAsync
            ( do
                Either ExitCode ()
result <-
                    IO ExitCode -> IO () -> IO (Either ExitCode ())
forall a b. IO a -> IO b -> IO (Either a b)
Async.race
                        ( do
                            ExitCode
code <- MVar ExitCode -> IO ExitCode
forall a. MVar a -> IO a
readMVar MVar ExitCode
quit
                            ExitCode -> IO ExitCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
code
                        )
                        ( do
                            -- execute actual "main"
                            α
_ <- Context τ -> Program τ α -> IO α
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context Program τ α
program
                            () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                        )

                case Either ExitCode ()
result of
                    Left ExitCode
code' -> ExitCode -> IO ExitCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
code'
                    Right () -> ExitCode -> IO ExitCode
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExitCode
ExitSuccess
            )
            (Context τ -> [Handler IO ExitCode]
forall c. Context c -> [Handler IO ExitCode]
escapeHandlers Context τ
context)

    -- instruct handlers to finish, and wait for the message queues to drain.
    -- Allow 0.1 seconds, then timeout, in case something has gone wrong and
    -- queues don't empty.
    IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
Async.race_
        ( do
            STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                TQueue (Maybe Datum) -> Maybe Datum -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue (Maybe Datum)
tel Maybe Datum
forall a. Maybe a
Nothing

            Async () -> IO ()
forall a. Async a -> IO a
Async.wait Async ()
l

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

            Async () -> IO ()
forall a. Async a -> IO a
Async.wait Async ()
o
        )
        ( do
            Int -> IO ()
threadDelay Int
10000000

            Async () -> IO ()
forall a. Async a -> IO ()
Async.cancel Async ()
l
            Async () -> IO ()
forall a. Async a -> IO ()
Async.cancel Async ()
o
            String -> IO ()
putStrLn String
"error: Timeout"
        )

    Handle -> IO ()
hFlush Handle
stdout

    -- exiting this way avoids "Exception: ExitSuccess" noise in GHCi
    if ExitCode
code ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
        then () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else (ExitCode -> IO ()
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 () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
        (IO ()
loop)
        (String -> SomeException -> IO ()
collapseHandler String
"output processing collapsed")
  where
    loop :: IO ()
    loop :: IO ()
loop = do
        Maybe Rope
probable <- STM (Maybe Rope) -> IO (Maybe Rope)
forall a. STM a -> IO a
atomically (STM (Maybe Rope) -> IO (Maybe Rope))
-> STM (Maybe Rope) -> IO (Maybe Rope)
forall a b. (a -> b) -> a -> b
$ do
            TQueue (Maybe Rope) -> STM (Maybe Rope)
forall a. TQueue a -> STM a
readTQueue TQueue (Maybe Rope)
out

        case Maybe Rope
probable of
            Maybe Rope
Nothing -> () -> IO ()
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')
                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
    TQueue (Maybe Datum) -> IO ()
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 <- STM (Maybe a) -> IO (Maybe a)
forall a. STM a -> IO a
atomically (STM (Maybe a) -> IO (Maybe a)) -> STM (Maybe a) -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ do
            TQueue (Maybe a) -> STM (Maybe a)
forall a. TQueue a -> STM a
readTQueue TQueue (Maybe a)
queue -- blocks
        case Maybe a
possibleItem of
            -- time to shutdown
            Maybe a
Nothing -> () -> IO ()
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
    IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
        (([Datum] -> IO ())
-> MVar Verbosity
-> TQueue (Maybe Rope)
-> TQueue (Maybe Datum)
-> IO ()
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)
        (String -> SomeException -> IO ()
collapseHandler String
"telemetry processing collapsed")
  where
    action :: [Datum] -> IO ()
action = Forwarder -> [Datum] -> IO ()
telemetryHandlerFrom Forwarder
processor

loopForever :: ([a] -> IO ()) -> MVar Verbosity -> TQueue (Maybe Rope) -> TQueue (Maybe a) -> IO ()
loopForever :: ([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 <- STM (Maybe [a]) -> IO (Maybe [a])
forall a. STM a -> IO a
atomically (STM (Maybe [a]) -> IO (Maybe [a]))
-> STM (Maybe [a]) -> IO (Maybe [a])
forall a b. (a -> b) -> a -> b
$ do
        [a] -> STM (Maybe [a])
cycleOverQueue []

    case Maybe [a]
possibleItems of
        -- we're done!
        Maybe [a]
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        -- handle it and loop
        Just [a]
items -> do
            TimeStamp
start <- IO TimeStamp
getCurrentTimeNanoseconds
            IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
                ( do
                    [a] -> IO ()
action ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
items)
                    TimeStamp -> Int -> IO ()
forall a. (Eq a, Num a, Show a) => TimeStamp -> a -> IO ()
reportStatus TimeStamp
start ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
items)
                )
                ( \(SomeException
e :: SomeException) -> do
                    TimeStamp -> SomeException -> IO ()
forall a. Show a => TimeStamp -> a -> IO ()
reportProblem TimeStamp
start SomeException
e
                )
            ([a] -> IO ())
-> MVar Verbosity
-> TQueue (Maybe Rope)
-> TQueue (Maybe a)
-> IO ()
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 :: [a] -> STM (Maybe [a])
cycleOverQueue [a]
items =
        case [a]
items of
            [] -> do
                Maybe a
possibleItem <- TQueue (Maybe a) -> STM (Maybe a)
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 -> Maybe [a] -> STM (Maybe [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [a]
forall a. Maybe a
Nothing
                    -- otherwise start accumulating
                    Just a
item -> do
                        [a] -> STM (Maybe [a])
cycleOverQueue (a
item a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [])
            [a]
_ -> do
                Maybe (Maybe a)
pending <- TQueue (Maybe a) -> STM (Maybe (Maybe a))
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 -> Maybe [a] -> STM (Maybe [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> Maybe [a]
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
                                TQueue (Maybe a) -> Maybe a -> STM ()
forall a. TQueue a -> a -> STM ()
unGetTQueue TQueue (Maybe a)
queue Maybe a
forall a. Maybe a
Nothing
                                Maybe [a] -> STM (Maybe [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> Maybe [a]
forall a. a -> Maybe a
Just [a]
items)
                            -- continue accumulating!
                            Just a
item -> do
                                [a] -> STM (Maybe [a])
cycleOverQueue (a
item a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
items)

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

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

-- putting to the quit MVar initiates the cleanup and exit sequence,
-- but throwing the exception also aborts execution and starts unwinding
-- back up the stack.
terminate :: Int -> Program τ α
terminate :: Int -> Program τ α
terminate Int
code =
    let exit :: ExitCode
exit = case Int
code of
            Int
0 -> ExitCode
ExitSuccess
            Int
_ -> Int -> ExitCode
ExitFailure Int
code
     in do
            Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
            let quit :: MVar ExitCode
quit = Context τ -> MVar ExitCode
forall τ. Context τ -> MVar ExitCode
exitSemaphoreFrom Context τ
context
            IO α -> Program τ α
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO α -> Program τ α) -> IO α -> Program τ α
forall a b. (a -> b) -> a -> b
$ do
                MVar ExitCode -> ExitCode -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ExitCode
quit ExitCode
exit
                ExitCode -> IO α
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw ExitCode
exit

-- undocumented
getVerbosityLevel :: Program τ Verbosity
getVerbosityLevel :: Program τ Verbosity
getVerbosityLevel = do
    Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO Verbosity -> Program τ Verbosity
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Verbosity -> Program τ Verbosity)
-> IO Verbosity -> Program τ Verbosity
forall a b. (a -> b) -> a -> b
$ do
        Verbosity
level <- MVar Verbosity -> IO Verbosity
forall a. MVar a -> IO a
readMVar (Context τ -> MVar Verbosity
forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context)
        Verbosity -> IO Verbosity
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 :: Verbosity -> Program τ ()
setVerbosityLevel Verbosity
level = 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
        let v :: MVar Verbosity
v = Context τ -> MVar Verbosity
forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context
        MVar Verbosity -> (Verbosity -> IO Verbosity) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Verbosity
v (\Verbosity
_ -> Verbosity -> IO 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 :: Rope -> Program τ ()
setProgramName Rope
name = 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
        let v :: MVar Rope
v = Context τ -> MVar Rope
forall τ. Context τ -> MVar Rope
programNameFrom Context τ
context
        MVar Rope -> (Rope -> IO Rope) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar Rope
v (\Rope
_ -> Rope -> IO 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 :: Program τ Rope
getProgramName = do
    Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
    IO Rope -> Program τ Rope
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Rope -> Program τ Rope) -> IO Rope -> Program τ Rope
forall a b. (a -> b) -> a -> b
$ do
        let v :: MVar Rope
v = Context τ -> MVar Rope
forall τ. Context τ -> MVar Rope
programNameFrom Context τ
context
        MVar Rope -> IO Rope
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 :: Program τ Int
getConsoleWidth = do
    Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
    let width :: Int
width = Context τ -> Int
forall τ. Context τ -> Int
terminalWidthFrom Context τ
context
    Int -> Program τ Int
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'.

@
    state <- getApplicationState
@
-}
getApplicationState :: Program τ τ
getApplicationState :: Program τ τ
getApplicationState = 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
        let v :: MVar τ
v = Context τ -> MVar τ
forall τ. Context τ -> MVar τ
applicationDataFrom Context τ
context
        MVar τ -> IO τ
forall a. MVar a -> IO a
readMVar MVar τ
v

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

@
    let state' = state { answer = 42 }
    setApplicationState state'
@
-}
setApplicationState :: τ -> Program τ ()
setApplicationState :: τ -> Program τ ()
setApplicationState τ
user = 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
        let v :: MVar τ
v = Context τ -> MVar τ
forall τ. Context τ -> MVar τ
applicationDataFrom Context τ
context
        MVar τ -> (τ -> IO τ) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar τ
v (\τ
_ -> τ -> IO τ
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 :: Handle -> Bytes -> Program τ ()
outputEntire Handle
handle Bytes
contents = IO () -> Program τ ()
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 :: Handle -> Program τ Bytes
inputEntire Handle
handle = IO Bytes -> Program τ Bytes
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
(Int -> ProcessProblem -> ShowS)
-> (ProcessProblem -> String)
-> ([ProcessProblem] -> ShowS)
-> Show ProcessProblem
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 :: [Rope] -> Program τ (ExitCode, Rope, Rope)
execProcess [] = String -> Program τ (ExitCode, Rope, Rope)
forall a. HasCallStack => String -> a
error String
"No command provided"
execProcess (Rope
cmd : [Rope]
args) =
    let cmd' :: String
cmd' = Rope -> String
forall α. Textual α => Rope -> α
fromRope Rope
cmd
        args' :: [String]
args' = (Rope -> String) -> [Rope] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rope -> String
forall α. Textual α => Rope -> α
fromRope [Rope]
args
        task :: ProcessConfig () () ()
task = String -> [String] -> ProcessConfig () () ()
proc String
cmd' [String]
args'
        task1 :: ProcessConfig () () ()
task1 = StreamSpec 'STInput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin StreamSpec 'STInput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
closed ProcessConfig () () ()
task
        command :: Rope
command = [Rope] -> Rope
forall a. Monoid a => [a] -> a
mconcat (Rope -> [Rope] -> [Rope]
forall a. a -> [a] -> [a]
List.intersperse (Char -> Rope
singletonRope Char
' ') (Rope
cmd Rope -> [Rope] -> [Rope]
forall a. a -> [a] -> [a]
: [Rope]
args))
     in do
            Rope -> Rope -> Program τ ()
forall τ. Rope -> Rope -> Program τ ()
debug Rope
"command" Rope
command

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

                    (ExitCode, Rope, Rope) -> Program τ (ExitCode, Rope, Rope)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExitCode
exit, ByteString -> Rope
forall α. Textual α => α -> Rope
intoRope ByteString
out, ByteString -> Rope
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 :: Program τ ()
resetTimer = 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
        TimeStamp
start <- IO TimeStamp
getCurrentTimeNanoseconds
        let v :: MVar TimeStamp
v = Context τ -> MVar TimeStamp
forall τ. Context τ -> MVar TimeStamp
startTimeFrom Context τ
context
        MVar TimeStamp -> (TimeStamp -> IO TimeStamp) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar TimeStamp
v (\TimeStamp
_ -> TimeStamp -> IO TimeStamp
forall (f :: * -> *) a. Applicative f => a -> f a
pure TimeStamp
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 :: Rational -> Program τ ()
sleepThread Rational
seconds =
    let us :: Int
us = Rational -> Int
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Rational
forall a. Real a => a -> Rational
toRational (Rational
seconds Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
1e6))
     in IO () -> Program τ ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Program τ ()) -> IO () -> Program τ ()
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 :: Program τ Parameters
getCommandLine = do
    Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
    Parameters -> Program τ Parameters
forall (m :: * -> *) a. Monad m => a -> m a
return (Context τ -> Parameters
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 :: LongName -> Program τ Rope
queryArgument LongName
name = do
    Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
    let params :: Parameters
params = Context τ -> Parameters
forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
    case LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> String -> Program τ Rope
forall a. HasCallStack => String -> a
error String
"Attempted lookup of unconfigured argument"
        Just ParameterValue
argument -> case ParameterValue
argument of
            ParameterValue
Empty -> String -> Program τ Rope
forall a. HasCallStack => String -> a
error String
"Invalid State"
            Value String
value -> Rope -> Program τ Rope
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Rope
forall α. Textual α => α -> Rope
intoRope String
value)

lookupArgument :: LongName -> Parameters -> Maybe String
lookupArgument :: LongName -> Parameters -> Maybe String
lookupArgument LongName
name Parameters
params =
    case LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> Maybe String
forall a. Maybe a
Nothing
        Just ParameterValue
argument -> case ParameterValue
argument of
            ParameterValue
Empty -> String -> Maybe String
forall a. HasCallStack => String -> a
error String
"Invalid State"
            Value String
value -> String -> Maybe String
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 :: Program τ [Rope]
queryRemaining = do
    Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
    let params :: Parameters
params = Context τ -> Parameters
forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
    let remaining :: [String]
remaining = Parameters -> [String]
remainingArgumentsFrom Parameters
params
    [Rope] -> Program τ [Rope]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> Rope) -> [String] -> [Rope]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Rope
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 might make accessing the parameter a
bit eaiser:

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

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

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

{- |
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 :: LongName -> Program τ Bool
queryOptionFlag LongName
name = do
    Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
    let params :: Parameters
params = Context τ -> Parameters
forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
    case LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> Bool -> Program τ Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        Just ParameterValue
_ -> Bool -> Program τ Bool
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 LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> Maybe Bool
forall a. Maybe a
Nothing
        Just ParameterValue
argument -> case ParameterValue
argument of
            ParameterValue
_ -> Bool -> Maybe Bool
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 :: LongName -> Program τ (Maybe Rope)
queryEnvironmentValue LongName
name = do
    Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
    let params :: Parameters
params = Context τ -> Parameters
forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
    case LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
environmentValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> String -> Program τ (Maybe Rope)
forall a. HasCallStack => String -> a
error String
"Attempted lookup of unconfigured environment variable"
        Just ParameterValue
param -> case ParameterValue
param of
            ParameterValue
Empty -> Maybe Rope -> Program τ (Maybe Rope)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Rope
forall a. Maybe a
Nothing
            Value String
str -> Maybe Rope -> Program τ (Maybe Rope)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rope -> Maybe Rope
forall a. a -> Maybe a
Just (String -> Rope
forall α. Textual α => α -> Rope
intoRope String
str))

lookupEnvironmentValue :: LongName -> Parameters -> Maybe String
lookupEnvironmentValue :: LongName -> Parameters -> Maybe String
lookupEnvironmentValue LongName
name Parameters
params =
    case LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
name (Parameters -> Map LongName ParameterValue
environmentValuesFrom Parameters
params) of
        Maybe ParameterValue
Nothing -> Maybe String
forall a. Maybe a
Nothing
        Just ParameterValue
param -> case ParameterValue
param of
            ParameterValue
Empty -> Maybe String
forall a. Maybe a
Nothing
            Value String
str -> String -> Maybe String
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 :: Program τ Rope
queryCommandName = do
    Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
    let params :: Parameters
params = Context τ -> Parameters
forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
    case Parameters -> Maybe LongName
commandNameFrom Parameters
params of
        Just (LongName String
name) -> Rope -> Program τ Rope
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Rope
forall α. Textual α => α -> Rope
intoRope String
name)
        Maybe LongName
Nothing -> String -> Program τ Rope
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 :: Program τ α
invalid = String -> Program τ α
forall a. HasCallStack => String -> a
error String
"Invalid State"