{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
module Core.Program.Context
(
Context(..)
, None(..)
, isNone
, configure
, Message(..)
, Verbosity(..)
, Program(..)
, unProgram
, getContext
, subProgram
, getConsoleWidth
) where
import Prelude hiding (log)
import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds)
import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar)
import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO)
import Control.Exception.Safe (displayException)
import qualified Control.Exception.Safe as Safe (throw, catch)
import Control.Monad.Catch (MonadThrow(throwM), MonadCatch(catch))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Trans.Reader (ReaderT(..))
import Data.Foldable (foldrM)
import Data.Text.Prettyprint.Doc (layoutPretty, LayoutOptions(..), PageWidth(..))
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 Core.Data.Structures
import Core.System.Base hiding (throw, catch)
import Core.Text.Rope
import Core.Program.Arguments
import Core.Program.Metadata
data Context τ = Context {
programNameFrom :: MVar Rope
, versionFrom :: Version
, commandLineFrom :: Parameters
, exitSemaphoreFrom :: MVar ExitCode
, startTimeFrom :: TimeStamp
, terminalWidthFrom :: Int
, verbosityLevelFrom :: MVar Verbosity
, outputChannelFrom :: TQueue Rope
, loggerChannelFrom :: TQueue Message
, applicationDataFrom :: MVar τ
}
data None = None
deriving (Show, Eq)
isNone :: None -> Bool
isNone _ = True
data Message = Message TimeStamp Verbosity Rope (Maybe Rope)
data Verbosity = Output | Event | Debug
deriving Show
newtype Program τ α = Program (ReaderT (Context τ) IO α)
deriving (Functor, Applicative, Monad, MonadIO, MonadReader (Context τ))
unProgram :: Program τ α -> ReaderT (Context τ) IO α
unProgram (Program r) = r
getContext :: Program τ (Context τ)
getContext = do
context <- ask
return context
subProgram :: Context τ -> Program τ α -> IO α
subProgram context (Program r) = do
runReaderT r context
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)
configure :: Version -> τ -> Config -> IO (Context τ)
configure version t config = do
start <- getCurrentTimeNanoseconds
arg0 <- getProgName
n <- newMVar (intoRope arg0)
p <- handleCommandLine version config
q <- newEmptyMVar
columns <- getConsoleWidth
out <- newTQueueIO
log <- newTQueueIO
u <- newMVar t
l <- handleVerbosityLevel p
return $! Context {
programNameFrom = n
, versionFrom = version
, commandLineFrom = p
, exitSemaphoreFrom = q
, startTimeFrom = start
, terminalWidthFrom = columns
, verbosityLevelFrom = l
, outputChannelFrom = out
, loggerChannelFrom = log
, applicationDataFrom = u
}
getConsoleWidth :: IO (Int)
getConsoleWidth = do
window <- Terminal.size
let columns = case window of
Just (Terminal.Window _ w) -> w
Nothing -> 80
return columns
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