Context.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}

-- This is an Internal module, hidden from Haddock
module Core.Program.Context (
    Context (..),
    None (..),
    isNone,
    configure,
    Message (..),
    Verbosity (..),
    Program (..),
    unProgram,
    getContext,
    fmapContext,
    subProgram,
) where

import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds)
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar)
import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO)
import qualified Control.Exception.Safe as Safe (catch, throw)
import Control.Monad.Catch (MonadCatch (catch), MonadThrow (throwM))
import Control.Monad.Reader.Class (MonadReader (..))
import Control.Monad.Trans.Reader (ReaderT (..))
import Core.Data.Structures
import Core.Program.Arguments
import Core.Program.Metadata
import Core.System.Base hiding (catch, throw)
import Core.Text.Rope
import Data.Foldable (foldrM)
import Data.Text.Prettyprint.Doc (LayoutOptions (..), PageWidth (..), layoutPretty)
import Data.Text.Prettyprint.Doc.Render.Text (renderIO)
import qualified System.Console.Terminal.Size as Terminal (Window (..), size)
import System.Environment (getArgs, getProgName, lookupEnv)
import System.Exit (ExitCode (..), exitWith)
import Prelude hiding (log)

{- |
Internal context for a running program. You access this via actions in the
'Program' monad. The principal item here is the user-supplied top-level
application data of type @τ@ which can be retrieved with
'Core.Program.Execute.getApplicationState' and updated with
'Core.Program.Execute.setApplicationState'.
-}

--
-- The fieldNameFrom idiom is an experiment. Looks very strange,
-- certainly, here in the record type definition and when setting
-- fields, but for the common case of getting a value out of the
-- record, a call like
--
--     fieldNameFrom context
--
-- isn't bad at all, and no worse than the leading underscore
-- convention.
--
--     _fieldName context
--
-- (I would argue better, since _ is already so overloaded as the
-- wildcard symbol in Haskell). Either way, the point is to avoid a
-- bare fieldName because so often you have want to be able to use
-- that field name as a local variable name.
--
data Context τ = Context
    { programNameFrom :: MVar Rope
    , versionFrom :: Version
    , commandLineFrom :: Parameters
    , exitSemaphoreFrom :: MVar ExitCode
    , startTimeFrom :: MVar TimeStamp
    , terminalWidthFrom :: Int
    , verbosityLevelFrom :: MVar Verbosity
    , outputChannelFrom :: TQueue Rope
    , loggerChannelFrom :: TQueue Message
    , applicationDataFrom :: MVar τ
    }

-- I would happily accept critique as to whether this is safe or not. I think
-- so? The only way to get to the underlying top-level application data is
-- through 'getApplicationState' which is in Program monad so the fact that it
-- is implemented within an MVar should be irrelevant.
instance Functor Context where
    fmap f = unsafePerformIO . fmapContext f

{- |
Map a function over the underlying user-data inside the 'Context', changing
it from type@τ1@ to @τ2@.
-}
fmapContext :: (τ1 -> τ2) -> Context τ1 -> IO (Context τ2)
fmapContext f context = do
    state <- readMVar (applicationDataFrom context)
    let state' = f state
    u <- newMVar state'
    return (context{applicationDataFrom = u})

{- |
A 'Program' with no user-supplied state to be threaded throughout the
computation.

The "Core.Program.Execute" framework makes your top-level application state
available at the outer level of your process. While this is a feature that
most substantial programs rely on, it is /not/ needed for many simple tasks or
when first starting out what will become a larger project.

This is effectively the unit type, but this alias is here to clearly signal a
user-data type is not a part of the program semantics.
-}

-- Bids are open for a better name for this
data None = None
    deriving (Show, Eq)

isNone :: None -> Bool
isNone _ = True

data Message = Message TimeStamp Verbosity Rope (Maybe Rope)

{- |
The verbosity level of the logging subsystem. You can override the level
specified on the command-line using 'Core.Program.Execute.setVerbosityLevel'
from within the 'Program' monad.
-}
data Verbosity = Output | Event | Debug
    deriving (Show)

{- |
The type of a top-level program.

You would use this by writing:

@
module Main where

import "Core.Program"

main :: 'IO' ()
main = 'Core.Program.Execute.execute' program
@

and defining a program that is the top level of your application:

@
program :: 'Program' 'None' ()
@

Such actions are combinable; you can sequence them (using bind in do-notation)
or run them in parallel, but basically you should need one such object at the
top of your application.

/Type variables/

A 'Program' has a user-supplied application state and a return type.

The first type variable, @τ@, is your application's state. This is an object
that will be threaded through the computation and made available to your code
in the 'Program' monad. While this is a common requirement of the outer code
layer in large programs, it is often /not/ necessary in small programs or when
starting new projects. You can mark that there is no top-level application
state required using 'None' and easily change it later if your needs evolve.

The return type, @α@, is usually unit as this effectively being called
directly from @main@ and Haskell programs have type @'IO' ()@. That is, they
don't return anything; I/O having already happened as side effects.

/Programs in separate modules/

One of the quirks of Haskell is that it is difficult to refer to code in the
Main module when you've got a number of programs kicking around in a project
each with a @main@ function. So you're best off putting your top-level
'Program' actions in a separate modules so you can refer to them from test
suites and example snippets.
-}
newtype Program τ α = Program (ReaderT (Context τ) IO α)
    deriving (Functor, Applicative, Monad, MonadIO, MonadReader (Context τ))

unProgram :: Program τ α -> ReaderT (Context τ) IO α
unProgram (Program r) = r

{- |
Get the internal @Context@ of the running @Program@. There is ordinarily no
reason to use this; to access your top-level application data @τ@ within the
@Context@ use 'Core.Program.Execute.getApplicationState'.
-}
getContext :: Program τ (Context τ)
getContext = do
    context <- ask
    return context

{- |
Run a subprogram from within a lifted @IO@ block.
-}
subProgram :: Context τ -> Program τ α -> IO α
subProgram context (Program r) = do
    runReaderT r context

{-
This is complicated. The **safe-exceptions** library exports a `throwM` which
is not the `throwM` class method from MonadThrow. See
https://github.com/fpco/safe-exceptions/issues/31 for discussion. In any
event, the re-exports flow back to Control.Monad.Catch from **exceptions** and
Control.Exceptions in **base**. In the execute actions, we need to catch
everything (including asynchronous exceptions); elsewhere we will use and
wrap/export **safe-exceptions**'s variants of the functions.
-}
instance MonadThrow (Program τ) where
    throwM = liftIO . Safe.throw

unHandler :: (ε -> Program τ α) -> (ε -> ReaderT (Context τ) IO α)
unHandler = fmap unProgram

instance MonadCatch (Program τ) where
    catch :: Exception ε => (Program τ) α -> (ε -> (Program τ) α) -> (Program τ) α
    catch program handler =
        let r = unProgram program
            h = unHandler handler
         in do
                context <- ask
                liftIO $ do
                    Safe.catch
                        (runReaderT r context)
                        (\e -> runReaderT (h e) context)

{- |
Initialize the programs's execution context. This takes care of various
administrative actions, including setting up output channels, parsing
command-line arguments (according to the supplied configuration), and putting
in place various semaphores for internal program communication. See
"Core.Program.Arguments" for details.

This is also where you specify the initial {blank, empty, default) value for
the top-level user-defined application state, if you have one. Specify 'None'
if you aren't using this feature.
-}
configure :: Version -> τ -> Config -> IO (Context τ)
configure version t config = do
    start <- getCurrentTimeNanoseconds

    arg0 <- getProgName
    n <- newMVar (intoRope arg0)
    p <- handleCommandLine version config
    q <- newEmptyMVar
    i <- newMVar start
    columns <- getConsoleWidth
    out <- newTQueueIO
    log <- newTQueueIO
    u <- newMVar t

    l <- handleVerbosityLevel p

    return
        $! Context
            { programNameFrom = n
            , versionFrom = version
            , commandLineFrom = p
            , exitSemaphoreFrom = q
            , startTimeFrom = i
            , terminalWidthFrom = columns
            , verbosityLevelFrom = l
            , outputChannelFrom = out
            , loggerChannelFrom = log
            , applicationDataFrom = u
            }

--

{- |
Probe the width of the terminal, in characters. If it fails to retrieve, for
whatever reason, return a default of 80 characters wide.
-}
getConsoleWidth :: IO (Int)
getConsoleWidth = do
    window <- Terminal.size
    let columns = case window of
            Just (Terminal.Window _ w) -> w
            Nothing -> 80
    return columns

--

{- |
Process the command line options and arguments. If an invalid option is
encountered or a [mandatory] argument is missing, then the program will
terminate here.
-}

{-
    We came back here with the error case so we can pass config in to
    buildUsage (otherwise we could have done it all in displayException and
    called that in Core.Program.Arguments). And, returning here lets us set
    up the layout width to match (one off the) actual width of console.
-}
handleCommandLine :: Version -> Config -> IO Parameters
handleCommandLine version config = do
    argv <- getArgs
    let result = parseCommandLine config argv
    case result of
        Right parameters -> do
            pairs <- lookupEnvironmentVariables config parameters
            return parameters{environmentValuesFrom = pairs}
        Left e -> case e of
            HelpRequest mode -> do
                render (buildUsage config mode)
                exitWith (ExitFailure 1)
            VersionRequest -> do
                render (buildVersion version)
                exitWith (ExitFailure 1)
            _ -> do
                putStr "error: "
                putStrLn (displayException e)
                hFlush stdout
                exitWith (ExitFailure 1)
  where
    render message = do
        columns <- getConsoleWidth
        let options = LayoutOptions (AvailablePerLine (columns - 1) 1.0)
        renderIO stdout (layoutPretty options message)
        hFlush stdout

lookupEnvironmentVariables :: Config -> Parameters -> IO (Map LongName ParameterValue)
lookupEnvironmentVariables config params = do
    let mode = commandNameFrom params
    let valids = extractValidEnvironments mode config

    result <- foldrM f emptyMap valids
    return result
  where
    f :: LongName -> (Map LongName ParameterValue) -> IO (Map LongName ParameterValue)
    f name@(LongName var) acc = do
        result <- lookupEnv var
        return $ case result of
            Just value -> insertKeyValue name (Value value) acc
            Nothing -> acc

handleVerbosityLevel :: Parameters -> IO (MVar Verbosity)
handleVerbosityLevel params = do
    let result = queryVerbosityLevel params
    case result of
        Right level -> do
            newMVar level
        Left exit -> do
            putStrLn "error: To set logging level use --verbose or --debug; neither take values."
            hFlush stdout
            exitWith exit

queryVerbosityLevel :: Parameters -> Either ExitCode Verbosity
queryVerbosityLevel params =
    let debug = lookupKeyValue "debug" (parameterValuesFrom params)
        verbose = lookupKeyValue "verbose" (parameterValuesFrom params)
     in case debug of
            Just value -> case value of
                Empty -> Right Debug
                Value _ -> Left (ExitFailure 2)
            Nothing -> case verbose of
                Just value -> case value of
                    Empty -> Right Event
                    Value _ -> Left (ExitFailure 2)
                Nothing -> Right Output