{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK prune #-}

-- |
-- Embelish a Haskell command-line program with useful behaviours.
--
-- /Runtime/
--
-- Sets number of capabilities (heavy-weight operating system threads used by
-- the GHC runtime to run Haskell green threads) to the number of CPU cores
-- available (for some reason the default is 1 capability only, which is a bit
-- silly on a multicore system).
--
-- Install signal handlers to properly terminate the program performing
-- cleanup as necessary.
--
-- Encoding is set to UTF-8, working around confusing bugs that sometimes
-- occur when applications are running in Docker containers.
--
-- /Logging and output/
--
-- The 'Program' monad provides functions for both normal output and debug
-- logging. A common annoyance when building command line tools and daemons is
-- getting program output to @stdout@ and debug messages interleaved, made
-- even worse when error messages written to @stderr@ land in the same
-- console. To avoid this, all output is sent through a single channel.
-- This includes both normal output and log messages.
--
-- /Exceptions/
--
-- Ideally your code should handle (and not leak) exceptions, as is good
-- practice anywhere in the Haskell ecosystem. As a measure of last resort
-- however, if an exception is thrown (and not caught) by your program it will
-- be caught at the outer 'execute' entrypoint, logged for debugging, and then
-- your program will exit.
--
-- /Customizing the execution context/
--
-- The 'execute' function will run your 'Program' in a basic 'Context'
-- initialized with appropriate defaults. Most settings can be changed at
-- runtime, but to specify the allowed command-line options and expected
-- arguments you can initialize your program using 'configure' and then run
-- with 'executeWith'.
module Core.Program.Execute
  ( Program (),

    -- * Running programs
    configure,
    execute,
    executeWith,

    -- * Exiting a program
    terminate,

    -- * Accessing program context
    getCommandLine,
    lookupOptionFlag,
    lookupOptionValue,
    lookupArgument,
    getProgramName,
    setProgramName,
    getVerbosityLevel,
    setVerbosityLevel,
    getConsoleWidth,
    getApplicationState,
    setApplicationState,

    -- * Useful actions
    outputEntire,
    inputEntire,

    -- * Concurrency
    Thread,
    fork,
    sleep,

    -- * Internals
    Context,
    None (..),
    isNone,
    unProgram,
    unThread,
    invalid,

    retrieve,
    update,
    output,
    input,
  )
where

import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
  ( Async,
    AsyncCancelled,
    ExceptionInLinkedThread (..),
    async,
    cancel,
    link,
    race_,
  )
import Control.Concurrent.MVar (modifyMVar_, 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, 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)

-- execute actual "main"
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

--
-- If an exception escapes, we'll catch it here. The displayException
-- value for some exceptions is really quit unhelpful, so we pattern
-- match the wrapping gumpf away for cases as we encounter them. The
-- final entry is the catch-all; the first is what we get from the
-- terminate action.
--
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)

--
-- If an exception occurs in one of the output handlers, its failure causes
-- a subsequent race condition when the program tries to clean up and drain
-- the queues. So we use `exitImmediately` (which we normally avoid, as it
-- unhelpfully destroys the parent process if you're in ghci) because we
-- really need the process to go down and we're in an inconsistent state
-- where debug or console output is no longer possible.
--
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)
      )
  ]

-- |
-- Embelish a program with useful behaviours. See module header
-- "Core.Program.Execute" for a detailed description. Internally this function
-- calls 'configure' with an appropriate default when initializing.
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
simple [])
  Context None -> Program None α -> IO ()
forall τ α. Context τ -> Program τ α -> IO ()
executeWith Context None
context Program None α
program

-- |
-- Embelish a program with useful behaviours, supplying a configuration
-- for command-line options & argument parsing and an initial value for
-- the top-level application state, if appropriate.
executeWith :: Context τ -> Program τ α -> IO ()
executeWith :: Context τ -> Program τ α -> IO ()
executeWith Context τ
context Program τ α
program = do
  -- command line +RTS -Nn -RTS value
  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)

  -- force UTF-8 working around bad VMs
  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

  -- set up standard output
  Async ()
o <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
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)

  -- set up debug logger
  Async ()
l <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
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)

  -- set up signal handlers
  Async ()
_ <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
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

  -- run actual program, ensuring to trap uncaught exceptions
  Async ()
m <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
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 ()
cancel Async ()
m

  -- drain message queues. Allow 0.1 seconds, then timeout, in case
  -- something has gone wrong and queues don't empty.
  IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
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 -- instead of yield
  Handle -> IO ()
hFlush Handle
stdout

  Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
l
  Async () -> IO ()
forall a. Async a -> IO ()
cancel Async ()
o

  -- exiting this way avoids "Exception: ExitSuccess" noise in GHCi
  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
    -- TODO do sactually do something with log messages
    -- Message now severity text potentialValue <- ...
    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 ()

-- |
-- Safely exit the program with the supplied exit code. Current output and
-- debug queues will be flushed, and then the process will terminate.

-- putting to the quit MVar initiates the cleanup and exit sequence,
-- but throwing the exception also aborts execution and starts unwinding
-- back up the stack.
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

-- undocumented
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

-- |
-- Change the verbosity level of the program's logging output. This changes
-- whether 'event' and the 'debug' family of functions emit to the logging
-- stream; they do /not/ affect 'write'ing to the terminal on the standard
-- output stream.
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)

-- |
-- Override the program name used for logging, etc. At least, that was the
-- idea. Nothing makes use of this at the moment. @:/@
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)

-- |
-- Get the program name as invoked from the command-line (or as overridden by
-- 'setProgramName').
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

-- |
-- Retreive the current terminal's width, in characters.
--
-- If you are outputting an object with a 'Core.Text.Untilities.Render'
-- instance then you may not need this; you can instead use 'wrteR' which is
-- aware of the width of your terminal and will reflow (in as much as the
-- underlying type's @Render@ instance lets it).
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

-- |
-- Get the user supplied application state as originally supplied to
-- 'configure' and modified subsequntly by replacement with
-- 'setApplicationState'.
--
-- @
--     state <- getApplicationState
-- @
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

-- |
-- Update the user supplied top-level application state.
--
-- @
--     let state' = state { answer = 42 }
--     setApplicationState state'
-- @
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

-- |
-- Write the supplied @Bytes@ to the given @Handle@. Note that in contrast to
-- 'write' we don't output a trailing newline.
--
-- @
--     'output' h b
-- @
--
-- Do /not/ use this to output to @stdout@ as that would bypass the mechanism
-- used by the 'write'*, 'event', and 'debug'* functions to sequence output
-- correctly. If you wish to write to the terminal use:
--
-- @
--     'write' ('intoRope' b)
-- @
--
-- (which is not /unsafe/, but will lead to unexpected results if the binary
-- blob you pass in is other than UTF-8 text).
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

-- |
-- Read the (entire) contents of the specified @Handle@.
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

-- |
-- A thread for concurrent computation. Haskell uses green threads: small
-- lines of work that are scheduled down onto actual execution contexts, set
-- by default by this library to be one per core. They are incredibly
-- lightweight, and you are encouraged to use them freely. Haskell provides a
-- rich ecosystem of tools to do work concurrently and to communicate safely
-- between threads
--
-- (this wraps __async__'s 'Async')
newtype Thread α = Thread (Async α)

unThread :: Thread α -> Async α
unThread :: Thread α -> Async α
unThread (Thread Async α
a) = Async α
a

-- |
-- Fork a thread. The child thread will run in the same @Context@ as the
-- calling @Program@, including sharing the user-defined application state
-- type.
--
-- (this wraps __async__'s 'async' which in turn wraps __base__'s 'Control.Concurrent.forkIO')
fork :: Program τ α -> Program τ (Thread α)
fork :: Program τ α -> Program τ (Thread α)
fork Program τ α
program = do
  Context τ
context <- Program τ (Context τ)
forall r (m :: * -> *). MonadReader r m => m r
ask
  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
    Async α
a <- IO α -> IO (Async α)
forall a. IO a -> IO (Async a)
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 ()
link Async α
a
    Thread α -> IO (Thread α)
forall (m :: * -> *) a. Monad m => a -> m a
return (Async α -> Thread α
forall α. Async α -> Thread α
Thread Async α
a)

-- |
-- Pause the current thread for the given number of seconds. For
-- example, to delay a second and a half, do:
--
-- @
--     'sleep' 1.5
-- @
--
-- (this wraps __base__'s 'threadDelay')

--
-- FIXME is this the right type, given we want to avoid type default warnings?
--
sleep :: Rational -> Program τ ()
sleep :: Rational -> Program τ ()
sleep 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

-- |
-- Retrieve the values of parameters parsed from options and arguments
-- supplied by the user on the command-line.
--
-- The command-line parameters are returned in a 'Map', mapping from from the
-- option or argument name to the supplied value. You can query this map
-- directly:
--
-- @
-- program = do
--     params <- 'getCommandLine'
--     let result = 'lookupKeyValue' \"silence\" (paramterValuesFrom params)
--     case result of
--         'Nothing' -> 'return' ()
--         'Just' quiet = case quiet of
--             'Value' _ -> 'throw' NotQuiteRight               -- complain that flag doesn't take value
--             'Empty'   -> 'write' \"You should be quiet now\"   -- much better
--     ...
-- @
--
-- which is pattern matching to answer "was this option specified by the
-- user?" or "what was the value of this [mandatory] argument?", and then "if
-- so, did the parameter have a value?"
--
-- This is available should you need to differentiate between a @Value@ and an
-- @Empty@ 'ParameterValue', but for many cases as a convenience you can use
-- the 'lookupOptionFlag', 'lookupOptionValue', and 'lookupArgument' functions
-- below (which are just wrappers around a code block like the example shown
-- here).
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)

-- |
-- Arguments are mandatory, so by the time your program is running a value
-- has already been identified. This returns the value for that parameter.

-- this is Maybe because you can inadvertently ask for an unconfigured name
-- this could be fixed with a much stronger Config type, potentially.
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

-- |
-- Look to see if the user supplied a valued option and if so, what its value
-- was.

-- Should this be more severe if it encounters Empty?
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

-- |
-- Returns @Just True@ if the option is present, and @Nothing@ if it is not.

-- The type is boolean to support a possible future extension of negated
-- arguments.
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 -- nom, nom

-- |
-- Illegal internal state resulting from what should be unreachable code
-- or otherwise a programmer error.
invalid :: Program τ α
invalid :: Program τ α
invalid = String -> Program τ α
forall a. HasCallStack => String -> a
error String
"Invalid State"