core-program 0.2.6.0 → 0.2.7.1
raw patch · 12 files changed
+2098/−1965 lines, 12 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Core.Program.Execute: fork :: Program τ α -> Program τ (Thread α)
+ Core.Program.Execute: forkThread :: Program τ α -> Program τ (Thread α)
+ Core.Program.Execute: resetTimer :: Program τ ()
+ Core.Program.Execute: waitThread :: Thread α -> Program τ α
+ Core.Program.Execute: waitThread_ :: Thread α -> Program τ ()
Files
- core-program.cabal +4/−4
- lib/Core/Program/Arguments.hs +861/−846
- lib/Core/Program/Context.hs +226/−220
- lib/Core/Program/Execute.hs +424/−327
- lib/Core/Program/Logging.hs +273/−261
- lib/Core/Program/Metadata.hs +106/−105
- lib/Core/Program/Notify.hs +14/−13
- lib/Core/Program/Signal.hs +35/−34
- lib/Core/Program/Unlift.hs +136/−135
- lib/Core/System/Base.hs +9/−8
- lib/Core/System/External.hs +6/−5
- lib/Core/System/Pretty.hs +4/−7
core-program.cabal view
@@ -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 <istathar@gmail.com> maintainer: Andrew Cowie <istathar@gmail.com>-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
lib/Core/Program/Arguments.hs view
@@ -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
lib/Core/Program/Context.hs view
@@ -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
lib/Core/Program/Execute.hs view
@@ -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"
lib/Core/Program/Logging.hs view
@@ -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'))
lib/Core/Program/Metadata.hs view
@@ -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
lib/Core/Program/Notify.hs view
@@ -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
lib/Core/Program/Signal.hs view
@@ -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 ()
lib/Core/Program/Unlift.hs view
@@ -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)
lib/Core/System/Base.hs view
@@ -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)
lib/Core/System/External.hs view
@@ -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)
lib/Core/System/Pretty.hs view
@@ -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