{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
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,
Boom (..),
) where
import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds)
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar)
import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO)
import qualified Control.Exception.Safe 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.Structures
import Core.Encoding.Json
import Core.Program.Arguments
import Core.Program.Metadata
import Core.System.Base hiding (catch, throw)
import Core.Text.Rope
import Data.Foldable (foldrM)
import System.IO (hIsTerminalDevice)
import Data.Int (Int64)
import Data.String (IsString)
import Prettyprinter (LayoutOptions (..), PageWidth (..), layoutPretty)
import Prettyprinter.Render.Text (renderIO)
import qualified System.Console.Terminal.Size as Terminal (Window (..), size)
import System.Environment (getArgs, getProgName, lookupEnv)
import System.Exit (ExitCode (..), exitWith)
import qualified System.Posix.Process as Posix (exitImmediately)
import Prelude hiding (log)
data Datum = Datum
{ Datum -> Maybe Span
spanIdentifierFrom :: Maybe Span
, Datum -> Rope
spanNameFrom :: Rope
, Datum -> Maybe Rope
serviceNameFrom :: Maybe Rope
, Datum -> TimeStamp
spanTimeFrom :: TimeStamp
, 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
(Int -> Datum -> ShowS)
-> (Datum -> String) -> ([Datum] -> ShowS) -> Show Datum
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 :: Maybe Span
-> Rope
-> Maybe Rope
-> TimeStamp
-> Maybe Trace
-> Maybe Span
-> Maybe Int64
-> Map JsonKey JsonValue
-> Datum
Datum
{ $sel:spanIdentifierFrom:Datum :: Maybe Span
spanIdentifierFrom = Maybe Span
forall a. Maybe a
Nothing
, $sel:spanNameFrom:Datum :: Rope
spanNameFrom = Rope
emptyRope
, $sel:serviceNameFrom:Datum :: Maybe Rope
serviceNameFrom = Maybe Rope
forall a. Maybe a
Nothing
, $sel:spanTimeFrom:Datum :: TimeStamp
spanTimeFrom = TimeStamp
0
, $sel:traceIdentifierFrom:Datum :: Maybe Trace
traceIdentifierFrom = Maybe Trace
forall a. Maybe a
Nothing
, $sel:parentIdentifierFrom:Datum :: Maybe Span
parentIdentifierFrom = Maybe Span
forall a. Maybe a
Nothing
, $sel:durationFrom:Datum :: Maybe Int64
durationFrom = Maybe Int64
forall a. Maybe a
Nothing
, $sel:attachedMetadataFrom:Datum :: Map JsonKey JsonValue
attachedMetadataFrom = Map JsonKey JsonValue
forall κ ν. Map κ ν
emptyMap
}
newtype Span = Span Rope
deriving (Int -> Span -> ShowS
[Span] -> ShowS
Span -> String
(Int -> Span -> ShowS)
-> (Span -> String) -> ([Span] -> ShowS) -> Show Span
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
(Span -> Span -> Bool) -> (Span -> Span -> Bool) -> Eq Span
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
(String -> Span) -> IsString 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
newtype Trace = Trace Rope
deriving (Int -> Trace -> ShowS
[Trace] -> ShowS
Trace -> String
(Int -> Trace -> ShowS)
-> (Trace -> String) -> ([Trace] -> ShowS) -> Show Trace
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
(Trace -> Trace -> Bool) -> (Trace -> Trace -> Bool) -> Eq Trace
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
(String -> Trace) -> IsString 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
}
data Forwarder = Forwarder
{ Forwarder -> [Datum] -> IO ()
telemetryHandlerFrom :: [Datum] -> IO ()
}
data Context τ = Context
{
Context τ -> MVar Rope
programNameFrom :: MVar Rope
, Context τ -> Int
terminalWidthFrom :: Int
, Context τ -> Bool
terminalColouredFrom :: Bool
, Context τ -> Version
versionFrom :: Version
,
Context τ -> Config
initialConfigFrom :: Config
, Context τ -> [Exporter]
initialExportersFrom :: [Exporter]
,
Context τ -> Parameters
commandLineFrom :: Parameters
,
Context τ -> MVar ExitCode
exitSemaphoreFrom :: MVar ExitCode
, Context τ -> MVar TimeStamp
startTimeFrom :: MVar TimeStamp
, Context τ -> MVar Verbosity
verbosityLevelFrom :: MVar Verbosity
,
Context τ -> TQueue (Maybe Rope)
outputChannelFrom :: TQueue (Maybe Rope)
, Context τ -> TQueue (Maybe Datum)
telemetryChannelFrom :: TQueue (Maybe Datum)
,
Context τ -> Maybe Forwarder
telemetryForwarderFrom :: Maybe Forwarder
, Context τ -> MVar Datum
currentDatumFrom :: MVar Datum
, Context τ -> MVar τ
applicationDataFrom :: MVar τ
}
instance Functor Context where
fmap :: (a -> b) -> Context a -> Context b
fmap a -> b
f = IO (Context b) -> Context b
forall a. IO a -> a
unsafePerformIO (IO (Context b) -> Context b)
-> (Context a -> IO (Context b)) -> Context a -> Context b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> Context a -> IO (Context b)
forall τ1 τ2. (τ1 -> τ2) -> Context τ1 -> IO (Context τ2)
fmapContext a -> b
f
fmapContext :: (τ1 -> τ2) -> Context τ1 -> IO (Context τ2)
fmapContext :: (τ1 -> τ2) -> Context τ1 -> IO (Context τ2)
fmapContext τ1 -> τ2
f Context τ1
context = do
τ1
state <- MVar τ1 -> IO τ1
forall a. MVar a -> IO a
readMVar (Context τ1 -> MVar τ1
forall τ. Context τ -> MVar τ
applicationDataFrom Context τ1
context)
let state' :: τ2
state' = τ1 -> τ2
f τ1
state
MVar τ2
u <- τ2 -> IO (MVar τ2)
forall a. a -> IO (MVar a)
newMVar τ2
state'
Context τ2 -> IO (Context τ2)
forall (m :: * -> *) a. Monad m => a -> m a
return (Context τ1
context{$sel:applicationDataFrom:Context :: MVar τ2
applicationDataFrom = MVar τ2
u})
data None = None
deriving (Int -> None -> ShowS
[None] -> ShowS
None -> String
(Int -> None -> ShowS)
-> (None -> String) -> ([None] -> ShowS) -> Show None
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [None] -> ShowS
$cshowList :: [None] -> ShowS
show :: None -> String
$cshow :: None -> String
showsPrec :: Int -> None -> ShowS
$cshowsPrec :: Int -> None -> ShowS
Show, None -> None -> Bool
(None -> None -> Bool) -> (None -> None -> Bool) -> Eq None
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: None -> None -> Bool
$c/= :: None -> None -> Bool
== :: None -> None -> Bool
$c== :: None -> None -> Bool
Eq)
isNone :: None -> Bool
isNone :: None -> Bool
isNone None
_ = Bool
True
data Verbosity
= Output
|
Verbose
| Debug
|
Internal
deriving (Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show)
newtype Program τ α = Program (ReaderT (Context τ) IO α)
deriving
( a -> Program τ b -> Program τ a
(a -> b) -> Program τ a -> Program τ b
(forall a b. (a -> b) -> Program τ a -> Program τ b)
-> (forall a b. a -> Program τ b -> Program τ a)
-> Functor (Program τ)
forall a b. a -> Program τ b -> Program τ a
forall a b. (a -> b) -> Program τ a -> Program τ b
forall τ a b. a -> Program τ b -> Program τ a
forall τ a b. (a -> b) -> Program τ a -> Program τ b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Program τ b -> Program τ a
$c<$ :: forall τ a b. a -> Program τ b -> Program τ a
fmap :: (a -> b) -> Program τ a -> Program τ b
$cfmap :: forall τ a b. (a -> b) -> Program τ a -> Program τ b
Functor
, Functor (Program τ)
a -> Program τ a
Functor (Program τ)
-> (forall a. a -> Program τ a)
-> (forall a b. Program τ (a -> b) -> Program τ a -> Program τ b)
-> (forall a b c.
(a -> b -> c) -> Program τ a -> Program τ b -> Program τ c)
-> (forall a b. Program τ a -> Program τ b -> Program τ b)
-> (forall a b. Program τ a -> Program τ b -> Program τ a)
-> Applicative (Program τ)
Program τ a -> Program τ b -> Program τ b
Program τ a -> Program τ b -> Program τ a
Program τ (a -> b) -> Program τ a -> Program τ b
(a -> b -> c) -> Program τ a -> Program τ b -> Program τ c
forall τ. Functor (Program τ)
forall a. a -> Program τ a
forall τ a. a -> Program τ a
forall a b. Program τ a -> Program τ b -> Program τ a
forall a b. Program τ a -> Program τ b -> Program τ b
forall a b. Program τ (a -> b) -> Program τ a -> Program τ b
forall τ a b. Program τ a -> Program τ b -> Program τ a
forall τ a b. Program τ a -> Program τ b -> Program τ b
forall τ a b. Program τ (a -> b) -> Program τ a -> Program τ b
forall a b c.
(a -> b -> c) -> Program τ a -> Program τ b -> Program τ c
forall τ a b c.
(a -> b -> c) -> Program τ a -> Program τ b -> Program τ c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Program τ a -> Program τ b -> Program τ a
$c<* :: forall τ a b. Program τ a -> Program τ b -> Program τ a
*> :: Program τ a -> Program τ b -> Program τ b
$c*> :: forall τ a b. Program τ a -> Program τ b -> Program τ b
liftA2 :: (a -> b -> c) -> Program τ a -> Program τ b -> Program τ c
$cliftA2 :: forall τ a b c.
(a -> b -> c) -> Program τ a -> Program τ b -> Program τ c
<*> :: Program τ (a -> b) -> Program τ a -> Program τ b
$c<*> :: forall τ a b. Program τ (a -> b) -> Program τ a -> Program τ b
pure :: a -> Program τ a
$cpure :: forall τ a. a -> Program τ a
$cp1Applicative :: forall τ. Functor (Program τ)
Applicative
, Applicative (Program τ)
a -> Program τ a
Applicative (Program τ)
-> (forall a b. Program τ a -> (a -> Program τ b) -> Program τ b)
-> (forall a b. Program τ a -> Program τ b -> Program τ b)
-> (forall a. a -> Program τ a)
-> Monad (Program τ)
Program τ a -> (a -> Program τ b) -> Program τ b
Program τ a -> Program τ b -> Program τ b
forall τ. Applicative (Program τ)
forall a. a -> Program τ a
forall τ a. a -> Program τ a
forall a b. Program τ a -> Program τ b -> Program τ b
forall a b. Program τ a -> (a -> Program τ b) -> Program τ b
forall τ a b. Program τ a -> Program τ b -> Program τ b
forall τ a b. Program τ a -> (a -> Program τ b) -> Program τ b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Program τ a
$creturn :: forall τ a. a -> Program τ a
>> :: Program τ a -> Program τ b -> Program τ b
$c>> :: forall τ a b. Program τ a -> Program τ b -> Program τ b
>>= :: Program τ a -> (a -> Program τ b) -> Program τ b
$c>>= :: forall τ a b. Program τ a -> (a -> Program τ b) -> Program τ b
$cp1Monad :: forall τ. Applicative (Program τ)
Monad
, Monad (Program τ)
Monad (Program τ)
-> (forall a. IO a -> Program τ a) -> MonadIO (Program τ)
IO a -> Program τ a
forall τ. Monad (Program τ)
forall a. IO a -> Program τ a
forall τ a. IO a -> Program τ a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> Program τ a
$cliftIO :: forall τ a. IO a -> Program τ a
$cp1MonadIO :: forall τ. Monad (Program τ)
MonadIO
, MonadReader (Context τ)
, Monad (Program τ)
Monad (Program τ)
-> (forall a. String -> Program τ a) -> MonadFail (Program τ)
String -> Program τ a
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 :: String -> Program τ a
$cfail :: forall τ a. String -> Program τ a
$cp1MonadFail :: forall τ. Monad (Program τ)
MonadFail
)
unProgram :: Program τ α -> ReaderT (Context τ) IO α
unProgram :: Program τ α -> ReaderT (Context τ) IO α
unProgram (Program ReaderT (Context τ) IO α
r) = ReaderT (Context τ) IO α
r
getContext :: Program τ (Context τ)
getContext :: Program τ (Context τ)
getContext = do
Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
Context τ -> Program τ (Context τ)
forall (m :: * -> *) a. Monad m => a -> m a
return Context τ
context
subProgram :: Context τ -> Program τ α -> IO α
subProgram :: Context τ -> Program τ α -> IO α
subProgram Context τ
context (Program ReaderT (Context τ) IO α
r) = do
ReaderT (Context τ) IO α -> Context τ -> IO α
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (Context τ) IO α
r Context τ
context
instance MonadThrow (Program τ) where
throwM :: e -> Program τ a
throwM = IO a -> Program τ a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Program τ a) -> (e -> IO a) -> e -> Program τ a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IO a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Safe.throw
deriving instance MonadCatch (Program τ)
deriving instance MonadMask (Program t)
configure :: Version -> τ -> Config -> IO (Context τ)
configure :: Version -> τ -> Config -> IO (Context τ)
configure Version
version τ
t Config
config = do
TimeStamp
start <- IO TimeStamp
getCurrentTimeNanoseconds
String
arg0 <- IO String
getProgName
MVar Rope
n <- Rope -> IO (MVar Rope)
forall a. a -> IO (MVar a)
newMVar (String -> Rope
forall α. Textual α => α -> Rope
intoRope String
arg0)
MVar ExitCode
q <- IO (MVar ExitCode)
forall a. IO (MVar a)
newEmptyMVar
MVar TimeStamp
i <- TimeStamp -> IO (MVar TimeStamp)
forall a. a -> IO (MVar a)
newMVar TimeStamp
start
Int
columns <- IO Int
getConsoleWidth
Bool
coloured <- IO Bool
getConsoleColoured
MVar Verbosity
level <- IO (MVar Verbosity)
forall a. IO (MVar a)
newEmptyMVar
TQueue (Maybe Rope)
out <- IO (TQueue (Maybe Rope))
forall a. IO (TQueue a)
newTQueueIO
TQueue (Maybe Datum)
tel <- IO (TQueue (Maybe Datum))
forall a. IO (TQueue a)
newTQueueIO
MVar Datum
v <- Datum -> IO (MVar Datum)
forall a. a -> IO (MVar a)
newMVar (Datum
emptyDatum)
MVar τ
u <- τ -> IO (MVar τ)
forall a. a -> IO (MVar a)
newMVar τ
t
Context τ -> IO (Context τ)
forall (m :: * -> *) a. Monad m => a -> m a
return
(Context τ -> IO (Context τ)) -> Context τ -> IO (Context τ)
forall a b. (a -> b) -> a -> b
$! Context :: forall τ.
MVar Rope
-> Int
-> Bool
-> Version
-> Config
-> [Exporter]
-> Parameters
-> MVar ExitCode
-> MVar TimeStamp
-> MVar Verbosity
-> TQueue (Maybe Rope)
-> TQueue (Maybe Datum)
-> Maybe Forwarder
-> MVar Datum
-> MVar τ
-> Context τ
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
, $sel:exitSemaphoreFrom:Context :: MVar ExitCode
exitSemaphoreFrom = MVar ExitCode
q
, $sel:startTimeFrom:Context :: MVar TimeStamp
startTimeFrom = MVar TimeStamp
i
, $sel:verbosityLevelFrom:Context :: MVar Verbosity
verbosityLevelFrom = MVar Verbosity
level
, $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 = Maybe Forwarder
forall a. Maybe a
Nothing
, $sel:currentDatumFrom:Context :: MVar Datum
currentDatumFrom = MVar Datum
v
, $sel:applicationDataFrom:Context :: MVar τ
applicationDataFrom = MVar τ
u
}
getConsoleWidth :: IO (Int)
getConsoleWidth :: IO Int
getConsoleWidth = do
Maybe (Window Int)
window <- IO (Maybe (Window Int))
forall n. Integral n => IO (Maybe (Window n))
Terminal.size
let columns :: Int
columns = case Maybe (Window Int)
window of
Just (Terminal.Window Int
_ Int
w) -> Int
w
Maybe (Window Int)
Nothing -> Int
80
Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
columns
getConsoleColoured :: IO Bool
getConsoleColoured :: IO Bool
getConsoleColoured = do
Bool
terminal <- Handle -> IO Bool
hIsTerminalDevice Handle
stdout
Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
terminal
handleCommandLine :: Context τ -> IO (Context τ)
handleCommandLine :: Context τ -> IO (Context τ)
handleCommandLine Context τ
context = do
[String]
argv <- IO [String]
getArgs
let config :: Config
config = Context τ -> Config
forall τ. Context τ -> Config
initialConfigFrom Context τ
context
version :: Version
version = Context τ -> 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
}
let context' :: Context τ
context' =
Context τ
context
{ $sel:commandLineFrom:Context :: Parameters
commandLineFrom = Parameters
params
}
Context τ -> IO (Context τ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Context τ
context'
Left InvalidCommandLine
e -> case InvalidCommandLine
e of
HelpRequest Maybe LongName
mode -> do
Doc Any -> IO ()
forall ann. Doc ann -> IO ()
render (Config -> Maybe LongName -> Doc Any
forall ann. Config -> Maybe LongName -> Doc ann
buildUsage Config
config Maybe LongName
mode)
ExitCode -> IO (Context τ)
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
InvalidCommandLine
VersionRequest -> do
Doc Any -> IO ()
forall ann. Doc ann -> IO ()
render (Version -> Doc Any
forall ann. Version -> Doc ann
buildVersion Version
version)
ExitCode -> IO (Context τ)
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
InvalidCommandLine
_ -> do
String -> IO ()
putStr String
"error: "
String -> IO ()
putStrLn (InvalidCommandLine -> String
forall e. Exception e => e -> String
displayException InvalidCommandLine
e)
Handle -> IO ()
hFlush Handle
stdout
ExitCode -> IO (Context τ)
forall a. ExitCode -> IO a
exitWith (Int -> ExitCode
ExitFailure Int
1)
where
render :: Doc ann -> IO ()
render Doc ann
message = do
Int
columns <- IO Int
getConsoleWidth
let options :: LayoutOptions
options = PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine (Int
columns Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Double
1.0)
Handle -> SimpleDocStream ann -> IO ()
forall ann. Handle -> SimpleDocStream ann -> IO ()
renderIO Handle
stdout (LayoutOptions -> Doc ann -> SimpleDocStream ann
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
options Doc ann
message)
Handle -> IO ()
hFlush Handle
stdout
lookupEnvironmentVariables :: Config -> Parameters -> IO (Map LongName ParameterValue)
lookupEnvironmentVariables :: Config -> Parameters -> IO (Map LongName ParameterValue)
lookupEnvironmentVariables Config
config Parameters
params = do
let mode :: Maybe LongName
mode = Parameters -> Maybe LongName
commandNameFrom Parameters
params
let valids :: Set LongName
valids = Maybe LongName -> Config -> Set LongName
extractValidEnvironments Maybe LongName
mode Config
config
Map LongName ParameterValue
result <- (LongName
-> Map LongName ParameterValue -> IO (Map LongName ParameterValue))
-> Map LongName ParameterValue
-> Set LongName
-> IO (Map LongName ParameterValue)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> b -> m b) -> b -> t a -> m b
foldrM LongName
-> Map LongName ParameterValue -> IO (Map LongName ParameterValue)
f Map LongName ParameterValue
forall κ ν. Map κ ν
emptyMap Set LongName
valids
Map LongName ParameterValue -> IO (Map LongName ParameterValue)
forall (m :: * -> *) a. Monad m => a -> m a
return Map LongName ParameterValue
result
where
f :: LongName -> (Map LongName ParameterValue) -> IO (Map LongName ParameterValue)
f :: LongName
-> Map LongName ParameterValue -> IO (Map LongName ParameterValue)
f name :: LongName
name@(LongName String
var) Map LongName ParameterValue
acc = do
Maybe String
result <- String -> IO (Maybe String)
lookupEnv String
var
Map LongName ParameterValue -> IO (Map LongName ParameterValue)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map LongName ParameterValue -> IO (Map LongName ParameterValue))
-> Map LongName ParameterValue -> IO (Map LongName ParameterValue)
forall a b. (a -> b) -> a -> b
$ case Maybe String
result of
Just String
value -> LongName
-> ParameterValue
-> Map LongName ParameterValue
-> Map LongName ParameterValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue LongName
name (String -> ParameterValue
Value String
value) Map LongName ParameterValue
acc
Maybe String
Nothing -> LongName
-> ParameterValue
-> Map LongName ParameterValue
-> Map LongName ParameterValue
forall κ ν. Key κ => κ -> ν -> Map κ ν -> Map κ ν
insertKeyValue LongName
name ParameterValue
Empty Map LongName ParameterValue
acc
handleVerbosityLevel :: Context τ -> IO (MVar Verbosity)
handleVerbosityLevel :: Context τ -> IO (MVar Verbosity)
handleVerbosityLevel Context τ
context = do
let params :: Parameters
params = Context τ -> Parameters
forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
level :: MVar Verbosity
level = Context τ -> MVar Verbosity
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
ExitCode -> IO (MVar Verbosity)
forall a. ExitCode -> IO a
exitWith ExitCode
exit
Right Verbosity
verbosity -> do
MVar Verbosity -> Verbosity -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Verbosity
level Verbosity
verbosity
MVar Verbosity -> IO (MVar 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 = LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
"debug" (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params)
verbose :: Maybe ParameterValue
verbose = LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
"verbose" (Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params)
in case Maybe ParameterValue
debug of
Just ParameterValue
value -> case ParameterValue
value of
ParameterValue
Empty -> Verbosity -> Either ExitCode Verbosity
forall a b. b -> Either a b
Right Verbosity
Debug
Value String
"internal" -> Verbosity -> Either ExitCode Verbosity
forall a b. b -> Either a b
Right Verbosity
Internal
Value String
_ -> ExitCode -> Either ExitCode Verbosity
forall a b. a -> Either a b
Left (Int -> ExitCode
ExitFailure Int
2)
Maybe ParameterValue
Nothing -> case Maybe ParameterValue
verbose of
Just ParameterValue
value -> case ParameterValue
value of
ParameterValue
Empty -> Verbosity -> Either ExitCode Verbosity
forall a b. b -> Either a b
Right Verbosity
Verbose
Value String
_ -> ExitCode -> Either ExitCode Verbosity
forall a b. a -> Either a b
Left (Int -> ExitCode
ExitFailure Int
2)
Maybe ParameterValue
Nothing -> Verbosity -> Either ExitCode Verbosity
forall a b. b -> Either a b
Right Verbosity
Output
handleTelemetryChoice :: Context τ -> IO (Context τ)
handleTelemetryChoice :: Context τ -> IO (Context τ)
handleTelemetryChoice Context τ
context = do
let params :: Parameters
params = Context τ -> Parameters
forall τ. Context τ -> Parameters
commandLineFrom Context τ
context
options :: Map LongName ParameterValue
options = Parameters -> Map LongName ParameterValue
parameterValuesFrom Parameters
params
exporters :: [Exporter]
exporters = Context τ -> [Exporter]
forall τ. Context τ -> [Exporter]
initialExportersFrom Context τ
context
case LongName -> Map LongName ParameterValue -> Maybe ParameterValue
forall κ ν. Key κ => κ -> Map κ ν -> Maybe ν
lookupKeyValue LongName
"telemetry" Map LongName ParameterValue
options of
Maybe ParameterValue
Nothing -> Context τ -> IO (Context τ)
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)
IO (Context τ)
forall a. HasCallStack => a
undefined
Just (Value String
value) -> case Rope -> [Exporter] -> Maybe Exporter
lookupExporter (String -> Rope
forall α. Textual α => α -> Rope
intoRope String
value) [Exporter]
exporters of
Maybe Exporter
Nothing -> do
String -> IO ()
putStrLn (String
"error: supplied value \"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
value String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\" not a valid telemetry exporter.")
ExitCode -> IO ()
Posix.exitImmediately (Int -> ExitCode
ExitFailure Int
99)
IO (Context τ)
forall a. HasCallStack => a
undefined
Just Exporter
exporter -> do
let setupAction :: Context τ -> IO Forwarder
setupAction = Exporter -> forall τ. Context τ -> IO Forwarder
setupActionFrom Exporter
exporter
Forwarder
forwarder <- Context τ -> IO Forwarder
forall τ. Context τ -> IO Forwarder
setupAction Context τ
context
Context τ -> IO (Context τ)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Context τ
context
{ $sel:telemetryForwarderFrom:Context :: Maybe Forwarder
telemetryForwarderFrom = Forwarder -> Maybe Forwarder
forall a. a -> Maybe a
Just Forwarder
forwarder
}
where
lookupExporter :: Rope -> [Exporter] -> Maybe Exporter
lookupExporter :: Rope -> [Exporter] -> Maybe Exporter
lookupExporter Rope
_ [] = Maybe Exporter
forall a. Maybe a
Nothing
lookupExporter Rope
target (Exporter
exporter : [Exporter]
exporters) =
case Rope
target Rope -> Rope -> Bool
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 -> Exporter -> Maybe Exporter
forall a. a -> Maybe a
Just Exporter
exporter
data Boom = Boom
deriving (Int -> Boom -> ShowS
[Boom] -> ShowS
Boom -> String
(Int -> Boom -> ShowS)
-> (Boom -> String) -> ([Boom] -> ShowS) -> Show Boom
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Boom] -> ShowS
$cshowList :: [Boom] -> ShowS
show :: Boom -> String
$cshow :: Boom -> String
showsPrec :: Int -> Boom -> ShowS
$cshowsPrec :: Int -> Boom -> ShowS
Show)
instance Exception Boom