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

-- This is an Internal module, hidden from Haddock
module Core.Program.Context (
    Datum (..),
    emptyDatum,
    Trace (..),
    unTrace,
    Span (..),
    unSpan,
    Context (..),
    handleCommandLine,
    handleVerbosityLevel,
    handleTelemetryChoice,
    Exporter (..),
    Forwarder (..),
    None (..),
    isNone,
    configure,
    Verbosity (..),
    Program (..),
    unProgram,
    getContext,
    fmapContext,
    subProgram,
) where

import Control.Concurrent (ThreadId)
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar)
import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO)
import Control.Concurrent.STM.TVar (TVar, newTVarIO)
import Control.Exception.Safe qualified as Safe (throw)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow (throwM))
import Control.Monad.Reader.Class (MonadReader (..))
import Control.Monad.Trans.Reader (ReaderT (..))
import Core.Data.Clock
import Core.Data.Structures
import Core.Encoding.Json
import Core.Program.Arguments
import Core.Program.Metadata
import Core.System.Base
import Core.Text.Rope
import Data.Foldable (foldrM)
import Data.Int (Int64)
import Data.String (IsString)
import Prettyprinter (LayoutOptions (..), PageWidth (..), layoutPretty)
import Prettyprinter.Render.Text (renderIO)
import System.Console.Terminal.Size qualified as Terminal (Window (..), size)
import System.Environment (getArgs, getProgName, lookupEnv)
import System.Exit (ExitCode (..), exitWith)
import System.IO (hIsTerminalDevice)
import System.Posix.Process qualified as Posix (exitImmediately)
import Prelude hiding (log)

{- |
Carrier for spans and events while their data is being accumulated, and later
sent down the telemetry channel. There is one of these in the Program monad's
Context.
-}

-- `spanIdentifierFrom` is a Maybe because at startup there is not yet a
-- current span. When the first (root) span is formed in `encloseSpan` it uses
-- this as the parent value - in this case, no parent, which is what we want.
data Datum = Datum
    { Datum -> Maybe Span
spanIdentifierFrom :: Maybe Span
    , Datum -> Rope
spanNameFrom :: Rope
    , Datum -> Maybe Rope
serviceNameFrom :: Maybe Rope
    , Datum -> Time
spanTimeFrom :: Time
    , Datum -> Maybe Trace
traceIdentifierFrom :: Maybe Trace
    , Datum -> Maybe Span
parentIdentifierFrom :: Maybe Span
    , Datum -> Maybe Int64
durationFrom :: Maybe Int64
    , Datum -> Map JsonKey JsonValue
attachedMetadataFrom :: Map JsonKey JsonValue
    }
    deriving (Int -> Datum -> ShowS
[Datum] -> ShowS
Datum -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Datum] -> ShowS
$cshowList :: [Datum] -> ShowS
show :: Datum -> String
$cshow :: Datum -> String
showsPrec :: Int -> Datum -> ShowS
$cshowsPrec :: Int -> Datum -> ShowS
Show)

emptyDatum :: Datum
emptyDatum :: Datum
emptyDatum =
    Datum
        { $sel:spanIdentifierFrom:Datum :: Maybe Span
spanIdentifierFrom = forall a. Maybe a
Nothing
        , $sel:spanNameFrom:Datum :: Rope
spanNameFrom = Rope
emptyRope
        , $sel:serviceNameFrom:Datum :: Maybe Rope
serviceNameFrom = forall a. Maybe a
Nothing
        , $sel:spanTimeFrom:Datum :: Time
spanTimeFrom = Time
epochTime
        , $sel:traceIdentifierFrom:Datum :: Maybe Trace
traceIdentifierFrom = forall a. Maybe a
Nothing
        , $sel:parentIdentifierFrom:Datum :: Maybe Span
parentIdentifierFrom = forall a. Maybe a
Nothing
        , $sel:durationFrom:Datum :: Maybe Int64
durationFrom = forall a. Maybe a
Nothing
        , $sel:attachedMetadataFrom:Datum :: Map JsonKey JsonValue
attachedMetadataFrom = forall κ ν. Map κ ν
emptyMap
        }

{- |
Unique identifier for a span. This will be generated by
'Core.Telemetry.Observability.encloseSpan' but for the case where you are
continuing an inherited trace and passed the identifier of the parent span you
can specify it using this constructor.
-}
newtype Span = Span Rope
    deriving (Int -> Span -> ShowS
[Span] -> ShowS
Span -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Span] -> ShowS
$cshowList :: [Span] -> ShowS
show :: Span -> String
$cshow :: Span -> String
showsPrec :: Int -> Span -> ShowS
$cshowsPrec :: Int -> Span -> ShowS
Show, Span -> Span -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Span -> Span -> Bool
$c/= :: Span -> Span -> Bool
== :: Span -> Span -> Bool
$c== :: Span -> Span -> Bool
Eq, String -> Span
forall a. (String -> a) -> IsString a
fromString :: String -> Span
$cfromString :: String -> Span
IsString)

unSpan :: Span -> Rope
unSpan :: Span -> Rope
unSpan (Span Rope
text) = Rope
text

{- |
Unique identifier for a trace. If your program is the top of an service stack
then you can use 'Core.Telemetry.Observability.beginTrace' to generate a new
idenfifier for this request or iteration. More commonly, however, you will
inherit the trace identifier from the application or service which invokes
this program or request handler, and you can specify it by using
'Core.Telemetry.Observability.usingTrace'.
-}
newtype Trace = Trace Rope
    deriving (Int -> Trace -> ShowS
[Trace] -> ShowS
Trace -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Trace] -> ShowS
$cshowList :: [Trace] -> ShowS
show :: Trace -> String
$cshow :: Trace -> String
showsPrec :: Int -> Trace -> ShowS
$cshowsPrec :: Int -> Trace -> ShowS
Show, Trace -> Trace -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Trace -> Trace -> Bool
$c/= :: Trace -> Trace -> Bool
== :: Trace -> Trace -> Bool
$c== :: Trace -> Trace -> Bool
Eq, String -> Trace
forall a. (String -> a) -> IsString a
fromString :: String -> Trace
$cfromString :: String -> Trace
IsString)

unTrace :: Trace -> Rope
unTrace :: Trace -> Rope
unTrace (Trace Rope
text) = Rope
text

data Exporter = Exporter
    { Exporter -> Rope
codenameFrom :: Rope
    , Exporter -> Config -> Config
setupConfigFrom :: Config -> Config
    , Exporter -> forall τ. Context τ -> IO Forwarder
setupActionFrom :: forall τ. Context τ -> IO Forwarder
    }

{- |
Implementation of a forwarder for structured logging of the telemetry channel.
-}
data Forwarder = Forwarder
    { Forwarder -> [Datum] -> IO ()
telemetryHandlerFrom :: [Datum] -> IO ()
    }

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

--
-- The fieldNameFrom idiom is an experiment. Looks very strange,
-- certainly, here in the record type definition and when setting
-- fields, but for the common case of getting a value out of the
-- record, a call like
--
--     fieldNameFrom context
--
-- isn't bad at all, and no worse than the leading underscore
-- convention.
--
--     _fieldName context
--
-- (I would argue better, since _ is already so overloaded as the
-- wildcard symbol in Haskell). Either way, the point is to avoid a
-- bare fieldName because so often you have want to be able to use
-- that field name as a local variable name.
--
data Context τ = Context
    { forall τ. Context τ -> MVar Rope
programNameFrom :: MVar Rope
    , forall τ. Context τ -> Int
terminalWidthFrom :: Int
    , forall τ. Context τ -> Bool
terminalColouredFrom :: Bool
    , forall τ. Context τ -> Version
versionFrom :: Version
    , forall τ. Context τ -> Config
initialConfigFrom :: Config -- only used during initial setup
    , forall τ. Context τ -> [Exporter]
initialExportersFrom :: [Exporter]
    , forall τ. Context τ -> Parameters
commandLineFrom :: Parameters -- derived at startup
    , forall τ. Context τ -> MVar ExitCode
exitSemaphoreFrom :: MVar ExitCode
    , forall τ. Context τ -> MVar Time
startTimeFrom :: MVar Time
    , forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom :: MVar Verbosity
    , forall τ. Context τ -> TQueue (Maybe Rope)
outputChannelFrom :: TQueue (Maybe Rope) -- communication channels
    , forall τ. Context τ -> TQueue (Maybe Datum)
telemetryChannelFrom :: TQueue (Maybe Datum) -- machinery for telemetry
    , forall τ. Context τ -> Maybe Forwarder
telemetryForwarderFrom :: Maybe Forwarder
    , forall τ. Context τ -> TVar (Set ThreadId)
currentScopeFrom :: TVar (Set ThreadId)
    , forall τ. Context τ -> MVar Datum
currentDatumFrom :: MVar Datum
    , forall τ. Context τ -> MVar τ
applicationDataFrom :: MVar τ
    }

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

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

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

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

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

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

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

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

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

You would use this by writing:

@
module Main where

import "Core.Program"

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

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

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

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

/Type variables/

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

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

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

/Programs in separate modules/

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

/Interoperating with the rest of the Haskell ecosystem/

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

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

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

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

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

deriving instance MonadCatch (Program τ)

deriving instance MonadMask (Program t)

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

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

    String
arg0 <- IO String
getProgName
    MVar Rope
n <- forall a. a -> IO (MVar a)
newMVar (forall α. Textual α => α -> Rope
intoRope String
arg0)
    MVar ExitCode
q <- forall a. IO (MVar a)
newEmptyMVar
    MVar Time
i <- forall a. a -> IO (MVar a)
newMVar Time
start
    Int
columns <- IO Int
getConsoleWidth
    Bool
coloured <- IO Bool
getConsoleColoured
    MVar Verbosity
level <- forall a. IO (MVar a)
newEmptyMVar
    TQueue (Maybe Rope)
out <- forall a. IO (TQueue a)
newTQueueIO
    TQueue (Maybe Datum)
tel <- forall a. IO (TQueue a)
newTQueueIO

    TVar (Set ThreadId)
scope <- forall a. a -> IO (TVar a)
newTVarIO forall ε. Key ε => Set ε
emptySet
    MVar Datum
v <- forall a. a -> IO (MVar a)
newMVar Datum
emptyDatum
    MVar τ
u <- forall a. a -> IO (MVar a)
newMVar τ
t

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$!
        Context
            { $sel:programNameFrom:Context :: MVar Rope
programNameFrom = MVar Rope
n
            , $sel:terminalWidthFrom:Context :: Int
terminalWidthFrom = Int
columns
            , $sel:terminalColouredFrom:Context :: Bool
terminalColouredFrom = Bool
coloured
            , $sel:versionFrom:Context :: Version
versionFrom = Version
version
            , $sel:initialConfigFrom:Context :: Config
initialConfigFrom = Config
config
            , $sel:initialExportersFrom:Context :: [Exporter]
initialExportersFrom = []
            , $sel:commandLineFrom:Context :: Parameters
commandLineFrom = Parameters
emptyParameters -- will be filled in handleCommandLine
            , $sel:exitSemaphoreFrom:Context :: MVar ExitCode
exitSemaphoreFrom = MVar ExitCode
q
            , $sel:startTimeFrom:Context :: MVar Time
startTimeFrom = MVar Time
i
            , $sel:verbosityLevelFrom:Context :: MVar Verbosity
verbosityLevelFrom = MVar Verbosity
level -- will be filled in handleVerbosityLevel
            , $sel:outputChannelFrom:Context :: TQueue (Maybe Rope)
outputChannelFrom = TQueue (Maybe Rope)
out
            , $sel:telemetryChannelFrom:Context :: TQueue (Maybe Datum)
telemetryChannelFrom = TQueue (Maybe Datum)
tel
            , $sel:telemetryForwarderFrom:Context :: Maybe Forwarder
telemetryForwarderFrom = forall a. Maybe a
Nothing
            , $sel:currentScopeFrom:Context :: TVar (Set ThreadId)
currentScopeFrom = TVar (Set ThreadId)
scope
            , $sel:currentDatumFrom:Context :: MVar Datum
currentDatumFrom = MVar Datum
v
            , $sel:applicationDataFrom:Context :: MVar τ
applicationDataFrom = MVar τ
u
            }

--

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

getConsoleColoured :: IO Bool
getConsoleColoured :: IO Bool
getConsoleColoured = do
    Bool
terminal <- Handle -> IO Bool
hIsTerminalDevice Handle
stdout
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
terminal

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

{-
    We came back here with the error case so we can pass config in to
    buildUsage (otherwise we could have done it all in displayException and
    called that in Core.Program.Arguments). And, returning here lets us set
    up the layout width to match (one off the) actual width of console.
-}
handleCommandLine :: Context τ -> IO (Context τ)
handleCommandLine :: forall τ. Context τ -> IO (Context τ)
handleCommandLine Context τ
context = do
    [String]
argv <- IO [String]
getArgs

    let config :: Config
config = forall τ. Context τ -> Config
initialConfigFrom Context τ
context
        version :: Version
version = forall τ. Context τ -> Version
versionFrom Context τ
context
        result :: Either InvalidCommandLine Parameters
result = Config -> [String] -> Either InvalidCommandLine Parameters
parseCommandLine Config
config [String]
argv

    case Either InvalidCommandLine Parameters
result of
        Right Parameters
parameters -> do
            Map LongName ParameterValue
pairs <- Config -> Parameters -> IO (Map LongName ParameterValue)
lookupEnvironmentVariables Config
config Parameters
parameters
            let params :: Parameters
params =
                    Parameters
parameters
                        { environmentValuesFrom :: Map LongName ParameterValue
environmentValuesFrom = Map LongName ParameterValue
pairs
                        }
            -- update the result of all this and return in
            let context' :: Context τ
context' =
                    Context τ
context
                        { $sel:commandLineFrom:Context :: Parameters
commandLineFrom = Parameters
params
                        }
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Context τ
context'
        Left InvalidCommandLine
e -> case InvalidCommandLine
e of
            HelpRequest Maybe LongName
mode -> do
                forall {ann}. Doc ann -> IO ()
render (forall ann. Config -> Maybe LongName -> Doc ann
buildUsage Config
config Maybe LongName
mode)
                forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
            InvalidCommandLine
VersionRequest -> do
                forall {ann}. Doc ann -> IO ()
render (forall ann. Version -> Doc ann
buildVersion Version
version)
                forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
            InvalidCommandLine
_ -> do
                String -> IO ()
putStr String
"error: "
                String -> IO ()
putStrLn (forall e. Exception e => e -> String
displayException InvalidCommandLine
e)
                Handle -> IO ()
hFlush Handle
stdout
                forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
  where
    render :: Doc ann -> IO ()
render Doc ann
message = do
        Int
columns <- IO Int
getConsoleWidth
        let options :: LayoutOptions
options = PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine (Int
columns forall a. Num a => a -> a -> a
- Int
1) Double
1.0)
        forall ann. Handle -> SimpleDocStream ann -> IO ()
renderIO Handle
stdout (forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
options Doc ann
message)
        Handle -> IO ()
hFlush Handle
stdout

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

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

handleVerbosityLevel :: Context τ -> IO (MVar Verbosity)
handleVerbosityLevel :: forall τ. Context τ -> IO (MVar Verbosity)
handleVerbosityLevel Context τ
context = do
    let params :: Parameters
params = forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
        level :: MVar Verbosity
level = forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context
        result :: Either ExitCode Verbosity
result = Parameters -> Either ExitCode Verbosity
queryVerbosityLevel Parameters
params
    case Either ExitCode Verbosity
result of
        Left ExitCode
exit -> do
            String -> IO ()
putStrLn String
"error: To set logging level use --verbose or --debug; neither take a value."
            Handle -> IO ()
hFlush Handle
stdout
            forall a. ExitCode -> IO a
exitWith ExitCode
exit
        Right Verbosity
verbosity -> do
            forall a. MVar a -> a -> IO ()
putMVar MVar Verbosity
level Verbosity
verbosity
            forall (f :: * -> *) a. Applicative f => a -> f a
pure MVar Verbosity
level

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

handleTelemetryChoice :: Context τ -> IO (Context τ)
handleTelemetryChoice :: forall τ. Context τ -> IO (Context τ)
handleTelemetryChoice Context τ
context = do
    let params :: Parameters
params = forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
        options :: Map LongName ParameterValue
options = Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params
        exporters :: [Exporter]
exporters = forall τ. Context τ -> [Exporter]
initialExportersFrom Context τ
context

    case forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
"telemetry" Map LongName ParameterValue
options of
        Maybe ParameterValue
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Context τ
context
        Just ParameterValue
Empty -> do
            String -> IO ()
putStrLn String
"error: Need to supply a value when specifiying --telemetry."
            ExitCode -> IO ()
Posix.exitImmediately (Int -> ExitCode
ExitFailure Int
99)
            forall a. HasCallStack => a
undefined
        Just (Value String
value) -> case Rope -> [Exporter] -> Maybe Exporter
lookupExporter (forall α. Textual α => α -> Rope
intoRope String
value) [Exporter]
exporters of
            Maybe Exporter
Nothing -> do
                String -> IO ()
putStrLn (String
"error: supplied value \"" forall a. [a] -> [a] -> [a]
++ String
value forall a. [a] -> [a] -> [a]
++ String
"\" not a valid telemetry exporter.")
                ExitCode -> IO ()
Posix.exitImmediately (Int -> ExitCode
ExitFailure Int
99)
                forall a. HasCallStack => a
undefined
            Just Exporter
exporter -> do
                let setupAction :: Context τ -> IO Forwarder
setupAction = Exporter -> forall τ. Context τ -> IO Forwarder
setupActionFrom Exporter
exporter

                -- run the IO action to setup the Forwareder
                Forwarder
forwarder <- forall τ. Context τ -> IO Forwarder
setupAction Context τ
context

                -- and return it
                forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    Context τ
context
                        { $sel:telemetryForwarderFrom:Context :: Maybe Forwarder
telemetryForwarderFrom = forall a. a -> Maybe a
Just Forwarder
forwarder
                        }
  where
    lookupExporter :: Rope -> [Exporter] -> Maybe Exporter
    lookupExporter :: Rope -> [Exporter] -> Maybe Exporter
lookupExporter Rope
_ [] = forall a. Maybe a
Nothing
    lookupExporter Rope
target (Exporter
exporter : [Exporter]
exporters) =
        case Rope
target forall a. Eq a => a -> a -> Bool
== Exporter -> Rope
codenameFrom Exporter
exporter of
            Bool
False -> Rope -> [Exporter] -> Maybe Exporter
lookupExporter Rope
target [Exporter]
exporters
            Bool
True -> forall a. a -> Maybe a
Just Exporter
exporter