{-# 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_,
Context,
None (..),
isNone,
unProgram,
unThread,
invalid,
retrieve,
update,
output,
input,
) where
import Chrono.TimeStamp (getCurrentTimeNanoseconds)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (
Async,
AsyncCancelled,
ExceptionInLinkedThread (..),
)
import qualified Control.Concurrent.Async as Async (
async,
cancel,
link,
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 (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)
executeAction :: Context τ -> Program τ α -> IO ()
executeAction :: Context τ -> Program τ α -> IO ()
executeAction Context τ
context Program τ α
program =
let quit :: MVar ExitCode
quit = Context τ -> MVar ExitCode
forall τ. Context τ -> MVar ExitCode
exitSemaphoreFrom Context τ
context
in do
α
_ <- Context τ -> Program τ α -> IO α
forall τ α. Context τ -> Program τ α -> IO α
subProgram Context τ
context Program τ α
program
MVar ExitCode -> ExitCode -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ExitCode
quit ExitCode
ExitSuccess
escapeHandlers :: Context c -> [Handler IO ()]
escapeHandlers :: Context c -> [Handler IO ()]
escapeHandlers Context c
context =
[ (ExitCode -> IO ()) -> Handler IO ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(ExitCode
exit :: ExitCode) -> ExitCode -> IO ()
done ExitCode
exit)
, (AsyncCancelled -> IO ()) -> Handler IO ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(AsyncCancelled
_ :: AsyncCancelled) -> IO ()
pass)
, (ExceptionInLinkedThread -> IO ()) -> Handler IO ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(ExceptionInLinkedThread Async a
_ SomeException
e) -> SomeException -> IO ()
forall e. Exception e => e -> IO ()
bail SomeException
e)
, (SomeException -> IO ()) -> Handler IO ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\(SomeException
e :: SomeException) -> SomeException -> IO ()
forall e. Exception e => e -> IO ()
bail SomeException
e)
]
where
quit :: MVar ExitCode
quit = Context c -> MVar ExitCode
forall τ. Context τ -> MVar ExitCode
exitSemaphoreFrom Context c
context
pass :: IO ()
pass :: IO ()
pass = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
done :: ExitCode -> IO ()
done :: ExitCode -> IO ()
done ExitCode
exit = do
MVar ExitCode -> ExitCode -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ExitCode
quit ExitCode
exit
bail :: Exception e => e -> IO ()
bail :: e -> IO ()
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 τ ()
event Rope
text
MVar ExitCode -> ExitCode -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ExitCode
quit (Int -> ExitCode
ExitFailure Int
127)
collapseHandlers :: [Handler IO ()]
collapseHandlers :: [Handler IO ()]
collapseHandlers =
[ (AsyncCancelled -> IO ()) -> Handler IO ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler
( \(AsyncCancelled
e :: AsyncCancelled) -> do
AsyncCancelled -> IO ()
forall e a. Exception e => e -> IO a
Base.throwIO AsyncCancelled
e
)
, (SomeException -> IO ()) -> Handler IO ()
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler
( \(SomeException
e :: SomeException) -> do
String -> IO ()
putStrLn String
"error: Output handler collapsed"
SomeException -> IO ()
forall a. Show a => a -> IO ()
print SomeException
e
ExitCode -> IO ()
Posix.exitImmediately (Int -> ExitCode
ExitFailure Int
99)
)
]
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 Message
log = Context τ -> TQueue Message
forall τ. Context τ -> TQueue Message
loggerChannelFrom Context τ
context
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
IO () -> [Handler IO ()] -> IO ()
forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
Safe.catchesAsync
(TQueue Rope -> IO ()
processStandardOutput TQueue Rope
out)
([Handler IO ()]
collapseHandlers)
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
IO () -> [Handler IO ()] -> IO ()
forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
Safe.catchesAsync
(TQueue Message -> IO ()
processDebugMessages TQueue Message
log)
([Handler IO ()]
collapseHandlers)
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 ()
m <- 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
IO () -> [Handler IO ()] -> IO ()
forall (m :: * -> *) a.
(MonadCatch m, MonadThrow m) =>
m a -> [Handler m a] -> m a
Safe.catchesAsync
(Context τ -> Program τ α -> IO ()
forall τ α. Context τ -> Program τ α -> IO ()
executeAction Context τ
context Program τ α
program)
(Context τ -> [Handler IO ()]
forall c. Context c -> [Handler IO ()]
escapeHandlers Context τ
context)
ExitCode
code <- MVar ExitCode -> IO ExitCode
forall a. MVar a -> IO a
readMVar MVar ExitCode
quit
Async () -> IO ()
forall a. Async a -> IO ()
Async.cancel Async ()
m
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 Message -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue Message
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 = 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')
processDebugMessages :: TQueue Message -> IO ()
processDebugMessages :: TQueue Message -> IO ()
processDebugMessages TQueue Message
log = 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
Message
_ <- STM Message -> IO Message
forall a. STM a -> IO a
atomically (TQueue Message -> STM Message
forall a. TQueue a -> STM a
readTQueue TQueue Message
log)
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
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"