{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Program.Execute (
Program (),
configure,
execute,
executeWith,
terminate,
getCommandLine,
queryCommandName,
queryOptionFlag,
queryOptionValue,
queryArgument,
queryRemaining,
queryEnvironmentValue,
getProgramName,
setProgramName,
getVerbosityLevel,
setVerbosityLevel,
getConsoleWidth,
getApplicationState,
setApplicationState,
outputEntire,
inputEntire,
execProcess,
sleepThread,
resetTimer,
trap_,
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)
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)
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)
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_ :: 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
)
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
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
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)
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
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
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
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
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
α
_ <- 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)
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
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
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
case Maybe a
possibleItem of
Maybe a
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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
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
Maybe [a]
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
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
case Maybe a
possibleItem of
Maybe a
Nothing -> Maybe [a] -> STM (Maybe [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [a]
forall a. Maybe a
Nothing
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
case Maybe (Maybe a)
pending of
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)
Just Maybe a
possibleItem -> do
case Maybe a
possibleItem of
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)
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
isDebug 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 -> Severity -> Rope -> Rope
formatLogMessage
TimeStamp
start
TimeStamp
now
Severity
SeverityInternal
(Rope
"telemetry: 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 -> Severity -> Rope -> Rope
formatLogMessage
TimeStamp
start
TimeStamp
now
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)
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
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
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)
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)
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
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
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
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)
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)
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
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)
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)
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
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)
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" #-}
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)
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" #-}
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
{-# DEPRECATED lookupOptionFlag "Use queryOptionFlag instead" #-}
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" #-}
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"
invalid :: Program τ α
invalid :: Program τ α
invalid = String -> Program τ α
forall a. HasCallStack => String -> a
error String
"Invalid State"