{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
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)
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 τ
}
instance Functor Context where
fmap f = unsafePerformIO . fmapContext f
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})
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