diff --git a/core-program.cabal b/core-program.cabal --- a/core-program.cabal +++ b/core-program.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 5ed0f9b93db8395fee43607d6360220db104b7dd764b60896ac8b495e2d79621 +-- hash: 9e2322161bd290450527b4d25e2a413be161d20fb7ec735599c5f87f3cc62cd5 name: core-program -version: 0.2.6.0 +version: 0.2.7.1 synopsis: Opinionated Haskell Interoperability description: A library to help build command-line programs, both tools and longer-running daemons. @@ -24,10 +24,10 @@ bug-reports: https://github.com/aesiniath/unbeliever/issues author: Andrew Cowie maintainer: Andrew Cowie -copyright: © 2018-2020 Athae Eredh Siniath and Others +copyright: © 2018-2021 Athae Eredh Siniath and Others license: BSD3 license-file: LICENSE -tested-with: GHC == 8.8.4 +tested-with: GHC == 8.10.4 build-type: Simple source-repository head diff --git a/lib/Core/Program/Arguments.hs b/lib/Core/Program/Arguments.hs --- a/lib/Core/Program/Arguments.hs +++ b/lib/Core/Program/Arguments.hs @@ -5,849 +5,864 @@ {-# LANGUAGE StrictData #-} {-# OPTIONS_HADDOCK prune #-} --- | --- Invoking a command-line program (be it tool or daemon) consists of listing --- the name of its binary, optionally supplying various options to adjust the --- behaviour of the program, and then supplying mandatory arguments, if any --- are specified. --- --- On startup, we parse any arguments passed in from the shell into --- @name,value@ pairs and incorporated into the resultant configuration stored --- in the program's Context. --- --- Additionally, this module allows you to specify environment variables that, --- if present, will be incorporated into the stored configuration. -module Core.Program.Arguments - ( -- * Setup - Config, - blank, - simple, - complex, - baselineOptions, - Parameters (..), - ParameterValue (..), - - -- * Options and Arguments - LongName (..), - ShortName, - Description, - Options (..), - - -- * Programs with Commands - Commands (..), - - -- * Internals - parseCommandLine, - extractValidEnvironments, - InvalidCommandLine (..), - buildUsage, - buildVersion, - ) -where - -import Core.Data.Structures -import Core.Program.Metadata -import Core.System.Base -import Core.Text.Rope -import Core.Text.Utilities -import Data.Hashable (Hashable) -import qualified Data.List as List -import Data.Maybe (fromMaybe) -import Data.String -import Data.Text.Prettyprint.Doc - ( Doc, - Pretty (..), - align, - emptyDoc, - fillBreak, - fillCat, - fillSep, - hardline, - indent, - nest, - softline, - (<+>), - ) -import Data.Text.Prettyprint.Doc.Util (reflow) -import System.Environment (getProgName) - --- | --- Single letter "short" options (omitting the "@-@" prefix, obviously). -type ShortName = Char - --- | --- The description of an option, command, or environment variable (for use --- when rendering usage information in response to @--help@ on the --- command-line). -type Description = Rope - --- | --- The name of an option, command, or agument (omitting the "@--@" prefix in --- the case of options). This identifier will be used to generate usage text --- in response to @--help@ and by you later when retreiving the values of the --- supplied parameters after the program has initialized. --- --- Turn on __@OverloadedStrings@__ when specifying configurations, obviously. -newtype LongName = LongName String - deriving (Show, IsString, Eq, Hashable, Ord) - -instance Key LongName - -instance Pretty LongName where - pretty (LongName name) = pretty name - -instance Textual LongName where - intoRope (LongName str) = intoRope str - fromRope = LongName . fromRope - --- | --- The setup for parsing the command-line arguments of your program. You build --- a @Config@ with 'simple' or 'complex', and pass it to --- 'Core.Program.Context.configure'. -data Config - = Blank - | Simple [Options] - | Complex [Commands] - --- --- Those constructors are not exposed [and functions wrapping them are] partly --- for documentation convenience, partly for aesthetics (after a point too many --- constructors got a bit hard to differentiate betwen), and mostly so that if --- configure's argument turns into a monad like RequestBuilder we have --- somewhere to make that change. --- - --- | --- A completely empty configuration, without the default debugging and logging --- options. Your program won't process any command-line options or arguments, --- which would be weird in most cases. Prefer 'simple'. -blank :: Config -blank = Blank - --- | --- Declare a simple (as in normal) configuration for a program with any number --- of optional parameters and mandatory arguments. For example: --- --- @ --- main :: 'IO' () --- main = do --- context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('simple' --- [ 'Option' "host" ('Just' \'h\') 'Empty' ['quote'| --- Specify an alternate host to connect to when performing the --- frobnication. The default is \"localhost\". --- |] --- , 'Option' "port" ('Just' \'p\') 'Empty' ['quote'| --- Specify an alternate port to connect to when frobnicating. --- |] --- , 'Option' "dry-run" 'Nothing' ('Value' \"TIME\") ['quote'| --- Perform a trial run at the specified time but don't actually --- do anything. --- |] --- , 'Option' "quiet" ('Just' \'q\') 'Empty' ['quote'| --- Supress normal output. --- |] --- , 'Argument' "filename" ['quote'| --- The file you want to frobnicate. --- |] --- ]) --- --- 'Core.Program.Execute.executeWith' context program --- @ --- --- which, if you build that into an executable called @snippet@ and invoke it --- with @--help@, would result in: --- --- @ --- \$ __./snippet --help__ --- Usage: --- --- snippet [OPTIONS] filename --- --- Available options: --- --- -h, --host Specify an alternate host to connect to when performing the --- frobnication. The default is \"localhost\". --- -p, --port Specify an alternate port to connect to when frobnicating. --- --dry-run=TIME --- Perform a trial run at the specified time but don't --- actually do anything. --- -q, --quiet Supress normal output. --- -v, --verbose Turn on event tracing. By default the logging stream will go --- to standard output on your terminal. --- --debug Turn on debug level logging. Implies --verbose. --- --- Required arguments: --- --- filename The file you want to frobnicate. --- \$ __|__ --- @ --- --- For information on how to use the multi-line string literals shown here, --- see 'quote' in "Core.Text.Utilities". -simple :: [Options] -> Config -simple options = Simple (options ++ baselineOptions) - --- | --- Declare a complex configuration (implying a larger tool with various --- "[sub]commands" or "modes"} for a program. You can specify global options --- applicable to all commands, a list of commands, and environment variables --- that will be honoured by the program. Each command can have a list of local --- options and arguments as needed. For example: --- --- @ --- program :: 'Core.Program.Execute.Program' MusicAppStatus () --- program = ... --- --- main :: 'IO' () --- main = do --- context <- 'Core.Program.Execute.configure' ('Core.Program.Execute.fromPackage' version) 'mempty' ('complex' --- [ 'Global' --- [ 'Option' "station-name" 'Nothing' ('Value' \"NAME\") ['quote'| --- Specify an alternate radio station to connect to when performing --- actions. The default is \"BBC Radio 1\". --- |] --- , 'Variable' \"PLAYER_FORCE_HEADPHONES\" ['quote'| --- If set to @1@, override the audio subsystem to force output --- to go to the user's headphone jack. --- |] --- ] --- , 'Command' \"play\" \"Play the music.\" --- [ 'Option' "repeat" 'Nothing' 'Empty' ['quote'| --- Request that they play the same song over and over and over --- again, simulating the effect of listening to a Top 40 radio --- station. --- |] --- ] --- , 'Command' \"rate\" \"Vote on whether you like the song or not.\" --- [ 'Option' "academic" 'Nothing' 'Empty' ['quote'| --- The rating you wish to apply, from A+ to F. This is the --- default, so there is no reason whatsoever to specify this. --- But some people are obsessive, compulsive, and have time on --- their hands. --- |] --- , 'Option' "numeric" 'Nothing' 'Empty' ['quote'| --- Specify a score as a number from 0 to 100 instead of an --- academic style letter grade. Note that negative values are --- not valid scores, despite how vicerally satisfying that --- would be for music produced in the 1970s. --- |] --- , 'Option' "unicode" ('Just' \'c\') 'Empty' ['quote'| --- Instead of a score, indicate your rating with a single --- character. This allows you to use emoji, so that you can --- rate a piece \'💩\', as so many songs deserve. --- |] --- , 'Argument' "score" ['quote'| --- The rating you wish to apply. --- |] --- ] --- ]) --- --- 'Core.Program.Execute.executeWith' context program --- @ --- --- is a program with one global option (in addition to the default ones) [and --- an environment variable] and two commands: @play@, with one option; and --- @rate@, with two options and a required argument. It also is set up to --- carry its top-level application state around in a type called --- @MusicAppStatus@ (implementing 'Monoid' and so initialized here with --- 'mempty'. This is a good pattern to use given we are so early in the --- program's lifetime). --- --- The resultant program could be invoked as in these examples: --- --- @ --- \$ __./player --station-name=\"KBBL-FM 102.5\" play__ --- \$ --- @ --- --- @ --- \$ __./player -v rate --numeric 76__ --- \$ --- @ --- --- For information on how to use the multi-line string literals shown here, --- see 'quote' in "Core.Text.Utilities". -complex :: [Commands] -> Config -complex commands = Complex (commands ++ [Global baselineOptions]) - --- | --- Description of the command-line structure of a program which has --- \"commands\" (sometimes referred to as \"subcommands\") representing --- different modes of operation. This is familiar from tools like /git/ --- and /docker/. -data Commands - = Global [Options] - | Command LongName Description [Options] - --- | --- Declaration of an optional switch or mandatory argument expected by a --- program. --- --- 'Option' takes a long name for the option, a short single character --- abbreviation if offered for convenience, whether or not the option takes a --- value (and what label to show in help output) and a description for use --- when displaying usage via @--help@. --- --- 'Argument' indicates a mandatory argument and takes the long name used --- to identify the parsed value from the command-line, and likewise a --- description for @--help@ output. --- --- By convention option and argument names are both /lower case/. If the --- identifier is two or more words they are joined with a hyphen. Examples: --- --- @ --- [ 'Option' \"quiet\" ('Just' \'q'\) 'Empty' \"Keep the noise to a minimum.\" --- , 'Option' \"dry-run\" 'Nothing' ('Value' \"TIME\") \"Run a simulation of what would happen at the specified time.\" --- , 'Argument' \"username\" \"The user to delete from the system.\" --- ] --- @ --- --- By convention a /description/ is one or more complete sentences each of --- which ends with a full stop. For options that take values, use /upper case/ --- when specifying the label to be used in help output. --- --- 'Variable' declares an /environment variable/ that, if present, will be --- read by the program and stored in its runtime context. By convention these --- are /upper case/. If the identifier is two or more words they are joined --- with an underscore: --- --- @ --- [ ... --- , 'Variable' \"CRAZY_MODE\" "Specify how many crazies to activate." --- , ... --- ] --- @ -data Options - = Option LongName (Maybe ShortName) ParameterValue Description - | Argument LongName Description - | Variable LongName Description - --- | --- Individual parameters read in off the command-line can either have a value --- (in the case of arguments and options taking a value) or be empty (in the --- case of options that are just flags). -data ParameterValue - = Value String - | Empty - deriving (Show, Eq) - -instance IsString ParameterValue where - fromString x = Value x - --- | --- Result of having processed the command-line and the environment. You get at --- the parsed command-line options and arguments by calling --- 'Core.Program.Execute.getCommandLine' within a --- 'Core.Program.Execute.Program' block. --- --- Each option and mandatory argument parsed from the command-line is either --- standalone (in the case of switches and flags, such as @--quiet@) or has an --- associated value. In the case of options the key is the name of the option, --- and for arguments it is the implicit name specified when setting up the --- program. For example, in: --- --- @ --- \$ ./submit --username=gbmh GraceHopper_Resume.pdf --- @ --- --- the option has parameter name \"@username@\" and value \"@gmbh@\"; the --- argument has parameter name \"filename\" (assuming that is what was --- declared in the 'Argument' entry) and a value being the Admiral's CV. This --- would be returned as: --- --- @ --- 'Parameters' 'Nothing' [("username","gbmh"), ("filename","GraceHopper_Resume.pdf")] [] --- @ --- --- The case of a complex command such as /git/ or /stack/, you get the specific --- mode chosen by the user returned in the first position: --- --- @ --- \$ missiles launch --all --- @ --- --- would be parsed as: --- --- @ --- 'Parameters' ('Just' \"launch\") [("all",Empty)] [] --- @ -data Parameters = Parameters - { commandNameFrom :: Maybe LongName, - parameterValuesFrom :: Map LongName ParameterValue, - environmentValuesFrom :: Map LongName ParameterValue - } - deriving (Show, Eq) - -baselineOptions :: [Options] -baselineOptions = - [ Option - "verbose" - (Just 'v') - Empty - [quote| - Turn on event tracing. By default the logging stream will go to - standard output on your terminal. - |], - Option - "debug" - Nothing - Empty - [quote| - Turn on debug level logging. Implies --verbose. - |] - ] - --- | --- Different ways parsing a simple or complex command-line can fail. -data InvalidCommandLine - = -- | Something was wrong with the way the user specified [usually a short] option. - InvalidOption String - | -- | User specified an option that doesn't match any in the supplied configuration. - UnknownOption String - | -- | Arguments are mandatory, and this one is missing. - MissingArgument LongName - | -- | Arguments are present we weren't expecting. - UnexpectedArguments [String] - | -- | In a complex configuration, user specified a command that doesn't match any in the configuration. - UnknownCommand String - | -- | In a complex configuration, user didn't specify a command. - NoCommandFound - | -- | In a complex configuration, usage information was requested with @--help@, either globally or for the supplied command. - HelpRequest (Maybe LongName) - | -- | Display of the program version requested with @--version@. - VersionRequest - deriving (Show, Eq) - -instance Exception InvalidCommandLine where - displayException e = case e of - InvalidOption arg -> - let one = "Option '" ++ arg ++ "' illegal.\n\n" - two = - [quote| -Options must either be long form with a double dash, for example: - - --verbose - -or, when available with a short version, a single dash and a single -character. They need to be listed individually: - - -v -a - -When an option takes a value it has to be in long form and the value -indicated with an equals sign, for example: - - --tempdir=/tmp - -with complex values escaped according to the rules of your shell: - - --username="Ada Lovelace" - -For options valid in this program, please see --help. - |] - in one ++ two - UnknownOption name -> "Sorry, option '" ++ name ++ "' not recognized." - MissingArgument (LongName name) -> "Mandatory argument '" ++ name ++ "' missing." - UnexpectedArguments args -> - let quoted = List.intercalate "', '" args - in [quote| -Unexpected trailing arguments: - -|] - ++ quoted - ++ [quote| - -For arguments expected by this program, please see --help. -|] - UnknownCommand first -> "Hm. Command '" ++ first ++ "' not recognized." - NoCommandFound -> - [quote| -No command specified. -Usage is of the form: - - |] - ++ programName - ++ [quote| [GLOBAL OPTIONS] COMMAND [LOCAL OPTIONS] [ARGUMENTS] - -See --help for details. -|] - -- handled by parent module calling back into here buildUsage - HelpRequest _ -> "" - -- handled by parent module calling back into here buildVersion - VersionRequest -> "" - -programName :: String -programName = unsafePerformIO getProgName - --- | --- Given a program configuration schema and the command-line arguments, --- process them into key/value pairs in a Parameters object. --- --- This results in 'InvalidCommandLine' on the left side if one of the passed --- in options is unrecognized or if there is some other problem handling --- options or arguments (because at that point, we want to rabbit right back --- to the top and bail out; there's no recovering). --- --- This isn't something you'll ever need to call directly; it's exposed for --- testing convenience. This function is invoked when you call --- 'Core.Program.Context.configure' or 'Core.Program.Execute.execute' (which --- calls 'configure' with a default @Config@ when initializing). -parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters -parseCommandLine config argv = case config of - Blank -> return (Parameters Nothing emptyMap emptyMap) - Simple options -> do - params <- extractor Nothing options argv - return (Parameters Nothing params emptyMap) - Complex commands -> - let globalOptions = extractGlobalOptions commands - modes = extractValidModes commands - in do - (possibles, argv') <- splitCommandLine1 argv - params1 <- extractor Nothing globalOptions possibles - (first, remainingArgs) <- splitCommandLine2 argv' - (mode, localOptions) <- parseIndicatedCommand modes first - params2 <- extractor (Just mode) localOptions remainingArgs - return (Parameters (Just mode) ((<>) params1 params2) emptyMap) - where - extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine (Map LongName ParameterValue) - extractor mode options args = - let (possibles, arguments) = List.partition isOption args - valids = extractValidNames options - shorts = extractShortNames options - needed = extractRequiredArguments options - in do - list1 <- parsePossibleOptions mode valids shorts possibles - list2 <- parseRequiredArguments needed arguments - return ((<>) (intoMap list1) (intoMap list2)) - -isOption :: String -> Bool -isOption arg = case arg of - ('-' : _) -> True - _ -> False - -parsePossibleOptions :: - Maybe LongName -> - Set LongName -> - Map ShortName LongName -> - [String] -> - Either InvalidCommandLine [(LongName, ParameterValue)] -parsePossibleOptions mode valids shorts args = mapM f args - where - f arg = case arg of - "--help" -> Left (HelpRequest mode) - "-?" -> Left (HelpRequest mode) - "--version" -> Left VersionRequest - ('-' : '-' : name) -> considerLongOption name - ('-' : c : []) -> considerShortOption c - _ -> Left (InvalidOption arg) - - considerLongOption :: String -> Either InvalidCommandLine (LongName, ParameterValue) - considerLongOption arg = - let (name, value) = List.span (/= '=') arg - candidate = LongName name - -- lose the '=' - value' = case List.uncons value of - Just (_, remainder) -> Value remainder - Nothing -> Empty - in if containsElement candidate valids - then Right (candidate, value') - else Left (UnknownOption ("--" ++ name)) - - considerShortOption :: Char -> Either InvalidCommandLine (LongName, ParameterValue) - considerShortOption c = - case lookupKeyValue c shorts of - Just name -> Right (name, Empty) - Nothing -> Left (UnknownOption ['-', c]) - -parseRequiredArguments :: - [LongName] -> - [String] -> - Either InvalidCommandLine [(LongName, ParameterValue)] -parseRequiredArguments needed argv = iter needed argv - where - iter :: [LongName] -> [String] -> Either InvalidCommandLine [(LongName, ParameterValue)] - - iter [] [] = Right [] - -- more arguments supplied than expected - iter [] args = Left (UnexpectedArguments args) - -- more arguments required, not satisfied - iter (name : _) [] = Left (MissingArgument name) - iter (name : names) (arg : args) = - let deeper = iter names args - in case deeper of - Left e -> Left e - Right list -> Right ((name, Value arg) : list) - -parseIndicatedCommand :: - Map LongName [Options] -> - String -> - Either InvalidCommandLine (LongName, [Options]) -parseIndicatedCommand modes first = - let candidate = LongName first - in case lookupKeyValue candidate modes of - Just options -> Right (candidate, options) - Nothing -> Left (UnknownCommand first) - --- --- Ok, the f,g,h,... was silly. But hey :) --- - -extractValidNames :: [Options] -> Set LongName -extractValidNames options = - foldr f emptySet options - where - f :: Options -> Set LongName -> Set LongName - f (Option longname _ _ _) valids = insertElement longname valids - f _ valids = valids - -extractShortNames :: [Options] -> Map ShortName LongName -extractShortNames options = - foldr g emptyMap options - where - g :: Options -> Map ShortName LongName -> Map ShortName LongName - g (Option longname shortname _ _) shorts = case shortname of - Just shortchar -> insertKeyValue shortchar longname shorts - Nothing -> shorts - g _ shorts = shorts - -extractRequiredArguments :: [Options] -> [LongName] -extractRequiredArguments arguments = - foldr h [] arguments - where - h :: Options -> [LongName] -> [LongName] - h (Argument longname _) needed = longname : needed - h _ needed = needed - -extractGlobalOptions :: [Commands] -> [Options] -extractGlobalOptions commands = - foldr j [] commands - where - j :: Commands -> [Options] -> [Options] - j (Global options) valids = options ++ valids - j _ valids = valids - -extractValidModes :: [Commands] -> Map LongName [Options] -extractValidModes commands = - foldr k emptyMap commands - where - k :: Commands -> Map LongName [Options] -> Map LongName [Options] - k (Command longname _ options) modes = insertKeyValue longname options modes - k _ modes = modes - --- | --- Break the command-line apart in two steps. The first peels off the global --- options, the second below looks to see if there is a command (of fails) and --- if so, whether it has any parameters. --- --- We do it this way so that `parseCommandLine` can pas the global options to --- `extractor` and thence `parsePossibleOptions` to catch --version and --- --help. -splitCommandLine1 :: [String] -> Either InvalidCommandLine ([String], [String]) -splitCommandLine1 args = - let (possibles, remainder) = List.span isOption args - in if null possibles && null remainder - then Left NoCommandFound - else Right (possibles, remainder) - -splitCommandLine2 :: [String] -> Either InvalidCommandLine (String, [String]) -splitCommandLine2 argv' = - let x = List.uncons argv' - in case x of - Just (mode, remainingArgs) -> Right (mode, remainingArgs) - Nothing -> Left NoCommandFound - --- --- Environment variable handling --- - -extractValidEnvironments :: Maybe LongName -> Config -> Set LongName -extractValidEnvironments mode config = case config of - Blank -> emptySet - Simple options -> extractVariableNames options - Complex commands -> - let globals = extractGlobalOptions commands - variables1 = extractVariableNames globals - - locals = extractLocalVariables commands (fromMaybe "" mode) - variables2 = extractVariableNames locals - in variables1 <> variables2 - -extractLocalVariables :: [Commands] -> LongName -> [Options] -extractLocalVariables commands mode = - foldr k [] commands - where - k :: Commands -> [Options] -> [Options] - k (Command name _ options) acc = if name == mode then options else acc - k _ acc = acc - -extractVariableNames :: [Options] -> Set LongName -extractVariableNames options = - foldr f emptySet options - where - f :: Options -> Set LongName -> Set LongName - f (Variable longname _) valids = insertElement longname valids - f _ valids = valids - --- --- The code from here on is formatting code. It's fairly repetative --- and crafted to achieve a specific aesthetic output. Rather messy. --- I'm sure it could be done "better" but no matter; this is on the --- path to an exit and return to user's command line. --- - -buildUsage :: Config -> Maybe LongName -> Doc ann -buildUsage config mode = case config of - Blank -> emptyDoc - Simple options -> - let (o, a) = partitionParameters options - in "Usage:" <> hardline <> hardline - <> indent - 4 - ( nest - 4 - ( fillCat - [ pretty programName, - optionsSummary o, - argumentsSummary a - ] - ) - ) - <> hardline - <> optionsHeading o - <> formatParameters o - <> argumentsHeading a - <> formatParameters a - Complex commands -> - let globalOptions = extractGlobalOptions commands - modes = extractValidModes commands - - (oG, _) = partitionParameters globalOptions - in "Usage:" <> hardline <> hardline <> case mode of - Nothing -> - indent - 2 - ( nest - 4 - ( fillCat - [ pretty programName, - globalSummary oG, - commandSummary modes - ] - ) - ) - <> hardline - <> globalHeading oG - <> formatParameters oG - <> commandHeading modes - <> formatCommands commands - Just longname -> - let (oL, aL) = case lookupKeyValue longname modes of - Just localOptions -> partitionParameters localOptions - Nothing -> error "Illegal State" - in indent - 2 - ( nest - 4 - ( fillCat - [ pretty programName, - globalSummary oG, - commandSummary modes, - localSummary oL, - argumentsSummary aL - ] - ) - ) - <> hardline - <> localHeading oL - <> formatParameters oL - <> argumentsHeading aL - <> formatParameters aL - where - partitionParameters :: [Options] -> ([Options], [Options]) - partitionParameters options = foldr f ([], []) options - - optionsSummary :: [Options] -> Doc ann - optionsSummary os = if length os > 0 then softline <> "[OPTIONS]" else emptyDoc - - optionsHeading os = if length os > 0 then hardline <> "Available options:" <> hardline else emptyDoc - - globalSummary os = if length os > 0 then softline <> "[GLOBAL OPTIONS]" else emptyDoc - globalHeading os = - if length os > 0 - then hardline <> "Global options:" <> hardline - else emptyDoc - - localSummary os = if length os > 0 then softline <> "[LOCAL OPTIONS]" else emptyDoc - localHeading os = - if length os > 0 - then hardline <> "Options to the '" <> commandName <> "' command:" <> hardline - else emptyDoc - - commandName :: Doc ann - commandName = case mode of - Just (LongName name) -> pretty name - Nothing -> "COMMAND..." - - argumentsSummary :: [Options] -> Doc ann - argumentsSummary as = " " <> fillSep (fmap pretty (extractRequiredArguments as)) - - argumentsHeading as = if length as > 0 then hardline <> "Required arguments:" <> hardline else emptyDoc - - -- there is a corner case of complex config with no commands - commandSummary modes = if length modes > 0 then softline <> commandName else emptyDoc - commandHeading modes = if length modes > 0 then hardline <> "Available commands:" <> hardline else emptyDoc - - f :: Options -> ([Options], [Options]) -> ([Options], [Options]) - f o@(Option _ _ _ _) (opts, args) = (o : opts, args) - f a@(Argument _ _) (opts, args) = (opts, a : args) - f (Variable _ _) (opts, args) = (opts, args) - - formatParameters :: [Options] -> Doc ann - formatParameters [] = emptyDoc - formatParameters options = hardline <> foldr g emptyDoc options - - -- - -- 16 characters width for short option, long option, and two spaces. If the - -- long option's name is wider than this the description will be moved to - -- the next line. - -- - -- Arguments are aligned to the character of the short option; looks - -- pretty good and better than waiting until column 8. - -- - - g :: Options -> Doc ann -> Doc ann - g (Option longname shortname valued description) acc = - let s = case shortname of - Just shortchar -> " -" <> pretty shortchar <> ", --" - Nothing -> " --" - l = pretty longname - d = fromRope description - in case valued of - Empty -> - fillBreak 16 (s <> l <> " ") <+> align (reflow d) <> hardline <> acc - Value label -> - fillBreak 16 (s <> l <> "=" <> pretty label <> " ") <+> align (reflow d) <> hardline <> acc - g (Argument longname description) acc = - let l = pretty longname - d = fromRope description - in fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc - g (Variable longname description) acc = - let l = pretty longname - d = fromRope description - in fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc - - formatCommands :: [Commands] -> Doc ann - formatCommands commands = hardline <> foldr h emptyDoc commands - - h :: Commands -> Doc ann -> Doc ann - h (Command longname description _) acc = - let l = pretty longname - d = fromRope description - in fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc - h _ acc = acc - -buildVersion :: Version -> Doc ann -buildVersion version = - pretty (projectNameFrom version) - <+> "v" - <> pretty (versionNumberFrom version) - <> hardline +{- | +Invoking a command-line program (be it tool or daemon) consists of listing +the name of its binary, optionally supplying various options to adjust the +behaviour of the program, and then supplying mandatory arguments, if any +are specified. + +On startup, we parse any arguments passed in from the shell into +@name,value@ pairs and incorporated into the resultant configuration stored +in the program's Context. + +Additionally, this module allows you to specify environment variables that, +if present, will be incorporated into the stored configuration. +-} +module Core.Program.Arguments ( + -- * Setup + Config, + blank, + simple, + complex, + baselineOptions, + Parameters (..), + ParameterValue (..), + + -- * Options and Arguments + LongName (..), + ShortName, + Description, + Options (..), + + -- * Programs with Commands + Commands (..), + + -- * Internals + parseCommandLine, + extractValidEnvironments, + InvalidCommandLine (..), + buildUsage, + buildVersion, +) where + +import Data.Hashable (Hashable) +import qualified Data.List as List +import Data.Maybe (fromMaybe) +import Data.String (IsString (..)) +import Data.Text.Prettyprint.Doc ( + Doc, + Pretty (..), + align, + emptyDoc, + fillBreak, + fillCat, + fillSep, + hardline, + indent, + nest, + softline, + (<+>), + ) +import Data.Text.Prettyprint.Doc.Util (reflow) +import System.Environment (getProgName) + +import Core.Data.Structures +import Core.Program.Metadata +import Core.System.Base +import Core.Text.Rope +import Core.Text.Utilities + +{- | +Single letter "short" options (omitting the "@-@" prefix, obviously). +-} +type ShortName = Char + +{- | +The description of an option, command, or environment variable (for use +when rendering usage information in response to @--help@ on the +command-line). +-} +type Description = Rope + +{- | +The name of an option, command, or agument (omitting the "@--@" prefix in +the case of options). This identifier will be used to generate usage text +in response to @--help@ and by you later when retreiving the values of the +supplied parameters after the program has initialized. + +Turn on __@OverloadedStrings@__ when specifying configurations, obviously. +-} +newtype LongName = LongName String + deriving (Show, IsString, Eq, Hashable, Ord) + +instance Key LongName + +instance Pretty LongName where + pretty (LongName name) = pretty name + +instance Textual LongName where + intoRope (LongName str) = intoRope str + fromRope = LongName . fromRope + +{- | +The setup for parsing the command-line arguments of your program. You build +a @Config@ with 'simple' or 'complex', and pass it to +'Core.Program.Context.configure'. +-} +data Config + = Blank + | Simple [Options] + | Complex [Commands] + +-- +-- Those constructors are not exposed [and functions wrapping them are] partly +-- for documentation convenience, partly for aesthetics (after a point too many +-- constructors got a bit hard to differentiate betwen), and mostly so that if +-- configure's argument turns into a monad like RequestBuilder we have +-- somewhere to make that change. +-- + +{- | +A completely empty configuration, without the default debugging and logging +options. Your program won't process any command-line options or arguments, +which would be weird in most cases. Prefer 'simple'. +-} +blank :: Config +blank = Blank + +{- | +Declare a simple (as in normal) configuration for a program with any number +of optional parameters and mandatory arguments. For example: + +@ +main :: 'IO' () +main = do + context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('simple' + [ 'Option' "host" ('Just' \'h\') 'Empty' ['quote'| + Specify an alternate host to connect to when performing the + frobnication. The default is \"localhost\". + |] + , 'Option' "port" ('Just' \'p\') 'Empty' ['quote'| + Specify an alternate port to connect to when frobnicating. + |] + , 'Option' "dry-run" 'Nothing' ('Value' \"TIME\") ['quote'| + Perform a trial run at the specified time but don't actually + do anything. + |] + , 'Option' "quiet" ('Just' \'q\') 'Empty' ['quote'| + Supress normal output. + |] + , 'Argument' "filename" ['quote'| + The file you want to frobnicate. + |] + ]) + + 'Core.Program.Execute.executeWith' context program +@ + +which, if you build that into an executable called @snippet@ and invoke it +with @--help@, would result in: + +@ +\$ __./snippet --help__ +Usage: + + snippet [OPTIONS] filename + +Available options: + + -h, --host Specify an alternate host to connect to when performing the + frobnication. The default is \"localhost\". + -p, --port Specify an alternate port to connect to when frobnicating. + --dry-run=TIME + Perform a trial run at the specified time but don't + actually do anything. + -q, --quiet Supress normal output. + -v, --verbose Turn on event tracing. By default the logging stream will go + to standard output on your terminal. + --debug Turn on debug level logging. Implies --verbose. + +Required arguments: + + filename The file you want to frobnicate. +\$ __|__ +@ + +For information on how to use the multi-line string literals shown here, +see 'quote' in "Core.Text.Utilities". +-} +simple :: [Options] -> Config +simple options = Simple (options ++ baselineOptions) + +{- | +Declare a complex configuration (implying a larger tool with various +"[sub]commands" or "modes"} for a program. You can specify global options +applicable to all commands, a list of commands, and environment variables +that will be honoured by the program. Each command can have a list of local +options and arguments as needed. For example: + +@ +program :: 'Core.Program.Execute.Program' MusicAppStatus () +program = ... + +main :: 'IO' () +main = do + context <- 'Core.Program.Execute.configure' ('Core.Program.Execute.fromPackage' version) 'mempty' ('complex' + [ 'Global' + [ 'Option' "station-name" 'Nothing' ('Value' \"NAME\") ['quote'| + Specify an alternate radio station to connect to when performing + actions. The default is \"BBC Radio 1\". + |] + , 'Variable' \"PLAYER_FORCE_HEADPHONES\" ['quote'| + If set to @1@, override the audio subsystem to force output + to go to the user's headphone jack. + |] + ] + , 'Command' \"play\" \"Play the music.\" + [ 'Option' "repeat" 'Nothing' 'Empty' ['quote'| + Request that they play the same song over and over and over + again, simulating the effect of listening to a Top 40 radio + station. + |] + ] + , 'Command' \"rate\" \"Vote on whether you like the song or not.\" + [ 'Option' "academic" 'Nothing' 'Empty' ['quote'| + The rating you wish to apply, from A+ to F. This is the + default, so there is no reason whatsoever to specify this. + But some people are obsessive, compulsive, and have time on + their hands. + |] + , 'Option' "numeric" 'Nothing' 'Empty' ['quote'| + Specify a score as a number from 0 to 100 instead of an + academic style letter grade. Note that negative values are + not valid scores, despite how vicerally satisfying that + would be for music produced in the 1970s. + |] + , 'Option' "unicode" ('Just' \'c\') 'Empty' ['quote'| + Instead of a score, indicate your rating with a single + character. This allows you to use emoji, so that you can + rate a piece \'💩\', as so many songs deserve. + |] + , 'Argument' "score" ['quote'| + The rating you wish to apply. + |] + ] + ]) + + 'Core.Program.Execute.executeWith' context program +@ + +is a program with one global option (in addition to the default ones) [and +an environment variable] and two commands: @play@, with one option; and +@rate@, with two options and a required argument. It also is set up to +carry its top-level application state around in a type called +@MusicAppStatus@ (implementing 'Monoid' and so initialized here with +'mempty'. This is a good pattern to use given we are so early in the +program's lifetime). + +The resultant program could be invoked as in these examples: + +@ +\$ __./player --station-name=\"KBBL-FM 102.5\" play__ +\$ +@ + +@ +\$ __./player -v rate --numeric 76__ +\$ +@ + +For information on how to use the multi-line string literals shown here, +see 'quote' in "Core.Text.Utilities". +-} +complex :: [Commands] -> Config +complex commands = Complex (commands ++ [Global baselineOptions]) + +{- | +Description of the command-line structure of a program which has +\"commands\" (sometimes referred to as \"subcommands\") representing +different modes of operation. This is familiar from tools like /git/ +and /docker/. +-} +data Commands + = Global [Options] + | Command LongName Description [Options] + +{- | +Declaration of an optional switch or mandatory argument expected by a +program. + +'Option' takes a long name for the option, a short single character +abbreviation if offered for convenience, whether or not the option takes a +value (and what label to show in help output) and a description for use +when displaying usage via @--help@. + +'Argument' indicates a mandatory argument and takes the long name used +to identify the parsed value from the command-line, and likewise a +description for @--help@ output. + +By convention option and argument names are both /lower case/. If the +identifier is two or more words they are joined with a hyphen. Examples: + +@ + [ 'Option' \"quiet\" ('Just' \'q'\) 'Empty' \"Keep the noise to a minimum.\" + , 'Option' \"dry-run\" 'Nothing' ('Value' \"TIME\") \"Run a simulation of what would happen at the specified time.\" + , 'Argument' \"username\" \"The user to delete from the system.\" + ] +@ + +By convention a /description/ is one or more complete sentences each of +which ends with a full stop. For options that take values, use /upper case/ +when specifying the label to be used in help output. + +'Variable' declares an /environment variable/ that, if present, will be +read by the program and stored in its runtime context. By convention these +are /upper case/. If the identifier is two or more words they are joined +with an underscore: + +@ + [ ... + , 'Variable' \"CRAZY_MODE\" "Specify how many crazies to activate." + , ... + ] +@ +-} +data Options + = Option LongName (Maybe ShortName) ParameterValue Description + | Argument LongName Description + | Variable LongName Description + +{- | +Individual parameters read in off the command-line can either have a value +(in the case of arguments and options taking a value) or be empty (in the +case of options that are just flags). +-} +data ParameterValue + = Value String + | Empty + deriving (Show, Eq) + +instance IsString ParameterValue where + fromString x = Value x + +{- | +Result of having processed the command-line and the environment. You get at +the parsed command-line options and arguments by calling +'Core.Program.Execute.getCommandLine' within a +'Core.Program.Execute.Program' block. + +Each option and mandatory argument parsed from the command-line is either +standalone (in the case of switches and flags, such as @--quiet@) or has an +associated value. In the case of options the key is the name of the option, +and for arguments it is the implicit name specified when setting up the +program. For example, in: + +@ +\$ ./submit --username=gbmh GraceHopper_Resume.pdf +@ + +the option has parameter name \"@username@\" and value \"@gmbh@\"; the +argument has parameter name \"filename\" (assuming that is what was +declared in the 'Argument' entry) and a value being the Admiral's CV. This +would be returned as: + +@ +'Parameters' 'Nothing' [("username","gbmh"), ("filename","GraceHopper_Resume.pdf")] [] +@ + +The case of a complex command such as /git/ or /stack/, you get the specific +mode chosen by the user returned in the first position: + +@ +\$ missiles launch --all +@ + +would be parsed as: + +@ +'Parameters' ('Just' \"launch\") [("all",Empty)] [] +@ +-} +data Parameters = Parameters + { commandNameFrom :: Maybe LongName + , parameterValuesFrom :: Map LongName ParameterValue + , environmentValuesFrom :: Map LongName ParameterValue + } + deriving (Show, Eq) + +baselineOptions :: [Options] +baselineOptions = + [ Option + "verbose" + (Just 'v') + Empty + [quote| + Turn on event tracing. By default the logging stream will go to + standard output on your terminal. + |] + , Option + "debug" + Nothing + Empty + [quote| + Turn on debug level logging. Implies --verbose. + |] + ] + +{- | +Different ways parsing a simple or complex command-line can fail. +-} +data InvalidCommandLine + = -- | Something was wrong with the way the user specified [usually a short] option. + InvalidOption String + | -- | User specified an option that doesn't match any in the supplied configuration. + UnknownOption String + | -- | Arguments are mandatory, and this one is missing. + MissingArgument LongName + | -- | Arguments are present we weren't expecting. + UnexpectedArguments [String] + | -- | In a complex configuration, user specified a command that doesn't match any in the configuration. + UnknownCommand String + | -- | In a complex configuration, user didn't specify a command. + NoCommandFound + | -- | In a complex configuration, usage information was requested with @--help@, either globally or for the supplied command. + HelpRequest (Maybe LongName) + | -- | Display of the program version requested with @--version@. + VersionRequest + deriving (Show, Eq) + +instance Exception InvalidCommandLine where + displayException e = case e of + InvalidOption arg -> + let one = "Option '" ++ arg ++ "' illegal.\n\n" + two = + [quote| +Options must either be long form with a double dash, for example: + + --verbose + +or, when available with a short version, a single dash and a single +character. They need to be listed individually: + + -v -a + +When an option takes a value it has to be in long form and the value +indicated with an equals sign, for example: + + --tempdir=/tmp + +with complex values escaped according to the rules of your shell: + + --username="Ada Lovelace" + +For options valid in this program, please see --help. + |] + in one ++ two + UnknownOption name -> "Sorry, option '" ++ name ++ "' not recognized." + MissingArgument (LongName name) -> "Mandatory argument '" ++ name ++ "' missing." + UnexpectedArguments args -> + let quoted = List.intercalate "', '" args + in [quote| +Unexpected trailing arguments: + +|] + ++ quoted + ++ [quote| + +For arguments expected by this program, please see --help. +|] + UnknownCommand first -> "Hm. Command '" ++ first ++ "' not recognized." + NoCommandFound -> + [quote| +No command specified. +Usage is of the form: + + |] + ++ programName + ++ [quote| [GLOBAL OPTIONS] COMMAND [LOCAL OPTIONS] [ARGUMENTS] + +See --help for details. +|] + -- handled by parent module calling back into here buildUsage + HelpRequest _ -> "" + -- handled by parent module calling back into here buildVersion + VersionRequest -> "" + +programName :: String +programName = unsafePerformIO getProgName + +{- | +Given a program configuration schema and the command-line arguments, +process them into key/value pairs in a Parameters object. + +This results in 'InvalidCommandLine' on the left side if one of the passed +in options is unrecognized or if there is some other problem handling +options or arguments (because at that point, we want to rabbit right back +to the top and bail out; there's no recovering). + +This isn't something you'll ever need to call directly; it's exposed for +testing convenience. This function is invoked when you call +'Core.Program.Context.configure' or 'Core.Program.Execute.execute' (which +calls 'configure' with a default @Config@ when initializing). +-} +parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters +parseCommandLine config argv = case config of + Blank -> return (Parameters Nothing emptyMap emptyMap) + Simple options -> do + params <- extractor Nothing options argv + return (Parameters Nothing params emptyMap) + Complex commands -> + let globalOptions = extractGlobalOptions commands + modes = extractValidModes commands + in do + (possibles, argv') <- splitCommandLine1 argv + params1 <- extractor Nothing globalOptions possibles + (first, remainingArgs) <- splitCommandLine2 argv' + (mode, localOptions) <- parseIndicatedCommand modes first + params2 <- extractor (Just mode) localOptions remainingArgs + return (Parameters (Just mode) ((<>) params1 params2) emptyMap) + where + extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine (Map LongName ParameterValue) + extractor mode options args = + let (possibles, arguments) = List.partition isOption args + valids = extractValidNames options + shorts = extractShortNames options + needed = extractRequiredArguments options + in do + list1 <- parsePossibleOptions mode valids shorts possibles + list2 <- parseRequiredArguments needed arguments + return ((<>) (intoMap list1) (intoMap list2)) + +isOption :: String -> Bool +isOption arg = case arg of + ('-' : _) -> True + _ -> False + +parsePossibleOptions :: + Maybe LongName -> + Set LongName -> + Map ShortName LongName -> + [String] -> + Either InvalidCommandLine [(LongName, ParameterValue)] +parsePossibleOptions mode valids shorts args = mapM f args + where + f arg = case arg of + "--help" -> Left (HelpRequest mode) + "-?" -> Left (HelpRequest mode) + "--version" -> Left VersionRequest + ('-' : '-' : name) -> considerLongOption name + ('-' : c : []) -> considerShortOption c + _ -> Left (InvalidOption arg) + + considerLongOption :: String -> Either InvalidCommandLine (LongName, ParameterValue) + considerLongOption arg = + let (name, value) = List.span (/= '=') arg + candidate = LongName name + -- lose the '=' + value' = case List.uncons value of + Just (_, remainder) -> Value remainder + Nothing -> Empty + in if containsElement candidate valids + then Right (candidate, value') + else Left (UnknownOption ("--" ++ name)) + + considerShortOption :: Char -> Either InvalidCommandLine (LongName, ParameterValue) + considerShortOption c = + case lookupKeyValue c shorts of + Just name -> Right (name, Empty) + Nothing -> Left (UnknownOption ['-', c]) + +parseRequiredArguments :: + [LongName] -> + [String] -> + Either InvalidCommandLine [(LongName, ParameterValue)] +parseRequiredArguments needed argv = iter needed argv + where + iter :: [LongName] -> [String] -> Either InvalidCommandLine [(LongName, ParameterValue)] + + iter [] [] = Right [] + -- more arguments supplied than expected + iter [] args = Left (UnexpectedArguments args) + -- more arguments required, not satisfied + iter (name : _) [] = Left (MissingArgument name) + iter (name : names) (arg : args) = + let deeper = iter names args + in case deeper of + Left e -> Left e + Right list -> Right ((name, Value arg) : list) + +parseIndicatedCommand :: + Map LongName [Options] -> + String -> + Either InvalidCommandLine (LongName, [Options]) +parseIndicatedCommand modes first = + let candidate = LongName first + in case lookupKeyValue candidate modes of + Just options -> Right (candidate, options) + Nothing -> Left (UnknownCommand first) + +-- +-- Ok, the f,g,h,... was silly. But hey :) +-- + +extractValidNames :: [Options] -> Set LongName +extractValidNames options = + foldr f emptySet options + where + f :: Options -> Set LongName -> Set LongName + f (Option longname _ _ _) valids = insertElement longname valids + f _ valids = valids + +extractShortNames :: [Options] -> Map ShortName LongName +extractShortNames options = + foldr g emptyMap options + where + g :: Options -> Map ShortName LongName -> Map ShortName LongName + g (Option longname shortname _ _) shorts = case shortname of + Just shortchar -> insertKeyValue shortchar longname shorts + Nothing -> shorts + g _ shorts = shorts + +extractRequiredArguments :: [Options] -> [LongName] +extractRequiredArguments arguments = + foldr h [] arguments + where + h :: Options -> [LongName] -> [LongName] + h (Argument longname _) needed = longname : needed + h _ needed = needed + +extractGlobalOptions :: [Commands] -> [Options] +extractGlobalOptions commands = + foldr j [] commands + where + j :: Commands -> [Options] -> [Options] + j (Global options) valids = options ++ valids + j _ valids = valids + +extractValidModes :: [Commands] -> Map LongName [Options] +extractValidModes commands = + foldr k emptyMap commands + where + k :: Commands -> Map LongName [Options] -> Map LongName [Options] + k (Command longname _ options) modes = insertKeyValue longname options modes + k _ modes = modes + +{- | +Break the command-line apart in two steps. The first peels off the global +options, the second below looks to see if there is a command (of fails) and +if so, whether it has any parameters. + +We do it this way so that `parseCommandLine` can pas the global options to +`extractor` and thence `parsePossibleOptions` to catch --version and +--help. +-} +splitCommandLine1 :: [String] -> Either InvalidCommandLine ([String], [String]) +splitCommandLine1 args = + let (possibles, remainder) = List.span isOption args + in if null possibles && null remainder + then Left NoCommandFound + else Right (possibles, remainder) + +splitCommandLine2 :: [String] -> Either InvalidCommandLine (String, [String]) +splitCommandLine2 argv' = + let x = List.uncons argv' + in case x of + Just (mode, remainingArgs) -> Right (mode, remainingArgs) + Nothing -> Left NoCommandFound + +-- +-- Environment variable handling +-- + +extractValidEnvironments :: Maybe LongName -> Config -> Set LongName +extractValidEnvironments mode config = case config of + Blank -> emptySet + Simple options -> extractVariableNames options + Complex commands -> + let globals = extractGlobalOptions commands + variables1 = extractVariableNames globals + + locals = extractLocalVariables commands (fromMaybe "" mode) + variables2 = extractVariableNames locals + in variables1 <> variables2 + +extractLocalVariables :: [Commands] -> LongName -> [Options] +extractLocalVariables commands mode = + foldr k [] commands + where + k :: Commands -> [Options] -> [Options] + k (Command name _ options) acc = if name == mode then options else acc + k _ acc = acc + +extractVariableNames :: [Options] -> Set LongName +extractVariableNames options = + foldr f emptySet options + where + f :: Options -> Set LongName -> Set LongName + f (Variable longname _) valids = insertElement longname valids + f _ valids = valids + +-- +-- The code from here on is formatting code. It's fairly repetative +-- and crafted to achieve a specific aesthetic output. Rather messy. +-- I'm sure it could be done "better" but no matter; this is on the +-- path to an exit and return to user's command line. +-- + +buildUsage :: Config -> Maybe LongName -> Doc ann +buildUsage config mode = case config of + Blank -> emptyDoc + Simple options -> + let (o, a) = partitionParameters options + in "Usage:" <> hardline <> hardline + <> indent + 4 + ( nest + 4 + ( fillCat + [ pretty programName + , optionsSummary o + , argumentsSummary a + ] + ) + ) + <> hardline + <> optionsHeading o + <> formatParameters o + <> argumentsHeading a + <> formatParameters a + Complex commands -> + let globalOptions = extractGlobalOptions commands + modes = extractValidModes commands + + (oG, _) = partitionParameters globalOptions + in "Usage:" <> hardline <> hardline <> case mode of + Nothing -> + indent + 2 + ( nest + 4 + ( fillCat + [ pretty programName + , globalSummary oG + , commandSummary modes + ] + ) + ) + <> hardline + <> globalHeading oG + <> formatParameters oG + <> commandHeading modes + <> formatCommands commands + Just longname -> + let (oL, aL) = case lookupKeyValue longname modes of + Just localOptions -> partitionParameters localOptions + Nothing -> error "Illegal State" + in indent + 2 + ( nest + 4 + ( fillCat + [ pretty programName + , globalSummary oG + , commandSummary modes + , localSummary oL + , argumentsSummary aL + ] + ) + ) + <> hardline + <> localHeading oL + <> formatParameters oL + <> argumentsHeading aL + <> formatParameters aL + where + partitionParameters :: [Options] -> ([Options], [Options]) + partitionParameters options = foldr f ([], []) options + + optionsSummary :: [Options] -> Doc ann + optionsSummary os = if length os > 0 then softline <> "[OPTIONS]" else emptyDoc + + optionsHeading os = if length os > 0 then hardline <> "Available options:" <> hardline else emptyDoc + + globalSummary os = if length os > 0 then softline <> "[GLOBAL OPTIONS]" else emptyDoc + globalHeading os = + if length os > 0 + then hardline <> "Global options:" <> hardline + else emptyDoc + + localSummary os = if length os > 0 then softline <> "[LOCAL OPTIONS]" else emptyDoc + localHeading os = + if length os > 0 + then hardline <> "Options to the '" <> commandName <> "' command:" <> hardline + else emptyDoc + + commandName :: Doc ann + commandName = case mode of + Just (LongName name) -> pretty name + Nothing -> "COMMAND..." + + argumentsSummary :: [Options] -> Doc ann + argumentsSummary as = " " <> fillSep (fmap pretty (extractRequiredArguments as)) + + argumentsHeading as = if length as > 0 then hardline <> "Required arguments:" <> hardline else emptyDoc + + -- there is a corner case of complex config with no commands + commandSummary modes = if length modes > 0 then softline <> commandName else emptyDoc + commandHeading modes = if length modes > 0 then hardline <> "Available commands:" <> hardline else emptyDoc + + f :: Options -> ([Options], [Options]) -> ([Options], [Options]) + f o@(Option _ _ _ _) (opts, args) = (o : opts, args) + f a@(Argument _ _) (opts, args) = (opts, a : args) + f (Variable _ _) (opts, args) = (opts, args) + + formatParameters :: [Options] -> Doc ann + formatParameters [] = emptyDoc + formatParameters options = hardline <> foldr g emptyDoc options + + -- + -- 16 characters width for short option, long option, and two spaces. If the + -- long option's name is wider than this the description will be moved to + -- the next line. + -- + -- Arguments are aligned to the character of the short option; looks + -- pretty good and better than waiting until column 8. + -- + + g :: Options -> Doc ann -> Doc ann + g (Option longname shortname valued description) acc = + let s = case shortname of + Just shortchar -> " -" <> pretty shortchar <> ", --" + Nothing -> " --" + l = pretty longname + d = fromRope description + in case valued of + Empty -> + fillBreak 16 (s <> l <> " ") <+> align (reflow d) <> hardline <> acc + Value label -> + fillBreak 16 (s <> l <> "=" <> pretty label <> " ") <+> align (reflow d) <> hardline <> acc + g (Argument longname description) acc = + let l = pretty longname + d = fromRope description + in fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc + g (Variable longname description) acc = + let l = pretty longname + d = fromRope description + in fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc + + formatCommands :: [Commands] -> Doc ann + formatCommands commands = hardline <> foldr h emptyDoc commands + + h :: Commands -> Doc ann -> Doc ann + h (Command longname description _) acc = + let l = pretty longname + d = fromRope description + in fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc + h _ acc = acc + +buildVersion :: Version -> Doc ann +buildVersion version = + pretty (projectNameFrom version) + <+> "v" + <> pretty (versionNumberFrom version) + <> hardline diff --git a/lib/Core/Program/Context.hs b/lib/Core/Program/Context.hs --- a/lib/Core/Program/Context.hs +++ b/lib/Core/Program/Context.hs @@ -10,8 +10,8 @@ {-# OPTIONS_HADDOCK hide #-} -- This is an Internal module, hidden from Haddock -module Core.Program.Context - ( Context (..), +module Core.Program.Context ( + Context (..), None (..), isNone, configure, @@ -22,8 +22,7 @@ getContext, fmapContext, subProgram, - ) -where +) where import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds) import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar) @@ -45,12 +44,13 @@ 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'. +{- | +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, @@ -71,219 +71,225 @@ -- that field name as a local variable name. -- 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 τ - } + { 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 + fmap f = unsafePerformIO . fmapContext f --- | --- Map a function over the underlying user-data inside the 'Context', changing --- it from type@τ1@ to @τ2@. +{- | +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}) + 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. +{- | +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) + 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. +{- | +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) + 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. +{- | +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 τ)) + 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'. +{- | +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 + context <- ask + return context --- | --- Run a subprogram from within a lifted @IO@ block. +{- | +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. + 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 + 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) + 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. +{- | +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 + start <- getCurrentTimeNanoseconds - arg0 <- getProgName - n <- newMVar (intoRope arg0) - p <- handleCommandLine version config - q <- newEmptyMVar - columns <- getConsoleWidth - out <- newTQueueIO - log <- newTQueueIO - u <- newMVar t + 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 + 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 - } + 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. +{- | +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 + 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. +{- | +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 @@ -293,67 +299,67 @@ -} 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) + 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 + 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 + let mode = commandNameFrom params + let valids = extractValidEnvironments mode config - result <- foldrM f emptyMap valids - return result + 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 + 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 + 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 + 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 diff --git a/lib/Core/Program/Execute.hs b/lib/Core/Program/Execute.hs --- a/lib/Core/Program/Execute.hs +++ b/lib/Core/Program/Execute.hs @@ -7,49 +7,50 @@ {-# 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 (), +{- | +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, @@ -77,8 +78,12 @@ -- * Concurrency Thread, + forkThread, fork, sleep, + resetTimer, + waitThread, + waitThread_, -- * Internals Context, @@ -87,30 +92,32 @@ unProgram, unThread, invalid, - retrieve, update, output, input, - ) -where +) where +import Chrono.TimeStamp (getCurrentTimeNanoseconds) import Control.Concurrent (threadDelay) -import Control.Concurrent.Async - ( Async, +import Control.Concurrent.Async ( + Async, AsyncCancelled, ExceptionInLinkedThread (..), + ) +import qualified Control.Concurrent.Async as Async ( async, cancel, link, race_, - ) -import Control.Concurrent.MVar (modifyMVar_, putMVar, readMVar) + wait, + ) +import Control.Concurrent.MVar (modifyMVar_, newMVar, 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 (forever, void, when) import Control.Monad.Catch (Handler (..)) import Control.Monad.Reader.Class (MonadReader (ask)) import Core.Data.Structures @@ -132,10 +139,10 @@ -- execute actual "main" executeAction :: Context τ -> Program τ α -> IO () executeAction context program = - let quit = exitSemaphoreFrom context - in do - _ <- subProgram context program - putMVar quit ExitSuccess + let quit = exitSemaphoreFrom context + in do + _ <- subProgram context program + putMVar quit ExitSuccess -- -- If an exception escapes, we'll catch it here. The displayException @@ -146,11 +153,11 @@ -- escapeHandlers :: Context c -> [Handler IO ()] escapeHandlers context = - [ Handler (\(exit :: ExitCode) -> done exit), - Handler (\(_ :: AsyncCancelled) -> pass), - Handler (\(ExceptionInLinkedThread _ e) -> bail e), - Handler (\(e :: SomeException) -> bail e) - ] + [ Handler (\(exit :: ExitCode) -> done exit) + , Handler (\(_ :: AsyncCancelled) -> pass) + , Handler (\(ExceptionInLinkedThread _ e) -> bail e) + , Handler (\(e :: SomeException) -> bail e) + ] where quit = exitSemaphoreFrom context @@ -159,16 +166,16 @@ done :: ExitCode -> IO () done exit = do - putMVar quit exit + putMVar quit exit bail :: Exception e => e -> IO () bail e = - let text = intoRope (displayException e) - in do - subProgram context $ do - setVerbosityLevel Debug - event text - putMVar quit (ExitFailure 127) + let text = intoRope (displayException e) + in do + subProgram context $ do + setVerbosityLevel Debug + event text + putMVar quit (ExitFailure 127) -- -- If an exception occurs in one of the output handlers, its failure causes @@ -180,213 +187,222 @@ -- collapseHandlers :: [Handler IO ()] collapseHandlers = - [ Handler - ( \(e :: AsyncCancelled) -> do - Base.throwIO e - ), - Handler - ( \(e :: SomeException) -> do - putStrLn "error: Output handler collapsed" - print e - Posix.exitImmediately (ExitFailure 99) - ) - ] + [ Handler + ( \(e :: AsyncCancelled) -> do + Base.throwIO e + ) + , Handler + ( \(e :: SomeException) -> do + putStrLn "error: Output handler collapsed" + print e + Posix.exitImmediately (ExitFailure 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. +{- | +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 = do - context <- configure "" None (simple []) - executeWith context program + context <- configure "" None (simple []) + executeWith context 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. +{- | +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 = do - -- command line +RTS -Nn -RTS value - when (numCapabilities == 1) (getNumProcessors >>= setNumCapabilities) + -- command line +RTS -Nn -RTS value + when (numCapabilities == 1) (getNumProcessors >>= setNumCapabilities) - -- force UTF-8 working around bad VMs - setLocaleEncoding utf8 + -- force UTF-8 working around bad VMs + setLocaleEncoding utf8 - let quit = exitSemaphoreFrom context - level = verbosityLevelFrom context - out = outputChannelFrom context - log = loggerChannelFrom context + let quit = exitSemaphoreFrom context + level = verbosityLevelFrom context + out = outputChannelFrom context + log = loggerChannelFrom context - -- set up standard output - o <- async $ do - Safe.catchesAsync - (processStandardOutput out) - (collapseHandlers) + -- set up standard output + o <- Async.async $ do + Safe.catchesAsync + (processStandardOutput out) + (collapseHandlers) - -- set up debug logger - l <- async $ do - Safe.catchesAsync - (processDebugMessages log) - (collapseHandlers) + -- set up debug logger + l <- Async.async $ do + Safe.catchesAsync + (processDebugMessages log) + (collapseHandlers) - -- set up signal handlers - _ <- async $ do - setupSignalHandlers quit level + -- set up signal handlers + _ <- Async.async $ do + setupSignalHandlers quit level - -- run actual program, ensuring to trap uncaught exceptions - m <- async $ do - Safe.catchesAsync - (executeAction context program) - (escapeHandlers context) + -- run actual program, ensuring to trap uncaught exceptions + m <- Async.async $ do + Safe.catchesAsync + (executeAction context program) + (escapeHandlers context) - code <- readMVar quit - cancel m + code <- readMVar quit + Async.cancel m - -- drain message queues. Allow 0.1 seconds, then timeout, in case - -- something has gone wrong and queues don't empty. - race_ - ( do - atomically $ do - done2 <- isEmptyTQueue log - check done2 + -- drain message queues. Allow 0.1 seconds, then timeout, in case + -- something has gone wrong and queues don't empty. + Async.race_ + ( do + atomically $ do + done2 <- isEmptyTQueue log + check done2 - done1 <- isEmptyTQueue out - check done1 - ) - ( do - threadDelay 100000 - putStrLn "error: Timeout" - ) + done1 <- isEmptyTQueue out + check done1 + ) + ( do + threadDelay 100000 + putStrLn "error: Timeout" + ) - threadDelay 100 -- instead of yield - hFlush stdout + threadDelay 100 -- instead of yield + hFlush stdout - cancel l - cancel o + Async.cancel l + Async.cancel o - -- exiting this way avoids "Exception: ExitSuccess" noise in GHCi - if code == ExitSuccess - then return () - else (Base.throwIO code) + -- exiting this way avoids "Exception: ExitSuccess" noise in GHCi + if code == ExitSuccess + then return () + else (Base.throwIO code) processStandardOutput :: TQueue Rope -> IO () processStandardOutput out = do - forever $ do - text <- atomically (readTQueue out) + forever $ do + text <- atomically (readTQueue out) - hWrite stdout text - B.hPut stdout (C.singleton '\n') + hWrite stdout text + B.hPut stdout (C.singleton '\n') processDebugMessages :: TQueue Message -> IO () processDebugMessages log = do - forever $ do - -- TODO do sactually do something with log messages - -- Message now severity text potentialValue <- ... - _ <- atomically (readTQueue log) + forever $ do + -- TODO do sactually do something with log messages + -- Message now severity text potentialValue <- ... + _ <- atomically (readTQueue log) - return () + return () --- | --- Safely exit the program with the supplied exit code. Current output and --- debug queues will be flushed, and then the process will terminate. +{- | +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 code = - let exit = case code of - 0 -> ExitSuccess - _ -> ExitFailure code - in do - context <- ask - let quit = exitSemaphoreFrom context - liftIO $ do - putMVar quit exit - Safe.throw exit + let exit = case code of + 0 -> ExitSuccess + _ -> ExitFailure code + in do + context <- ask + let quit = exitSemaphoreFrom context + liftIO $ do + putMVar quit exit + Safe.throw exit -- undocumented getVerbosityLevel :: Program τ Verbosity getVerbosityLevel = do - context <- ask - liftIO $ do - level <- readMVar (verbosityLevelFrom context) - return level + context <- ask + liftIO $ do + level <- readMVar (verbosityLevelFrom context) + return 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. +{- | +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 level = do - context <- ask - liftIO $ do - let v = verbosityLevelFrom context - modifyMVar_ v (\_ -> pure level) + context <- ask + liftIO $ do + let v = verbosityLevelFrom context + modifyMVar_ v (\_ -> pure level) --- | --- Override the program name used for logging, etc. At least, that was the --- idea. Nothing makes use of this at the moment. @:/@ +{- | +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 name = do - context <- ask - liftIO $ do - let v = programNameFrom context - modifyMVar_ v (\_ -> pure name) + context <- ask + liftIO $ do + let v = programNameFrom context + modifyMVar_ v (\_ -> pure name) --- | --- Get the program name as invoked from the command-line (or as overridden by --- 'setProgramName'). +{- | +Get the program name as invoked from the command-line (or as overridden by +'setProgramName'). +-} getProgramName :: Program τ Rope getProgramName = do - context <- ask - liftIO $ do - let v = programNameFrom context - readMVar v + context <- ask + liftIO $ do + let v = programNameFrom context + readMVar 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). +{- | +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 = do - context <- ask - let width = terminalWidthFrom context - return width + context <- ask + let width = terminalWidthFrom context + return width --- | --- Get the user supplied application state as originally supplied to --- 'configure' and modified subsequntly by replacement with --- 'setApplicationState'. --- --- @ --- state <- getApplicationState --- @ +{- | +Get the user supplied application state as originally supplied to +'configure' and modified subsequntly by replacement with +'setApplicationState'. + +@ + state <- getApplicationState +@ +-} getApplicationState :: Program τ τ getApplicationState = do - context <- ask - liftIO $ do - let v = applicationDataFrom context - readMVar v + context <- ask + liftIO $ do + let v = applicationDataFrom context + readMVar v --- | --- Update the user supplied top-level application state. --- --- @ --- let state' = state { answer = 42 } --- setApplicationState state' --- @ +{- | +Update the user supplied top-level application state. + +@ + let state' = state { answer = 42 } + setApplicationState state' +@ +-} setApplicationState :: τ -> Program τ () setApplicationState user = do - context <- ask - liftIO $ do - let v = applicationDataFrom context - modifyMVar_ v (\_ -> pure user) + context <- ask + liftIO $ do + let v = applicationDataFrom context + modifyMVar_ v (\_ -> pure user) -- | {-# DEPRECATED retrieve "Use getApplicationState instead" #-} @@ -398,24 +414,25 @@ update :: τ -> Program τ () update = 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). +{- | +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 contents = liftIO (hOutput handle contents) @@ -424,8 +441,9 @@ output :: Handle -> Bytes -> Program τ () output = outputEntire --- | --- Read the (entire) contents of the specified @Handle@. +{- | + Read the (entire) contents of the specified @Handle@. +-} inputEntire :: Handle -> Program τ Bytes inputEntire handle = liftIO (hInput handle) @@ -434,128 +452,207 @@ input :: Handle -> Program τ Bytes input = 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') +{- | +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 a) = 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 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 = do + context <- ask + let i = startTimeFrom context + + liftIO $ do + start <- readMVar i + i' <- newMVar start + + let context' = context{startTimeFrom = i'} + + a <- Async.async $ do + subProgram context' program + Async.link a + return (Thread a) + fork :: Program τ α -> Program τ (Thread α) -fork program = do - context <- ask - liftIO $ do - a <- async $ do - subProgram context program - link a - return (Thread a) +fork = forkThread +{-# DEPRECATED fork "Use forkThread instead" #-} --- | --- 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') +{- | +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 = do + context <- ask + + liftIO $ do + start <- getCurrentTimeNanoseconds + let v = startTimeFrom context + modifyMVar_ v (\_ -> pure start) + +{- | +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 seconds = - let us = floor (toRational (seconds * 1e6)) - in liftIO $ threadDelay us + let us = floor (toRational (seconds * 1e6)) + in liftIO $ threadDelay 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). +{- | +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 a) = liftIO $ Async.wait 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_ = void . 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 = do - context <- ask - return (commandLineFrom context) + context <- ask + return (commandLineFrom 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. +{- | +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 name params = - case lookupKeyValue name (parameterValuesFrom params) of - Nothing -> Nothing - Just argument -> case argument of - Empty -> error "Invalid State" - Value value -> Just value + case lookupKeyValue name (parameterValuesFrom params) of + Nothing -> Nothing + Just argument -> case argument of + Empty -> error "Invalid State" + Value value -> Just value --- | --- Look to see if the user supplied a valued option and if so, what its value --- was. +{- | +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 name params = - case lookupKeyValue name (parameterValuesFrom params) of - Nothing -> Nothing - Just argument -> case argument of - Empty -> Nothing - Value value -> Just value + case lookupKeyValue name (parameterValuesFrom params) of + Nothing -> Nothing + Just argument -> case argument of + Empty -> Nothing + Value value -> Just value --- | --- Returns @Just True@ if the option is present, and @Nothing@ if it is not. +{- | +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 name params = - case lookupKeyValue name (parameterValuesFrom params) of - Nothing -> Nothing - Just argument -> case argument of - _ -> Just True -- nom, nom + case lookupKeyValue name (parameterValuesFrom params) of + Nothing -> Nothing + Just argument -> case argument of + _ -> Just True -- nom, nom --- | --- Illegal internal state resulting from what should be unreachable code --- or otherwise a programmer error. +{- | +Illegal internal state resulting from what should be unreachable code or +otherwise a programmer error. +-} invalid :: Program τ α invalid = error "Invalid State" diff --git a/lib/Core/Program/Logging.hs b/lib/Core/Program/Logging.hs --- a/lib/Core/Program/Logging.hs +++ b/lib/Core/Program/Logging.hs @@ -5,117 +5,118 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK prune #-} --- | --- Output and Logging from your program. --- --- Broadly speaking, there are two kinds of program: console tools invoked for --- a single purpose, and long-running daemons that effectively run forever. --- --- Tools tend to be run to either have an effect (in which case they tend not --- to a say much of anything) or to report a result. This tends to be written --- to \"standard output\"—traditionally abbreviated in code as @stdout@—which --- is usually printed to your terminal. --- --- Daemons, on the other hand, don't write their output to file descriptor 1; --- rather they tend to respond to requests by writing to files, replying over --- network sockets, or sending up smoke signals (@ECPUTOOHOT@, in case you're --- curious). What daemons /do/ output, however, is log messages. --- --- While there are many sophisticated logging services around that you can --- interact with directly, from the point of view of an individual /program/ --- these tend to have faded away and have become more an aspect of the --- Infrastructure- or Platform-as-a-Service you're running on. Over the past --- few years containerization mechanisms like __docker__, then more recently --- container orchestration layers like __kubernetes__, have generally simply --- captured programs' standard output /as if it were the program's log output/ --- and then sent that down external logging channels to whatever log analysis --- system is available. Even programs running locally under __systemd__ or --- similar tend to follow the same pattern; services write to @stdout@ and --- that output, as "logs", ends up being fed to the system journal. --- --- So with that in mind, in your program you will either be outputting results --- to @stdout@ or not writing there at all, and you will either be describing --- extensively what your application is up to, or not at all. --- --- There is also a \"standard error\" file descriptor available. We recommend --- not using it. At best it is unclear what is written to @stderr@ and what --- isn't; at worse it is lost as many environments in the wild discard --- @stderr@ entirely. To avoid this most of the time people just combine them --- in the invoking shell with @2>&1@, which inevitably results in @stderr@ --- text appearing in the middle of normal @stdout@ lines corrupting them. --- --- The original idea of standard error was to provde a way to report adverse --- conditions without interrupting normal text output, but as we have just --- observed if it happens without context or out of order there isn't much --- point. Instead this library offers a mechanism which caters for the --- different /kinds/ of output in a unified, safe manner. --- --- == Three kinds of output/logging messages --- --- /Standard output/ --- --- Your program's normal output to the terminal. This library provides the --- 'write' (and 'writeS' and 'writeR') functions to send output to @stdout@. --- --- /Events/ --- --- When running a tool, you sometimes need to know /what it is doing/ as it is --- carrying out its steps. The 'event' function allows you to emit descriptive --- messages to the log channel tracing the activities of your program. --- --- Ideally you would never need to turn this on in a command-line tool, but --- sometimes a user or operations engineer needs to see what an application is --- up to. These should be human readable status messages to convey a sense of --- progress. --- --- In the case of long-running daemons, 'event' can be used to describe --- high-level lifecycle events, to document individual requests, or even --- describing individual transitions in a request handler's state machine, all --- depending on the nature of your program. --- --- /Debugging/ --- --- Programmers, on the other hand, often need to see the internal state of --- the program when /debugging/. --- --- You almost always you want to know the value of some variable or parameter, --- so the 'debug' (and 'debugS' and 'debugR') utility functions here send --- messages to the log channel prefixed with a label that is, by convention, --- the name of the value you are examining. --- --- The important distinction here is that such internal values are almost --- never useful for someone other than the person or team who wrote the code --- emitting it. Operations engineers might be asked by developers to turn on --- @--debug@ing and report back the results; but a user of your program is not --- going to do that in and of themselves to solve a problem. --- --- == Single output channel --- --- It is the easy to make the mistake of having multiple subsystems attempting --- to write to @stdout@ and these outputs corrupting each other, especially in --- a multithreaded language like Haskell. The output actions described here --- send all output to terminal down a single thread-safe channel. Output will --- be written in the order it was executed, and (so long as you don't use the --- @stdout@ Handle directly yourself) your terminal output will be sound. --- --- Passing @--verbose@ on the command-line of your program will cause 'event' --- to write its tracing messages to the terminal. This shares the same output --- channel as the 'write'@*@ functions and will /not/ cause corruption of your --- program's normal output. --- --- Passing @--debug@ on the command-line of your program will cause the --- 'debug'@*@ actions to write their debug-level messages to the terminal. --- This shares the same output channel as above and again will not cause --- corruption of your program's normal output. --- --- == Logging channel --- --- /Event and debug messages are internally also sent to a "logging channel",/ --- /as distinct from the "output" one. This would allow us to send them/ --- /directly to a file, syslog, or network logging service, but this is/ --- /as-yet unimplemented./ -module Core.Program.Logging - ( putMessage, +{- | +Output and Logging from your program. + +Broadly speaking, there are two kinds of program: console tools invoked for +a single purpose, and long-running daemons that effectively run forever. + +Tools tend to be run to either have an effect (in which case they tend not +to a say much of anything) or to report a result. This tends to be written +to \"standard output\"—traditionally abbreviated in code as @stdout@—which +is usually printed to your terminal. + +Daemons, on the other hand, don't write their output to file descriptor 1; +rather they tend to respond to requests by writing to files, replying over +network sockets, or sending up smoke signals (@ECPUTOOHOT@, in case you're +curious). What daemons /do/ output, however, is log messages. + +While there are many sophisticated logging services around that you can +interact with directly, from the point of view of an individual /program/ +these tend to have faded away and have become more an aspect of the +Infrastructure- or Platform-as-a-Service you're running on. Over the past +few years containerization mechanisms like __docker__, then more recently +container orchestration layers like __kubernetes__, have generally simply +captured programs' standard output /as if it were the program's log output/ +and then sent that down external logging channels to whatever log analysis +system is available. Even programs running locally under __systemd__ or +similar tend to follow the same pattern; services write to @stdout@ and +that output, as "logs", ends up being fed to the system journal. + +So with that in mind, in your program you will either be outputting results +to @stdout@ or not writing there at all, and you will either be describing +extensively what your application is up to, or not at all. + +There is also a \"standard error\" file descriptor available. We recommend +not using it. At best it is unclear what is written to @stderr@ and what +isn't; at worse it is lost as many environments in the wild discard +@stderr@ entirely. To avoid this most of the time people just combine them +in the invoking shell with @2>&1@, which inevitably results in @stderr@ +text appearing in the middle of normal @stdout@ lines corrupting them. + +The original idea of standard error was to provde a way to report adverse +conditions without interrupting normal text output, but as we have just +observed if it happens without context or out of order there isn't much +point. Instead this library offers a mechanism which caters for the +different /kinds/ of output in a unified, safe manner. + +== Three kinds of output/logging messages + +/Standard output/ + +Your program's normal output to the terminal. This library provides the +'write' (and 'writeS' and 'writeR') functions to send output to @stdout@. + +/Events/ + +When running a tool, you sometimes need to know /what it is doing/ as it is +carrying out its steps. The 'event' function allows you to emit descriptive +messages to the log channel tracing the activities of your program. + +Ideally you would never need to turn this on in a command-line tool, but +sometimes a user or operations engineer needs to see what an application is +up to. These should be human readable status messages to convey a sense of +progress. + +In the case of long-running daemons, 'event' can be used to describe +high-level lifecycle events, to document individual requests, or even +describing individual transitions in a request handler's state machine, all +depending on the nature of your program. + +/Debugging/ + +Programmers, on the other hand, often need to see the internal state of +the program when /debugging/. + +You almost always you want to know the value of some variable or parameter, +so the 'debug' (and 'debugS' and 'debugR') utility functions here send +messages to the log channel prefixed with a label that is, by convention, +the name of the value you are examining. + +The important distinction here is that such internal values are almost +never useful for someone other than the person or team who wrote the code +emitting it. Operations engineers might be asked by developers to turn on +@--debug@ing and report back the results; but a user of your program is not +going to do that in and of themselves to solve a problem. + +== Single output channel + +It is the easy to make the mistake of having multiple subsystems attempting +to write to @stdout@ and these outputs corrupting each other, especially in +a multithreaded language like Haskell. The output actions described here +send all output to terminal down a single thread-safe channel. Output will +be written in the order it was executed, and (so long as you don't use the +@stdout@ Handle directly yourself) your terminal output will be sound. + +Passing @--verbose@ on the command-line of your program will cause 'event' +to write its tracing messages to the terminal. This shares the same output +channel as the 'write'@*@ functions and will /not/ cause corruption of your +program's normal output. + +Passing @--debug@ on the command-line of your program will cause the +'debug'@*@ actions to write their debug-level messages to the terminal. +This shares the same output channel as above and again will not cause +corruption of your program's normal output. + +== Logging channel + +/Event and debug messages are internally also sent to a "logging channel",/ +/as distinct from the "output" one. This would allow us to send them/ +/directly to a file, syslog, or network logging service, but this is/ +/as-yet unimplemented./ +-} +module Core.Program.Logging ( + putMessage, Verbosity (..), -- * Normal output @@ -130,8 +131,7 @@ debug, debugS, debugR, - ) -where +) where import Chrono.TimeStamp (TimeStamp (..), getCurrentTimeNanoseconds) import Control.Concurrent.MVar (readMVar) @@ -140,13 +140,14 @@ import Control.Exception (evaluate) import Control.Monad (when) import Control.Monad.Reader.Class (MonadReader (ask)) +import Data.Fixed +import Data.Hourglass (TimeFormatElem (..), timePrint) +import qualified Data.Text.Short as S (replicate) + import Core.Program.Context import Core.System.Base import Core.Text.Rope import Core.Text.Utilities -import Data.Fixed -import Data.Hourglass (TimeFormatElem (..), timePrint) -import qualified Data.Text.Short as S (replicate) {- class Monad m => MonadLog a m where @@ -155,196 +156,207 @@ putMessage :: Context τ -> Message -> IO () putMessage context message@(Message now _ text potentialValue) = do - let start = startTimeFrom context - let output = outputChannelFrom context - let logger = loggerChannelFrom context + let i = startTimeFrom context + start <- readMVar i + let output = outputChannelFrom context + let logger = loggerChannelFrom context - let display = case potentialValue of - Just value -> - if containsCharacter '\n' value - then text <> " =\n" <> value - else text <> " = " <> value - Nothing -> text + let display = case potentialValue of + Just value -> + if containsCharacter '\n' value + then text <> " =\n" <> value + else text <> " = " <> value + Nothing -> text - let result = formatLogMessage start now display + let result = formatLogMessage start now display - atomically $ do - writeTQueue output result - writeTQueue logger message + atomically $ do + writeTQueue output result + writeTQueue logger message formatLogMessage :: TimeStamp -> TimeStamp -> Rope -> Rope formatLogMessage start now message = - let start' = unTimeStamp start - now' = unTimeStamp now - stampZ = - timePrint - [ Format_Hour, - Format_Text ':', - Format_Minute, - Format_Text ':', - Format_Second, - Format_Text 'Z' - ] - now + let start' = unTimeStamp start + now' = unTimeStamp now + stampZ = + timePrint + [ Format_Hour + , Format_Text ':' + , Format_Minute + , Format_Text ':' + , Format_Second + , Format_Text 'Z' + ] + now - -- I hate doing math in Haskell - elapsed = fromRational (toRational (now' - start') / 1e9) :: Fixed E3 - in mconcat - [ intoRope stampZ, - " (", - padWithZeros 9 (show elapsed), - ") ", - message - ] + -- I hate doing math in Haskell + elapsed = fromRational (toRational (now' - start') / 1e9) :: Fixed E3 + in mconcat + [ intoRope stampZ + , " (" + , padWithZeros 6 (show elapsed) + , ") " + , message + ] --- | --- Utility function to prepend \'0\' characters to a string representing a --- number. +-- +{- | +Utility function to prepend \'0\' characters to a string representing a +number. +-} + {- Cloned from **locators** package Data.Locators.Hashes, BSD3 licence -} padWithZeros :: Int -> String -> Rope padWithZeros digits str = - intoRope pad <> intoRope str + intoRope pad <> intoRope str where pad = S.replicate len "0" len = digits - length str --- | --- Write the supplied text to @stdout@. --- --- This is for normal program output. --- --- @ --- 'write' "Beginning now" --- @ +{- | +Write the supplied text to @stdout@. + +This is for normal program output. + +@ + 'write' "Beginning now" +@ +-} write :: Rope -> Program τ () write text = do - context <- ask - liftIO $ do - let out = outputChannelFrom context + context <- ask + liftIO $ do + let out = outputChannelFrom context - !text' <- evaluate text - atomically (writeTQueue out text') + !text' <- evaluate text + atomically (writeTQueue out text') --- | --- Call 'show' on the supplied argument and write the resultant text to --- @stdout@. --- --- (This is the equivalent of 'print' from __base__) +{- | +Call 'show' on the supplied argument and write the resultant text to +@stdout@. + +(This is the equivalent of 'print' from __base__) +-} writeS :: Show α => α -> Program τ () writeS = write . intoRope . show --- | --- Pretty print the supplied argument and write the resultant text to --- @stdout@. This will pass the detected terminal width to the 'render' --- function, resulting in appopriate line wrapping when rendering your value. +{- | +Pretty print the supplied argument and write the resultant text to +@stdout@. This will pass the detected terminal width to the 'render' +function, resulting in appopriate line wrapping when rendering your value. +-} writeR :: Render α => α -> Program τ () writeR thing = do - context <- ask - liftIO $ do - let out = outputChannelFrom context - let columns = terminalWidthFrom context + context <- ask + liftIO $ do + let out = outputChannelFrom context + let columns = terminalWidthFrom context - let text = render columns thing - !text' <- evaluate text - atomically (writeTQueue out text') + let text = render columns thing + !text' <- evaluate text + atomically (writeTQueue out text') --- | --- Note a significant event, state transition, status, or debugging --- message. This: --- --- @ --- 'event' "Starting..." --- @ --- --- will result in --- --- > 13:05:55Z (0000.001) Starting... --- --- appearing on stdout /and/ the message being sent down the logging --- channel. The output string is current time in UTC, and time elapsed --- since startup shown to the nearest millisecond (our timestamps are to --- nanosecond precision, but you don't need that kind of resolution in --- in ordinary debugging). --- --- Messages sent to syslog will be logged at @Info@ level severity. +{- | +Note a significant event, state transition, status, or debugging +message. This: + +@ + 'event' "Starting..." +@ + +will result in + +> 13:05:55Z (00.112) Starting... + +appearing on stdout /and/ the message being sent down the logging +channel. The output string is current time in UTC, and time elapsed +since startup shown to the nearest millisecond (our timestamps are to +nanosecond precision, but you don't need that kind of resolution in +in ordinary debugging). + +Messages sent to syslog will be logged at @Info@ level severity. +-} event :: Rope -> Program τ () event text = do - context <- ask - liftIO $ do - level <- readMVar (verbosityLevelFrom context) - when (isEvent level) $ do - now <- getCurrentTimeNanoseconds - putMessage context (Message now Event text Nothing) + context <- ask + liftIO $ do + level <- readMVar (verbosityLevelFrom context) + when (isEvent level) $ do + now <- getCurrentTimeNanoseconds + putMessage context (Message now Event text Nothing) isEvent :: Verbosity -> Bool isEvent level = case level of - Output -> False - Event -> True - Debug -> True + Output -> False + Event -> True + Debug -> True isDebug :: Verbosity -> Bool isDebug level = case level of - Output -> False - Event -> False - Debug -> True + Output -> False + Event -> False + Debug -> True --- | --- Output a debugging message formed from a label and a value. This is like --- 'event' above but for the (rather common) case of needing to inspect or --- record the value of a variable when debugging code. This: --- --- @ --- 'setProgramName' \"hello\" --- name <- 'getProgramName' --- 'debug' \"programName\" name --- @ --- --- will result in --- --- > 13:05:58Z (0003.141) programName = hello --- --- appearing on stdout /and/ the message being sent down the logging channel, --- assuming these actions executed about three seconds after program start. --- --- Messages sent to syslog will be logged at @Debug@ level severity. +{- | +Output a debugging message formed from a label and a value. This is like +'event' above but for the (rather common) case of needing to inspect or +record the value of a variable when debugging code. This: + +@ + 'setProgramName' \"hello\" + name <- 'getProgramName' + 'debug' \"programName\" name +@ + +will result in + +> 13:05:58Z (03.141) programName = hello + +appearing on stdout /and/ the message being sent down the logging channel, +assuming these actions executed about three seconds after program start. + +Messages sent to syslog will be logged at @Debug@ level severity. +-} debug :: Rope -> Rope -> Program τ () debug label value = do - context <- ask - liftIO $ do - level <- readMVar (verbosityLevelFrom context) - when (isDebug level) $ do - now <- getCurrentTimeNanoseconds - !value' <- evaluate value - putMessage context (Message now Debug label (Just value')) + context <- ask + liftIO $ do + level <- readMVar (verbosityLevelFrom context) + when (isDebug level) $ do + now <- getCurrentTimeNanoseconds + !value' <- evaluate value + putMessage context (Message now Debug label (Just value')) --- | --- Convenience for the common case of needing to inspect the value --- of a general variable which has a 'Show' instance +{- | +Convenience for the common case of needing to inspect the value +of a general variable which has a 'Show' instance +-} debugS :: Show α => Rope -> α -> Program τ () debugS label value = debug label (intoRope (show value)) --- | --- Convenience for the common case of needing to inspect the value of a --- general variable for which there is a 'Render' instance and so can pretty --- print the supplied argument to the log. This will pass the detected --- terminal width to the 'render' function, resulting in appopriate line --- wrapping when rendering your value (if logging to something other than --- console the default width of @80@ will be applied). +{- | +Convenience for the common case of needing to inspect the value of a +general variable for which there is a 'Render' instance and so can pretty +print the supplied argument to the log. This will pass the detected +terminal width to the 'render' function, resulting in appopriate line +wrapping when rendering your value (if logging to something other than +console the default width of @80@ will be applied). +-} debugR :: Render α => Rope -> α -> Program τ () debugR label thing = do - context <- ask - liftIO $ do - level <- readMVar (verbosityLevelFrom context) - when (isDebug level) $ do - now <- getCurrentTimeNanoseconds + context <- ask + liftIO $ do + level <- readMVar (verbosityLevelFrom context) + when (isDebug level) $ do + now <- getCurrentTimeNanoseconds - let columns = terminalWidthFrom context + let columns = terminalWidthFrom context - -- TODO take into account 22 width already consumed by timestamp - -- TODO move render to putMessage? putMessageR? - let value = render columns thing - !value' <- evaluate value - putMessage context (Message now Debug label (Just value')) + -- TODO take into account 22 width already consumed by timestamp + -- TODO move render to putMessage? putMessageR? + let value = render columns thing + !value' <- evaluate value + putMessage context (Message now Debug label (Just value')) diff --git a/lib/Core/Program/Metadata.hs b/lib/Core/Program/Metadata.hs --- a/lib/Core/Program/Metadata.hs +++ b/lib/Core/Program/Metadata.hs @@ -2,15 +2,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} --- | --- Dig metadata out of the description of your project. --- --- This uses the evil /Template Haskell/ to run code at compile time that --- parses the /.cabal/ file for your Haskell project and extracts various --- meaningful fields. -module Core.Program.Metadata - ( Version, +{- | +Dig metadata out of the description of your project. +This uses the evil /Template Haskell/ to run code at compile time that +parses the /.cabal/ file for your Haskell project and extracts various +meaningful fields. +-} +module Core.Program.Metadata ( + Version, + -- * Splice fromPackage, @@ -18,8 +19,7 @@ versionNumberFrom, projectNameFrom, projectSynopsisFrom, - ) -where +) where import Core.Data import Core.System (IOMode (..), withFile) @@ -32,95 +32,96 @@ import Language.Haskell.TH.Syntax (Exp (..), Lift) import System.Directory (listDirectory) --- | --- Information about the version number of this piece of software and other --- related metadata related to the project it was built from. This is supplied --- to your program when you call 'Core.Program.Execute.configure'. This value --- is used if the user requests it by specifying the @--version@ option on the --- command-line. --- --- Simply providing an overloaded string literal such as version @\"1.0\"@ --- will give you a 'Version' with that value: --- --- @ --- \{\-\# LANGUAGE OverloadedStrings \#\-\} --- --- main :: 'IO' () --- main = do --- context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('Core.Program.Arguments.simple' ... --- @ --- --- --- For more complex usage you can populate a 'Version' object using the --- 'fromPackage' splice below. You can then call various accessors like --- 'versionNumberFrom' to access individual fields. +{- | +Information about the version number of this piece of software and other +related metadata related to the project it was built from. This is supplied +to your program when you call 'Core.Program.Execute.configure'. This value +is used if the user requests it by specifying the @--version@ option on the +command-line. + +Simply providing an overloaded string literal such as version @\"1.0\"@ +will give you a 'Version' with that value: + +@ +\{\-\# LANGUAGE OverloadedStrings \#\-\} + +main :: 'IO' () +main = do + context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('Core.Program.Arguments.simple' ... +@ + +For more complex usage you can populate a 'Version' object using the +'fromPackage' splice below. You can then call various accessors like +'versionNumberFrom' to access individual fields. +-} data Version = Version - { projectNameFrom :: String, - projectSynopsisFrom :: String, - versionNumberFrom :: String - } - deriving (Show, Lift) + { projectNameFrom :: String + , projectSynopsisFrom :: String + , versionNumberFrom :: String + } + deriving (Show, Lift) emptyVersion :: Version emptyVersion = Version "" "" "0" instance IsString Version where - fromString x = emptyVersion {versionNumberFrom = x} + fromString x = emptyVersion{versionNumberFrom = x} --- | --- This is a splice which includes key built-time metadata, including the --- number from the version field from your project's /.cabal/ file (as written --- by hand or generated from /package.yaml/). --- --- While we generally discourage the use of Template Haskell by beginners --- (there are more important things to learn first) it is a way to execute --- code at compile time and that is what what we need in order to have the --- version number extracted from the /.cabal/ file rather than requiring the --- user to specify (and synchronize) it in multiple places. --- --- To use this, enable the Template Haskell language extension in your --- /Main.hs/ file. Then use the special @$( ... )@ \"insert splice here\" --- syntax that extension provides to get a 'Version' object with the desired --- metadata about your project: --- --- @ --- \{\-\# LANGUAGE TemplateHaskell \#\-\} --- --- version :: 'Version' --- version = $('fromPackage') --- --- main :: 'IO' () --- main = do --- context <- 'Core.Program.Execute.configure' version 'Core.Program.Execute.None' ('Core.Program.Arguments.simple' ... --- @ --- --- (Using Template Haskell slows down compilation of this file, but the upside --- of this technique is that it avoids linking the Haskell build machinery --- into your executable, saving you about 10 MB in the size of the resultant --- binary) +{- | +This is a splice which includes key built-time metadata, including the +number from the version field from your project's /.cabal/ file (as written +by hand or generated from /package.yaml/). + +While we generally discourage the use of Template Haskell by beginners +(there are more important things to learn first) it is a way to execute +code at compile time and that is what what we need in order to have the +version number extracted from the /.cabal/ file rather than requiring the +user to specify (and synchronize) it in multiple places. + +To use this, enable the Template Haskell language extension in your +/Main.hs/ file. Then use the special @$( ... )@ \"insert splice here\" +syntax that extension provides to get a 'Version' object with the desired +metadata about your project: + +@ +\{\-\# LANGUAGE TemplateHaskell \#\-\} + +version :: 'Version' +version = $('fromPackage') + +main :: 'IO' () +main = do + context <- 'Core.Program.Execute.configure' version 'Core.Program.Execute.None' ('Core.Program.Arguments.simple' ... +@ + +(Using Template Haskell slows down compilation of this file, but the upside +of this technique is that it avoids linking the Haskell build machinery +into your executable, saving you about 10 MB in the size of the resultant +binary) +-} fromPackage :: Q Exp fromPackage = do - pairs <- readCabalFile + pairs <- readCabalFile - let name = fromMaybe "" . lookupKeyValue "name" $ pairs - let synopsis = fromMaybe "" . lookupKeyValue "synopsis" $ pairs - let version = fromMaybe "" . lookupKeyValue "version" $ pairs + let name = fromMaybe "" . lookupKeyValue "name" $ pairs + let synopsis = fromMaybe "" . lookupKeyValue "synopsis" $ pairs + let version = fromMaybe "" . lookupKeyValue "version" $ pairs - let result = - Version - { projectNameFrom = fromRope name, - projectSynopsisFrom = fromRope synopsis, - versionNumberFrom = fromRope version - } + let result = + Version + { projectNameFrom = fromRope name + , projectSynopsisFrom = fromRope synopsis + , versionNumberFrom = fromRope version + } - -- I would have preferred - -- - -- let e = AppE (VarE ... - -- return e - -- - -- but that's not happening. So more voodoo TH nonsense instead. + -- I would have preferred + -- + -- let e = AppE (VarE ... + -- return e + -- + -- but that's not happening. So more voodoo TH nonsense instead. - [e|result|] + [e|result|] {- Locate the .cabal file in the present working directory (assumed to be the @@ -130,36 +131,36 @@ findCabalFile :: IO FilePath findCabalFile = do - files <- listDirectory "." - let found = List.find (List.isSuffixOf ".cabal") files - case found of - Just file -> return file - Nothing -> error "No .cabal file found" + files <- listDirectory "." + let found = List.find (List.isSuffixOf ".cabal") files + case found of + Just file -> return file + Nothing -> error "No .cabal file found" readCabalFile :: Q (Map Rope Rope) readCabalFile = runIO $ do - -- Find .cabal file - file <- findCabalFile + -- Find .cabal file + file <- findCabalFile - -- Parse .cabal file - contents <- withFile file ReadMode hInput - let pairs = parseCabalFile contents - -- pass to calling program - return pairs + -- Parse .cabal file + contents <- withFile file ReadMode hInput + let pairs = parseCabalFile contents + -- pass to calling program + return pairs parseCabalFile :: Bytes -> Map Rope Rope parseCabalFile contents = - let breakup = intoMap . fmap (breakRope (== ':')) . breakLines . fromBytes - in breakup contents + let breakup = intoMap . fmap (breakRope (== ':')) . breakLines . fromBytes + in breakup contents -- this should probably be a function in Core.Text.Rope breakRope :: (Char -> Bool) -> Rope -> (Rope, Rope) breakRope predicate text = - let pieces = take 2 (breakPieces predicate text) - in case pieces of - [] -> ("", "") - [one] -> (one, "") - (one : two : _) -> (one, trimRope two) + let pieces = take 2 (breakPieces predicate text) + in case pieces of + [] -> ("", "") + [one] -> (one, "") + (one : two : _) -> (one, trimRope two) -- knock off the whitespace in "name: hello" trimRope :: Rope -> Rope diff --git a/lib/Core/Program/Notify.hs b/lib/Core/Program/Notify.hs --- a/lib/Core/Program/Notify.hs +++ b/lib/Core/Program/Notify.hs @@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK prune #-} --- | --- Helpers for watching files for changes and taking action in the event of a --- change. -module Core.Program.Notify - ( -- * Notify - waitForChange, - ) -where +{- | +Helpers for watching files for changes and taking action in the event of a +change. +-} +module Core.Program.Notify ( + -- * Notify + waitForChange, +) where import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar) import Control.Monad.IO.Class (liftIO) @@ -21,11 +21,12 @@ import System.FSNotify (Event (..), eventPath, watchDir, withManager) import System.FilePath (dropFileName) --- | --- Watch for changes to a given list of files. --- --- Before continuing we insert a 100ms pause to allow whatever the editor was to --- finish its write and switcheroo sequence. +{- | +Watch for changes to a given list of files. + +Before continuing we insert a 100ms pause to allow whatever the editor was to +finish its write and switcheroo sequence. +-} -- -- Ideally we'd just set up inotifies on these individual files, but that diff --git a/lib/Core/Program/Signal.hs b/lib/Core/Program/Signal.hs --- a/lib/Core/Program/Signal.hs +++ b/lib/Core/Program/Signal.hs @@ -1,29 +1,28 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -module Core.Program.Signal - ( setupSignalHandlers, - ) -where +module Core.Program.Signal ( + setupSignalHandlers, +) where import Control.Concurrent.MVar (MVar, modifyMVar_, putMVar) import Core.Program.Context import Foreign.C.Types (CInt) import System.Exit (ExitCode (..)) import System.IO (hFlush, hPutStrLn, stdout) -import System.Posix.Signals - ( Handler (Catch), +import System.Posix.Signals ( + Handler (Catch), installHandler, sigINT, sigTERM, sigUSR1, - ) - --- + ) --- | Make a non-zero exit code which is 0b1000000 + the number of the --- signal. Probably never need this (especaially given our attempt to --- write out a human readable name for the signal caught) but it's a --- convention we're happy to observe. +{- | +Make a non-zero exit code which is 0b1000000 + the number of the signal. +Probably never need this (especaially given our attempt to write out a human +readable name for the signal caught) but it's a convention we're happy to +observe. +-} code :: CInt -> ExitCode code signal = ExitFailure (128 + fromIntegral signal) @@ -35,35 +34,37 @@ interruptHandler :: MVar ExitCode -> Handler interruptHandler quit = Catch $ do - hPutStrLn stdout "\nInterrupt" - hFlush stdout - putMVar quit (code sigINT) + hPutStrLn stdout "\nInterrupt" + hFlush stdout + putMVar quit (code sigINT) terminateHandler :: MVar ExitCode -> Handler terminateHandler quit = Catch $ do - hPutStrLn stdout "Terminating" - hFlush stdout - putMVar quit (code sigTERM) + hPutStrLn stdout "Terminating" + hFlush stdout + putMVar quit (code sigTERM) logLevelHandler :: MVar Verbosity -> Handler logLevelHandler v = Catch $ do - hPutStrLn stdout "Signal" - hFlush stdout - modifyMVar_ - v - ( \level -> case level of - Output -> pure Debug - Event -> pure Debug - Debug -> pure Output - ) + hPutStrLn stdout "Signal" + hFlush stdout + modifyMVar_ + v + ( \level -> case level of + Output -> pure Debug + Event -> pure Debug + Debug -> pure Output + ) -- --- | Install signal handlers for SIGINT and SIGTERM that set the exit --- semaphore so that a Program's [minimal] cleanup can occur. +{- | +Install signal handlers for SIGINT and SIGTERM that set the exit +semaphore so that a Program's [minimal] cleanup can occur. +-} setupSignalHandlers :: MVar ExitCode -> MVar Verbosity -> IO () setupSignalHandlers quit level = do - installHandler sigINT (interruptHandler quit) Nothing - installHandler sigTERM (terminateHandler quit) Nothing - installHandler sigUSR1 (logLevelHandler level) Nothing - return () + installHandler sigINT (interruptHandler quit) Nothing + installHandler sigTERM (terminateHandler quit) Nothing + installHandler sigUSR1 (logLevelHandler level) Nothing + return () diff --git a/lib/Core/Program/Unlift.hs b/lib/Core/Program/Unlift.hs --- a/lib/Core/Program/Unlift.hs +++ b/lib/Core/Program/Unlift.hs @@ -4,156 +4,157 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_HADDOCK prune #-} --- | --- The 'Program' monad is an instance of 'MonadIO', which makes sense; it's --- just a wrapper around doing 'IO' and you call it using --- 'execute' from the top-level @main@ action that is the --- entrypoint to any program. So when you need to actually do some I/O or --- interact with other major libraries in the Haskell ecosystem, you need to --- get back to 'IO' and you use 'liftIO' to do it: --- --- @ --- main :: 'IO' () --- main = 'execute' $ do --- -- now in the Program monad --- 'write' "Hello there" --- --- 'liftIO' $ do --- -- now something in IO --- source <- readFile "hello.c" --- compileSourceCode source --- --- -- back in Program monad --- 'write' \"Finished\" --- @ --- --- and this is a perfectly reasonable pattern. --- --- Sometimes, however, you want to get to the 'Program' monad from /there/, --- and that's tricky; you can't just 'execute' a new --- program (and don't try: we've already initialized output and logging --- channels, signal handlers, your application context, etc). --- --- @ --- main :: 'IO' () --- main = 'execute' $ do --- -- now in the Program monad --- 'write' "Hello there" --- --- 'liftIO' $ do --- -- now something in IO --- source <- readFile "hello.c" --- -- log that we're starting compile ... FIXME how??? --- result <- compileSourceCode source --- case result of --- Right object -> linkObjectCode object --- Left err -> -- debug the error ... FIXME how??? --- --- -- back in Program monad --- 'write' \"Finished\" --- @ --- --- We have a problem, because what we'd like to do is use, say, 'debug' to log --- the compiler error, but we have no way to unlift back out of 'IO' to get to --- the 'Program' monad. --- --- To workaround this, we offer 'withContext'. It gives you a function that --- you can then use within your lifted 'IO' to run a (sub)'Program' action: --- --- @ --- main :: 'IO' () --- main = 'execute' $ do --- -- now in the Program monad --- 'write' "Hello there" --- --- 'withContext' $ \\runProgram -> do --- -- now lifted to IO --- source <- readFile "hello.c" --- --- runProgram $ do --- -- now \"unlifted\" back to Program monad! --- 'event' \"Starting compile...\" --- 'event' \"Nah. Changed our minds\" --- 'event' \"Ok, fine, compile the thing\" --- --- -- more IO --- result <- compileSourceCode source --- case result of --- 'Right' object -> linkObjectCode object --- 'Left' err -> runProgram ('debugS' err) --- --- -- back in Program monad --- 'write' \"Finished\" --- @ --- --- Sometimes Haskell type inference can give you trouble because it tends to --- assume you mean what you say with the last statement of do-notation block. --- If you've got the type wrong you'll get an error, but in an odd place, --- probably at the top where you have the lambda. This can be confusing. If --- you're having trouble with the types try putting @return ()@ at the end of --- your subprogram. -module Core.Program.Unlift - ( -- * Unlifting +{- | +The 'Program' monad is an instance of 'MonadIO', which makes sense; it's +just a wrapper around doing 'IO' and you call it using +'execute' from the top-level @main@ action that is the +entrypoint to any program. So when you need to actually do some I/O or +interact with other major libraries in the Haskell ecosystem, you need to +get back to 'IO' and you use 'liftIO' to do it: + +@ +main :: 'IO' () +main = 'execute' $ do + -- now in the Program monad + 'write' "Hello there" + + 'liftIO' $ do + -- now something in IO + source <- readFile "hello.c" + compileSourceCode source + + -- back in Program monad + 'write' \"Finished\" +@ + +and this is a perfectly reasonable pattern. + +Sometimes, however, you want to get to the 'Program' monad from /there/, +and that's tricky; you can't just 'execute' a new +program (and don't try: we've already initialized output and logging +channels, signal handlers, your application context, etc). + +@ +main :: 'IO' () +main = 'execute' $ do + -- now in the Program monad + 'write' "Hello there" + + 'liftIO' $ do + -- now something in IO + source <- readFile "hello.c" + -- log that we're starting compile ... FIXME how??? + result <- compileSourceCode source + case result of + Right object -> linkObjectCode object + Left err -> -- debug the error ... FIXME how??? + + -- back in Program monad + 'write' \"Finished\" +@ + +We have a problem, because what we'd like to do is use, say, 'debug' to log +the compiler error, but we have no way to unlift back out of 'IO' to get to +the 'Program' monad. + +To workaround this, we offer 'withContext'. It gives you a function that +you can then use within your lifted 'IO' to run a (sub)'Program' action: + +@ +main :: 'IO' () +main = 'execute' $ do + -- now in the Program monad + 'write' "Hello there" + + 'withContext' $ \\runProgram -> do + -- now lifted to IO + source <- readFile "hello.c" + + runProgram $ do + -- now \"unlifted\" back to Program monad! + 'event' \"Starting compile...\" + 'event' \"Nah. Changed our minds\" + 'event' \"Ok, fine, compile the thing\" + + -- more IO + result <- compileSourceCode source + case result of + 'Right' object -> linkObjectCode object + 'Left' err -> runProgram ('debugS' err) + + -- back in Program monad + 'write' \"Finished\" +@ + +Sometimes Haskell type inference can give you trouble because it tends to +assume you mean what you say with the last statement of do-notation block. +If you've got the type wrong you'll get an error, but in an odd place, +probably at the top where you have the lambda. This can be confusing. If +you're having trouble with the types try putting @return ()@ at the end of +your subprogram. +-} +module Core.Program.Unlift ( + -- * Unlifting withContext, -- * Internals getContext, subProgram, - ) -where +) where import Core.Program.Context import Core.Program.Execute import Core.Program.Logging import Core.System.Base --- | --- This gives you a function that you can use within your lifted 'IO' actions --- to return to the 'Program' monad. --- --- The type signature of this function is a bit involved, but the example below --- shows that the lambda gives you a /function/ as its argument (we recommend --- you name it @__runProgram__@ for consistency) which gives you a way to run a --- subprogram, be that a single action like writing to terminal or logging, or --- a larger action in a do-notation block: --- --- @ --- main :: IO () --- main = 'execute' $ do --- 'withContext' $ \\runProgram -> do --- -- in IO monad, lifted --- -- (just as if you had used liftIO) --- --- ... --- --- runProgram $ do --- -- now unlifted, back to Program monad --- --- ... --- @ --- --- Think of this as 'liftIO' with an escape hatch. --- --- This function is named 'withContext' because it is a convenience around the --- following pattern: --- --- @ --- context <- 'getContext' --- liftIO $ do --- ... --- 'subProgram' context $ do --- -- now in Program monad --- ... --- @ +{- | +This gives you a function that you can use within your lifted 'IO' actions +to return to the 'Program' monad. +The type signature of this function is a bit involved, but the example below +shows that the lambda gives you a /function/ as its argument (we recommend +you name it @__runProgram__@ for consistency) which gives you a way to run a +subprogram, be that a single action like writing to terminal or logging, or +a larger action in a do-notation block: + +@ +main :: IO () +main = 'execute' $ do + 'withContext' $ \\runProgram -> do + -- in IO monad, lifted + -- (just as if you had used liftIO) + + ... + + runProgram $ do + -- now unlifted, back to Program monad + + ... +@ + +Think of this as 'liftIO' with an escape hatch. + +This function is named 'withContext' because it is a convenience around the +following pattern: + +@ + context <- 'getContext' + liftIO $ do + ... + 'subProgram' context $ do + -- now in Program monad + ... +@ +-} + -- I think I just discovered the same pattern as **unliftio**? Certainly -- the signature is similar. I'm not sure if there is any benefit to -- restating this as a `withRunInIO` action; we're deliberately trying to -- constrain the types. withContext :: - ((forall β. Program τ β -> IO β) -> IO α) -> - Program τ α + ((forall β. Program τ β -> IO β) -> IO α) -> + Program τ α withContext action = do - context <- getContext - let runThing = subProgram context - liftIO (action runThing) + context <- getContext + let runThing = subProgram context + liftIO (action runThing) diff --git a/lib/Core/System/Base.hs b/lib/Core/System/Base.hs --- a/lib/Core/System/Base.hs +++ b/lib/Core/System/Base.hs @@ -2,9 +2,11 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_HADDOCK not-home #-} --- | Re-exports of Haskell base and GHC system libraries. -module Core.System.Base - ( -- * Input/Output +{- | +Re-exports of Haskell base and GHC system libraries. +-} +module Core.System.Base ( + -- * Input/Output -- ** from Control.Monad.IO.Class @@ -36,18 +38,17 @@ bracket, catch, finally, - ) -where +) where -import Control.Exception.Safe - ( Exception (..), +import Control.Exception.Safe ( + Exception (..), SomeException, bracket, catch, finally, impureThrow, throw, - ) + ) import Control.Monad.IO.Class (MonadIO, liftIO) import System.IO (Handle, IOMode (..), hFlush, stderr, stdin, stdout, withFile) import System.IO.Unsafe (unsafePerformIO) diff --git a/lib/Core/System/External.hs b/lib/Core/System/External.hs --- a/lib/Core/System/External.hs +++ b/lib/Core/System/External.hs @@ -1,15 +1,16 @@ {-# OPTIONS_HADDOCK not-home #-} --- | Re-exports of dependencies from various external libraries. -module Core.System.External - ( -- * Time +{- | +Re-exports of dependencies from various external libraries. +-} +module Core.System.External ( + -- * Time -- ** from Chrono.TimeStamp -- | Re-exported from "Chrono.TimeStamp" in __chronologique__: TimeStamp (..), getCurrentTimeNanoseconds, - ) -where +) where import Chrono.TimeStamp (TimeStamp (..), getCurrentTimeNanoseconds) diff --git a/lib/Core/System/Pretty.hs b/lib/Core/System/Pretty.hs --- a/lib/Core/System/Pretty.hs +++ b/lib/Core/System/Pretty.hs @@ -1,14 +1,12 @@ {-# OPTIONS_HADDOCK not-home #-} -- | Re-exports of combinators for use when building 'Render' instances. -module Core.System.Pretty - ( -- * Pretty Printing +module Core.System.Pretty ( + -- * Pretty Printing -- ** from Data.Text.Prettyprint.Doc - -- | Re-exported from "Data.Text.Prettyprint.Doc" in __prettyprinter__ - -- and "Data.Text.Prettyprint.Doc.Render.Terminal" in - -- __prettyprinter-ansi-terminal__: + -- | Re-exported from "Data.Text.Prettyprint.Doc" in __prettyprinter__ and "Data.Text.Prettyprint.Doc.Render.Terminal" in __prettyprinter-ansi-terminal__: Doc, Pretty (pretty), dquote, @@ -44,7 +42,6 @@ indent, nest, concatWith, - ) -where +) where import Data.Text.Prettyprint.Doc