{-# 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, when 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,
    lookupEnvironmentValue,
    getProgramName,
    setProgramName,
    getVerbosityLevel,
    setVerbosityLevel,
    getConsoleWidth,
    getApplicationState,
    setApplicationState,

    -- * Useful actions
    outputEntire,
    inputEntire,
    execProcess,

    -- * Concurrency
    Thread,
    forkThread,
    sleepThread,
    resetTimer,
    waitThread,
    waitThread_,
    trap_,

    -- * Internals
    Context,
    None (..),
    isNone,
    unProgram,
    unThread,
    invalid,
    loopForever,
) 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,
 )
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 GHC.Conc (getNumProcessors, numCapabilities, setNumCapabilities)
import GHC.IO.Encoding (setLocaleEncoding, utf8)
import System.Exit (ExitCode (..))
import qualified System.Posix.Process as Posix (exitImmediately)
import System.Process.Typed (closed, proc, readProcess, setStdin)
import Prelude hiding (log)

--
-- 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.
--
-- Note this is called via Safe.catchesAsync because we want to be able to
-- strip out ExceptionInLinkedThread (which is asynchronous and otherwise
-- reasonably special) from the final output message.
--
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)

--
-- 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.
--
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 any exceptions coming out of the given Program action, and discard them.
The one and only time you want this is inside an endless loop:

@
    forever $ do
        trap_
            ( bracket
                obtainResource
                releaseResource
                useResource
            )
@

This function really will swollow expcetions, which means that you'd better
have handled any synchronous checked errors already with a 'catch' and/or have
released resources with 'bracket' or 'finally' as shown above.

An info level message will be sent to the log channel indicating that an
uncaught exception was trapped along with a debug level message showing the
exception text, if any.
-}
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
        )

{- |
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
simpleConfig [])
    Context None -> Program None α -> IO ()
forall τ α. Context τ -> Program τ α -> IO ()
executeActual 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 τ -> Program τ α -> IO ()
forall τ α. Context τ -> Program τ α -> IO ()
executeActual

executeActual :: Context τ -> Program τ α -> IO ()
executeActual :: Context τ -> Program τ α -> IO ()
executeActual Context τ
context0 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

    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 :: Forwarder
forwarder = Context τ -> Forwarder
forall τ. Context τ -> Forwarder
telemetryForwarderFrom Context τ
context

    -- set up signal handlers
    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

    -- set up standard output
    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

    -- set up debug logger
    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
            Forwarder -> TQueue (Maybe Rope) -> TQueue (Maybe Datum) -> IO ()
processTelemetryMessages Forwarder
forwarder TQueue (Maybe Rope)
out TQueue (Maybe Datum)
tel

    -- run actual program, ensuring to grab any otherwise uncaught exceptions.
    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
                            -- execute actual "main"
                            α
_ <- 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)

    -- instruct handlers to finish, and wait for the message queues to drain.
    -- 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 ()
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
                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 ()
l
            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

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

--
-- I'm embarrased how long it took to get here. At one point we were firing
-- off an Async.race of two threads for every item coming down the queue. And
-- you know what? That didn't work either. After all of that, realized that
-- the technique used   by **io-streams** to just pass along a stream of Maybes,
-- with Nothing signalling end-of-stream is exactly good enough for our needs.
--
processTelemetryMessages :: Forwarder -> TQueue (Maybe Rope) -> TQueue (Maybe Datum) -> IO ()
processTelemetryMessages :: Forwarder -> TQueue (Maybe Rope) -> TQueue (Maybe Datum) -> IO ()
processTelemetryMessages Forwarder
processor 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 ())
-> TQueue (Maybe Rope) -> TQueue (Maybe Datum) -> IO ()
forall a.
([a] -> IO ()) -> TQueue (Maybe Rope) -> TQueue (Maybe a) -> IO ()
loopForever [Datum] -> IO ()
action 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 ()) -> TQueue (Maybe Rope) -> TQueue (Maybe a) -> IO ()
loopForever :: ([a] -> IO ()) -> TQueue (Maybe Rope) -> TQueue (Maybe a) -> IO ()
loopForever [a] -> IO ()
action TQueue (Maybe Rope)
out TQueue (Maybe a)
queue = do
    TimeStamp
start <- IO TimeStamp
getCurrentTimeNanoseconds
    -- block waiting for an item
    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
        -- we're done!
        Maybe [a]
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        -- handle it and loop
        Just [a]
items -> do
            IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
                ([a] -> IO ()
action ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
items))
                ( \(SomeException
e :: SomeException) -> do
                    TimeStamp
now <- IO TimeStamp
getCurrentTimeNanoseconds
                    let result :: Rope
result =
                            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 (SomeException -> String
forall a. Show a => a -> String
show SomeException
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
result)
                )
            ([a] -> IO ()) -> TQueue (Maybe Rope) -> TQueue (Maybe a) -> IO ()
forall a.
([a] -> IO ()) -> TQueue (Maybe Rope) -> TQueue (Maybe a) -> IO ()
loopForever [a] -> IO ()
action 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 -- blocks
                case Maybe a
possibleItem of
                    -- we're finished! time to shutdown
                    Maybe a
Nothing -> Maybe [a] -> STM (Maybe [a])
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe [a]
forall a. Maybe a
Nothing
                    -- otherwise start accumulating
                    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 -- doesn't block
                case Maybe (Maybe a)
pending of
                    -- nothing left in the queue
                    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)
                    -- otherwise we get one of our Maybe Datum, and consider it
                    Just Maybe a
possibleItem -> do
                        case Maybe a
possibleItem of
                            -- oh, time to stop! We put the Nothing back into
                            -- the queue, then let the accumulated items get
                            -- processed. The next loop will read the
                            -- Nothing and shutdown.
                            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)
                            -- continue accumulating!
                            Just a
item -> do
                                [a] -> STM (Maybe [a])
cycleOverQueue (a
item a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
items)

{- |
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)

{- |
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)

{- |
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)

{- |
Execute an external child process and wait for its output and result. The
command is specified first and and subsequent arguments as elements of the
list. This helper then logs the command being executed to the debug output,
which can be useful when you're trying to find out what exactly what program
is being invoked.

Keep in mind that this isn't invoking a shell; arguments and their values have
to be enumerated separately:

@
    'execProcess' [\"\/usr\/bin\/ssh\", \"-l\", \"admin\", \"203.0.113.42\", \"\\\'remote command here\\\'\"]
@

having to write out the individual options and arguments and deal with
escaping is a bit of an annoyance but that's /execvp(3)/ for you.

The return tuple is the exit code from the child process, its entire @stdout@
and its entire @stderr@, if any. Note that this is not a streaming interface,
so if you're doing something that returns huge amounts of output you'll want
to use something like __io-streams__ instead.

(this wraps __typed-process__'s 'readProcess')
-}
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 cmdStr :: String
cmdStr = Rope -> String
forall α. Textual α => Rope -> α
fromRope Rope
cmd
        argsStr :: [String]
argsStr = Rope -> String
forall α. Textual α => Rope -> α
fromRope (Rope -> String) -> [Rope] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Rope]
args
        task :: ProcessConfig () () ()
task = String -> [String] -> ProcessConfig () () ()
proc String
cmdStr [String]
argsStr
        task' :: ProcessConfig () () ()
task' = 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
     in do
            Rope -> ProcessConfig () () () -> Program τ ()
forall α τ. Show α => Rope -> α -> Program τ ()
debugS Rope
"command" ProcessConfig () () ()
task'

            (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 () () ()
task'

            (ExitCode, Rope, Rope) -> Program τ (ExitCode, Rope, Rope)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
exit, ByteString -> Rope
forall α. Textual α => α -> Rope
intoRope ByteString
out, ByteString -> Rope
forall α. Textual α => α -> Rope
intoRope ByteString
err)

{- |
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')
-}
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{$sel:startTimeFrom:Context :: 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)

{- |
Reset the start time (used to calculate durations shown in event- and
debug-level logging) held in the @Context@ to zero. This is useful if you want
to see the elapsed time taken by a specific worker rather than seeing log
entries relative to the program start time which is the default.

If you want to start time held on your main program thread to maintain a count
of the total elapsed program time, then fork a new thread for your worker and
reset the timer there.

@
    'forkThread' $ do
        'resetTimer'
        ...
@

then times output in the log messages will be relative to that call to
'resetTimer', not the program start.
-}
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)

{- |
Pause the current thread for the given number of seconds. For
example, to delay a second and a half, do:

@
    'sleepThread' 1.5
@

(this wraps __base__'s 'threadDelay')
-}

--
-- FIXME is this the right type, given we want to avoid type default warnings?
--
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

{- |
Wait for the completion of a thread, returning the result. This is a blocking
operation.

(this wraps __async__'s 'wait')
-}
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

{- |
Wait for the completion of a thread, discarding its result. This is
particularly useful at the end of a do-block if you're waiting on a worker
thread to finish but don't need its return value, if any; otherwise you have
to explicily deal with the unused return value:

@
    _ <- 'waitThread' t1
    'return' ()
@

which is a bit tedious. Instead, you can just use this convenience function:

@
    'waitThread_' t1
@

The trailing underscore in the name of this function follows the same
convetion as found in "Control.Monad", which has 'Control.Monad.mapM_' which
does the same as 'Control.Monad.mapM' but which likewise discards the return
value.
-}
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

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

{- |
Look to see if the user supplied the named environment variable and if so,
return what its value was.
-}
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

{- |
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"