{-# 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,
lookupOptionFlag,
lookupOptionValue,
lookupArgument,
lookupEnvironmentValue,
getProgramName,
setProgramName,
getVerbosityLevel,
setVerbosityLevel,
getConsoleWidth,
getApplicationState,
setApplicationState,
outputEntire,
inputEntire,
Thread,
forkThread,
fork,
sleepThread,
sleep,
resetTimer,
waitThread,
waitThread_,
trap_,
Context,
None (..),
isNone,
unProgram,
unThread,
invalid,
retrieve,
update,
output,
input,
) where
import Chrono.TimeStamp (getCurrentTimeNanoseconds)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (
Async,
ExceptionInLinkedThread (..),
)
import qualified Control.Concurrent.Async as Async (
async,
cancel,
link,
race,
race_,
wait,
)
import Control.Concurrent.MVar (modifyMVar_, newMVar, putMVar, readMVar)
import Control.Concurrent.STM (atomically, check)
import Control.Concurrent.STM.TQueue (TQueue, isEmptyTQueue, readTQueue)
import qualified Control.Exception as Base (throwIO)
import qualified Control.Exception.Safe as Safe (catch, catchesAsync, throw)
import Control.Monad (forever, 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 GHC.Conc (getNumProcessors, numCapabilities, setNumCapabilities)
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import System.Exit (ExitCode (..))
import qualified System.Posix.Process as Posix (exitImmediately)
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 ()
executeWith Context None
context Program None α
program
executeWith :: Context τ -> Program τ α -> IO ()
executeWith :: Context τ -> Program τ α -> IO ()
executeWith Context τ
context 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
let quit :: MVar ExitCode
quit = Context τ -> MVar ExitCode
forall τ. Context τ -> MVar ExitCode
exitSemaphoreFrom Context τ
context
level :: MVar Verbosity
level = Context τ -> MVar Verbosity
forall τ. Context τ -> MVar Verbosity
verbosityLevelFrom Context τ
context
out :: TQueue Rope
out = Context τ -> TQueue Rope
forall τ. Context τ -> TQueue Rope
outputChannelFrom Context τ
context
log :: TQueue ()
log = Context τ -> TQueue ()
forall τ. Context τ -> TQueue ()
loggerChannelFrom 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 Rope -> IO ()
processStandardOutput TQueue 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
TQueue () -> IO ()
processDebugMessages TQueue ()
log
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
Bool
done2 <- TQueue () -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue ()
log
Bool -> STM ()
check Bool
done2
Bool
done1 <- TQueue Rope -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue Rope
out
Bool -> STM ()
check Bool
done1
)
( do
Int -> IO ()
threadDelay Int
100000
String -> IO ()
putStrLn String
"error: Timeout"
)
Int -> IO ()
threadDelay Int
100
Handle -> IO ()
hFlush Handle
stdout
Async () -> IO ()
forall a. Async a -> IO ()
Async.cancel Async ()
l
Async () -> IO ()
forall a. Async a -> IO ()
Async.cancel Async ()
o
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 Rope -> IO ()
processStandardOutput :: TQueue Rope -> IO ()
processStandardOutput TQueue Rope
out =
IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
( do
IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Rope
text <- STM Rope -> IO Rope
forall a. STM a -> IO a
atomically (TQueue Rope -> STM Rope
forall a. TQueue a -> STM a
readTQueue TQueue Rope
out)
Handle -> Rope -> IO ()
hWrite Handle
stdout Rope
text
Handle -> ByteString -> IO ()
B.hPut Handle
stdout (Char -> ByteString
C.singleton Char
'\n')
)
(String -> SomeException -> IO ()
collapseHandler String
"output processing collapsed")
processDebugMessages :: TQueue () -> IO ()
processDebugMessages :: TQueue () -> IO ()
processDebugMessages TQueue ()
log =
IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
Safe.catch
( do
IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
()
_ <- STM () -> IO ()
forall a. STM a -> IO a
atomically (TQueue () -> STM ()
forall a. TQueue a -> STM a
readTQueue TQueue ()
log)
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
)
(String -> SomeException -> IO ()
collapseHandler String
"debug processing collapsed")
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)
{-# DEPRECATED retrieve "Use getApplicationState instead" #-}
retrieve :: Program τ τ
retrieve :: Program τ τ
retrieve = Program τ τ
forall τ. Program τ τ
getApplicationState
{-# DEPRECATED update "Use setApplicationState instead" #-}
update :: τ -> Program τ ()
update :: τ -> Program τ ()
update = τ -> Program τ ()
forall τ. τ -> Program τ ()
setApplicationState
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)
{-# DEPRECATED output "Use outputEntire instead" #-}
output :: Handle -> Bytes -> Program τ ()
output :: Handle -> Bytes -> Program τ ()
output = Handle -> Bytes -> Program τ ()
forall τ. Handle -> Bytes -> Program τ ()
outputEntire
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)
{-# DEPRECATED input "Use inputEntire instead" #-}
input :: Handle -> Program τ Bytes
input :: Handle -> Program τ Bytes
input = Handle -> Program τ Bytes
forall τ. Handle -> Program τ Bytes
inputEntire
newtype Thread α = Thread (Async α)
unThread :: Thread α -> Async α
unThread :: Thread α -> Async α
unThread (Thread Async α
a) = Async α
a
forkThread :: Program τ α -> Program τ (Thread α)
forkThread :: Program τ α -> Program τ (Thread α)
forkThread Program τ α
program = do
Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
let i :: MVar TimeStamp
i = Context τ -> MVar TimeStamp
forall τ. Context τ -> MVar TimeStamp
startTimeFrom Context τ
context
IO (Thread α) -> Program τ (Thread α)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Thread α) -> Program τ (Thread α))
-> IO (Thread α) -> Program τ (Thread α)
forall a b. (a -> b) -> a -> b
$ do
TimeStamp
start <- MVar TimeStamp -> IO TimeStamp
forall a. MVar a -> IO a
readMVar MVar TimeStamp
i
MVar TimeStamp
i' <- TimeStamp -> IO (MVar TimeStamp)
forall a. a -> IO (MVar a)
newMVar TimeStamp
start
let context' :: Context τ
context' = Context τ
context{startTimeFrom :: MVar TimeStamp
startTimeFrom = MVar TimeStamp
i'}
Async α
a <- 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
Context τ -> Program τ α -> IO α
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context' Program τ α
program
Async α -> IO ()
forall a. Async a -> IO ()
Async.link Async α
a
Thread α -> IO (Thread α)
forall (m :: * -> *) a. Monad m => a -> m a
return (Async α -> Thread α
forall α. Async α -> Thread α
Thread Async α
a)
fork :: Program τ α -> Program τ (Thread α)
fork :: Program τ α -> Program τ (Thread α)
fork = Program τ α -> Program τ (Thread α)
forall τ α. Program τ α -> Program τ (Thread α)
forkThread
{-# DEPRECATED fork "Use forkThread instead" #-}
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
sleep :: Rational -> Program τ ()
sleep :: Rational -> Program τ ()
sleep = Rational -> Program τ ()
forall τ. Rational -> Program τ ()
sleepThread
{-# DEPRECATED sleep "Use sleepThread instead" #-}
waitThread :: Thread α -> Program τ α
waitThread :: Thread α -> Program τ α
waitThread (Thread Async α
a) = IO α -> Program τ α
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO α -> Program τ α) -> IO α -> Program τ α
forall a b. (a -> b) -> a -> b
$ Async α -> IO α
forall a. Async a -> IO a
Async.wait Async α
a
waitThread_ :: Thread α -> Program τ ()
waitThread_ :: Thread α -> Program τ ()
waitThread_ = Program τ α -> Program τ ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Program τ α -> Program τ ())
-> (Thread α -> Program τ α) -> Thread α -> Program τ ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Thread α -> Program τ α
forall α τ. Thread α -> Program τ α
waitThread
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)
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
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
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
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
invalid :: Program τ α
invalid :: Program τ α
invalid = String -> Program τ α
forall a. HasCallStack => String -> a
error String
"Invalid State"