core-program 0.2.4.5 → 0.2.5.0
raw patch · 14 files changed
+2290/−2288 lines, 14 filesdep ~hashabledep ~prettyprinterPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: hashable, prettyprinter
API changes (from Hackage documentation)
Files
- core-program.cabal +7/−7
- lib/Core/Program.hs +38/−40
- lib/Core/Program/Arguments.hs +854/−861
- lib/Core/Program/Context.hs +242/−233
- lib/Core/Program/Execute.hs +390/−396
- lib/Core/Program/Logging.hs +279/−287
- lib/Core/Program/Metadata.hs +117/−122
- lib/Core/Program/Notify.hs +50/−45
- lib/Core/Program/Signal.hs +34/−28
- lib/Core/Program/Unlift.hs +141/−142
- lib/Core/System.hs +36/−40
- lib/Core/System/Base.hs +44/−30
- lib/Core/System/External.hs +9/−9
- lib/Core/System/Pretty.hs +49/−48
core-program.cabal view
@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 8dc61390fa8f607454dee014554b87586d09684c923fab5e4dfe28a48763a18e+-- hash: a518f4719d8c63a92778aeb8d0dac45fd444d9db8f61c148b0f486cc9d993ab9 name: core-program-version: 0.2.4.5+version: 0.2.5.0 synopsis: Opinionated Haskell Interoperability description: A library to help build command-line programs, both tools and longer-running daemons.@@ -22,12 +22,12 @@ stability: experimental homepage: https://github.com/aesiniath/unbeliever#readme bug-reports: https://github.com/aesiniath/unbeliever/issues-author: Andrew Cowie <andrew@operationaldynamics.com>-maintainer: Andrew Cowie <andrew@operationaldynamics.com>+author: Andrew Cowie <istathar@gmail.com>+maintainer: Andrew Cowie <istathar@gmail.com> copyright: © 2018-2020 Athae Eredh Siniath and Others license: BSD3 license-file: LICENSE-tested-with: GHC == 8.8.3+tested-with: GHC == 8.8.4 build-type: Simple source-repository head@@ -64,10 +64,10 @@ , exceptions , filepath , fsnotify- , hashable >=1.2 && <1.4+ , hashable >=1.2 , hourglass , mtl- , prettyprinter >=1.2.1.1 && <1.8+ , prettyprinter >=1.2.1.1 , prettyprinter-ansi-terminal , safe-exceptions , stm
lib/Core/Program.hs view
@@ -1,54 +1,52 @@ {-# OPTIONS_HADDOCK not-home #-} -{-|-Support for building command-line programs, ranging from simple tools to-long-running daemons.+-- actually, they're there to group implementation too, but hey. -This is intended to be used directly:+-- |+-- Support for building command-line programs, ranging from simple tools to+-- long-running daemons.+--+-- This is intended to be used directly:+--+-- @+-- import "Core.Program"+-- @+--+-- the submodules are mostly there to group documentation.+module Core.Program+ ( -- * Executing a program -@-import "Core.Program"-@+ -- |+ -- A top-level Program type giving you unified access to logging, concurrency,+ -- and more.+ module Core.Program.Execute,+ module Core.Program.Unlift,+ module Core.Program.Metadata, -the submodules are mostly there to group documentation.--}--- actually, they're there to group implementation too, but hey.-module Core.Program- (- {-* Executing a program -}-{-|-A top-level Program type giving you unified access to logging, concurrency,-and more.--}- module Core.Program.Execute- , module Core.Program.Unlift- , module Core.Program.Metadata+ -- * Command-line argument parsing - {-* Command-line argument parsing -}-{-|-Including declaring what options your program accepts, generating help, and-for more complex cases [sub]commands, mandatory arguments, and environment-variable handling.--}- , module Core.Program.Arguments- {-* Logging facilities -}-{-|-Facilities for noting events through your program and doing debugging.--}- , module Core.Program.Logging+ -- |+ -- Including declaring what options your program accepts, generating help, and+ -- for more complex cases [sub]commands, mandatory arguments, and environment+ -- variable handling.+ module Core.Program.Arguments, -{-|-There are a few common use cases which require a bit of wrapping to use-effectively. Watching files for changes and taking action in the event of a-change is one.--}- , module Core.Program.Notify- ) where+ -- * Logging facilities + -- |+ -- Facilities for noting events through your program and doing debugging.+ module Core.Program.Logging,+ -- |+ -- There are a few common use cases which require a bit of wrapping to use+ -- effectively. Watching files for changes and taking action in the event of a+ -- change is one.+ module Core.Program.Notify,+ )+where+ import Core.Program.Arguments import Core.Program.Execute import Core.Program.Logging import Core.Program.Metadata import Core.Program.Notify import Core.Program.Unlift-
lib/Core/Program/Arguments.hs view
@@ -1,861 +1,854 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveFunctor #-}-{-# 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 Control.Exception.Safe (Exception(displayException))-import Data.Hashable (Hashable)-import qualified Data.List as List-import Data.Maybe (fromMaybe)-import Data.Text.Prettyprint.Doc (Doc, Pretty(..), nest, fillCat- , emptyDoc, hardline, softline, fillBreak, align, (<+>), fillSep, indent)-import Data.Text.Prettyprint.Doc.Util (reflow)-import Data.String-import System.Environment (getProgName)--import Core.Data.Structures-import Core.System.Base-import Core.Text.Rope-import Core.Text.Utilities-import Core.Program.Metadata--{-|-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- = InvalidOption String {-^ Something was wrong with the way the user specified [usually a short] option. -}- | UnknownOption String {-^ User specified an option that doesn't match any in the supplied configuration. -}- | MissingArgument LongName- {-^ Arguments are mandatory, and this one is missing. -}- | UnexpectedArguments [String]- {-^ Arguments are present we weren't expecting. -}- | UnknownCommand String {-^ In a complex configuration, user specified a command that doesn't match any in the configuration. -}- | NoCommandFound {-^ In a complex configuration, user didn't specify a command. -}- | HelpRequest (Maybe LongName)- {-^ In a complex configuration, usage information was requested with @--help@, either globally or for the supplied command. -}- | VersionRequest- {-^ Display of the program version requested with @--version@. -}- 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-+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# 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 Control.Exception.Safe (Exception (displayException))+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
lib/Core/Program/Context.hs view
@@ -1,59 +1,57 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StrictData #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} -- This is an Internal module, hidden from Haddock module Core.Program.Context- (- Context(..)- , None(..)- , isNone- , configure- , Message(..)- , Verbosity(..)- , Program(..)- , unProgram- , getContext- , subProgram- ) where+ ( Context (..),+ None (..),+ isNone,+ configure,+ Message (..),+ Verbosity (..),+ Program (..),+ unProgram,+ getContext,+ fmapContext,+ subProgram,+ )+where -import Prelude hiding (log) import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds)-import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar)+import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, readMVar) import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO)-import Control.Exception.Safe (displayException)-import qualified Control.Exception.Safe as Safe (throw, catch)-import Control.Monad.Catch (MonadThrow(throwM), MonadCatch(catch))-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Reader.Class (MonadReader(..))-import Control.Monad.Trans.Reader (ReaderT(..))+import qualified Control.Exception.Safe as Safe (catch, throw)+import Control.Monad.Catch (MonadCatch (catch), MonadThrow (throwM))+import Control.Monad.Reader.Class (MonadReader (..))+import Control.Monad.Trans.Reader (ReaderT (..))+import Core.Data.Structures+import Core.Program.Arguments+import Core.Program.Metadata+import Core.System.Base hiding (catch, throw)+import Core.Text.Rope import Data.Foldable (foldrM)-import Data.Text.Prettyprint.Doc (layoutPretty, LayoutOptions(..), PageWidth(..))+import Data.Text.Prettyprint.Doc (LayoutOptions (..), PageWidth (..), layoutPretty) import Data.Text.Prettyprint.Doc.Render.Text (renderIO)-import qualified System.Console.Terminal.Size as Terminal (Window(..), size)+import qualified System.Console.Terminal.Size as Terminal (Window (..), size) import System.Environment (getArgs, getProgName, lookupEnv)-import System.Exit (ExitCode(..), exitWith)+import System.Exit (ExitCode (..), exitWith)+import Prelude hiding (log) -import Core.Data.Structures-import Core.System.Base hiding (throw, catch)-import Core.Text.Rope-import Core.Program.Arguments-import Core.Program.Metadata+-- |+-- 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, -- certainly, here in the record type definition and when setting@@ -72,120 +70,131 @@ -- bare fieldName because so often you have want to be able to use -- that field name as a local variable name. ---data Context τ = Context {- programNameFrom :: MVar Rope- , versionFrom :: Version- , commandLineFrom :: Parameters- , exitSemaphoreFrom :: MVar ExitCode- , startTimeFrom :: TimeStamp- , terminalWidthFrom :: Int- , verbosityLevelFrom :: MVar Verbosity- , outputChannelFrom :: TQueue Rope- , loggerChannelFrom :: TQueue Message- , applicationDataFrom :: MVar τ-}+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 τ+ } -{-|-A 'Program' with no user-supplied state to be threaded throughout the-computation.+-- 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 -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.+-- |+-- 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}) -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--{-|-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/+ deriving (Show) -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+ runReaderT r context -- -- This is complicated. The **safe-exceptions** library exports a@@ -193,85 +202,89 @@ -- 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++-- ** 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.++-- ** 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+ catch :: Exception ε => (Program τ) α -> (ε -> (Program τ) α) -> (Program τ) α+ catch program handler =+ let r = unProgram program h = unHandler handler- in do- context <- ask- liftIO $ do+ 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.+ (runReaderT r context)+ (\e -> runReaderT (h e) context) -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+ 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 = start,+ terminalWidthFrom = columns,+ verbosityLevelFrom = l,+ outputChannelFrom = out,+ loggerChannelFrom = log,+ applicationDataFrom = u+ } --+ -- | Probe the width of the terminal, in characters. If it fails to retrieve, -- for whatever reason, return a default of 80 characters wide.--- getConsoleWidth :: IO (Int) getConsoleWidth = do- window <- Terminal.size- let columns = case window of- Just (Terminal.Window _ w) -> w- Nothing -> 80- return columns+ window <- Terminal.size+ let columns = case window of+ Just (Terminal.Window _ w) -> w+ Nothing -> 80+ return columns --+ -- | Process the command line options and arguments. If an invalid -- option is encountered or a [mandatory] argument is missing, then -- the program will terminate here.---+ {- We came back here with the error case so we can pass config in to buildUsage (otherwise we could have done it all in displayException and@@ -280,71 +293,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+ 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)+ 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+ Just value -> case value of+ Empty -> Right Event+ Value _ -> Left (ExitFailure 2)+ Nothing -> Right Output
lib/Core/Program/Execute.hs view
@@ -1,129 +1,140 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StrictData #-} {-# 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.+-- |+-- 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 (), -/Logging and output/+ -- * Running programs+ configure,+ execute,+ executeWith, -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.+ -- * Exiting a program+ terminate, -/Exceptions/+ -- * Accessing program context+ getCommandLine,+ lookupOptionFlag,+ lookupOptionValue,+ lookupArgument,+ getProgramName,+ setProgramName,+ getVerbosityLevel,+ setVerbosityLevel,+ getConsoleWidth,+ getApplicationState,+ setApplicationState,+ retrieve,+ update, -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.+ -- * Useful actions+ output,+ input, -/Customizing the execution context/+ -- * Concurrency+ Thread,+ fork,+ sleep, -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- , executeWith- {-* Exiting a program -}- , terminate- {-* Accessing program context -}- , getCommandLine- , lookupOptionFlag- , lookupOptionValue- , lookupArgument- , getProgramName- , setProgramName- , getVerbosityLevel- , setVerbosityLevel- , getConsoleWidth- , getApplicationState- , setApplicationState- , retrieve- , update- {-* Useful actions -}- , output- , input- {-* Concurrency -}- , Thread- , fork- , sleep- {-* Internals -}- , Context- , None(..)- , isNone- , unProgram- , unThread- , invalid- ) where+ -- * Internals+ Context,+ None (..),+ isNone,+ unProgram,+ unThread,+ invalid,+ )+where -import Prelude hiding (log) import Control.Concurrent (threadDelay)-import Control.Concurrent.Async (Async, async, link, cancel- , ExceptionInLinkedThread(..), AsyncCancelled, race_)-import Control.Concurrent.MVar (readMVar, putMVar, modifyMVar_)+import Control.Concurrent.Async+ ( Async,+ AsyncCancelled,+ ExceptionInLinkedThread (..),+ async,+ cancel,+ link,+ race_,+ )+import Control.Concurrent.MVar (modifyMVar_, putMVar, readMVar) import Control.Concurrent.STM (atomically, check)-import Control.Concurrent.STM.TQueue (TQueue, readTQueue, isEmptyTQueue)+import Control.Concurrent.STM.TQueue (TQueue, isEmptyTQueue, readTQueue) import qualified Control.Exception as Base (throwIO)-import Control.Exception.Safe (SomeException, Exception(displayException))-import qualified Control.Exception.Safe as Safe (throw, catchesAsync)-import Control.Monad (when, forever)-import Control.Monad.Catch (Handler(..))+import Control.Exception.Safe (Exception (displayException), SomeException)+import qualified Control.Exception.Safe as Safe (catchesAsync, throw)+import Control.Monad (forever, when)+import Control.Monad.Catch (Handler (..)) import Control.Monad.IO.Class (liftIO)-import Control.Monad.Reader.Class (MonadReader(ask))-import qualified Data.ByteString as B (hPut)-import qualified Data.ByteString.Char8 as C (singleton)-import GHC.Conc (numCapabilities, getNumProcessors, setNumCapabilities)-import GHC.IO.Encoding (setLocaleEncoding, utf8)-import System.Exit (ExitCode(..))-import qualified System.Posix.Process as Posix (exitImmediately)-+import Control.Monad.Reader.Class (MonadReader (ask)) import Core.Data.Structures-import Core.Text.Bytes-import Core.Text.Rope-import Core.System.Base+import Core.Program.Arguments import Core.Program.Context import Core.Program.Logging import Core.Program.Signal-import Core.Program.Arguments+import Core.System.Base+import Core.Text.Bytes+import Core.Text.Rope+import qualified Data.ByteString as B (hPut)+import qualified Data.ByteString.Char8 as C (singleton)+import GHC.Conc (getNumProcessors, numCapabilities, setNumCapabilities)+import GHC.IO.Encoding (setLocaleEncoding, utf8)+import System.Exit (ExitCode (..))+import qualified System.Posix.Process as Posix (exitImmediately)+import Prelude hiding (log) -- 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@@ -133,11 +144,11 @@ -- terminate action. -- 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)+escapeHandlers context =+ [ Handler (\(exit :: ExitCode) -> done exit),+ Handler (\(_ :: AsyncCancelled) -> pass),+ Handler (\(ExceptionInLinkedThread _ e) -> bail e),+ Handler (\(e :: SomeException) -> bail e) ] where quit = exitSemaphoreFrom context@@ -147,17 +158,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@@ -169,388 +179,372 @@ -- 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)-- -- force UTF-8 working around bad VMs- setLocaleEncoding utf8+ -- command line +RTS -Nn -RTS value+ when (numCapabilities == 1) (getNumProcessors >>= setNumCapabilities) - let quit = exitSemaphoreFrom context- level = verbosityLevelFrom context- out = outputChannelFrom context- log = loggerChannelFrom context+ -- force UTF-8 working around bad VMs+ setLocaleEncoding utf8 - -- set up standard output- o <- async $ do- Safe.catchesAsync- (processStandardOutput out)- (collapseHandlers)+ let quit = exitSemaphoreFrom context+ level = verbosityLevelFrom context+ out = outputChannelFrom context+ log = loggerChannelFrom context - -- set up debug logger- l <- async $ do- Safe.catchesAsync- (processDebugMessages log)- (collapseHandlers)+ -- set up standard output+ o <- async $ do+ Safe.catchesAsync+ (processStandardOutput out)+ (collapseHandlers) - -- set up signal handlers- _ <- async $ do- setupSignalHandlers quit level+ -- set up debug logger+ l <- async $ do+ Safe.catchesAsync+ (processDebugMessages log)+ (collapseHandlers) - -- run actual program, ensuring to trap uncaught exceptions- m <- async $ do- Safe.catchesAsync- (executeAction context program)- (escapeHandlers context)+ -- set up signal handlers+ _ <- async $ do+ setupSignalHandlers quit level - code <- readMVar quit- cancel m+ -- run actual program, ensuring to trap uncaught exceptions+ m <- async $ do+ Safe.catchesAsync+ (executeAction context program)+ (escapeHandlers context) - -- 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+ code <- readMVar quit+ cancel m - done1 <- isEmptyTQueue out- check done1)- (do- threadDelay 100000- putStrLn "error: Timeout")+ -- 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 - threadDelay 100 -- instead of yield- hFlush stdout+ done1 <- isEmptyTQueue out+ check done1+ )+ ( do+ threadDelay 100000+ putStrLn "error: Timeout"+ ) - cancel l- cancel o+ threadDelay 100 -- instead of yield+ hFlush stdout - -- exiting this way avoids "Exception: ExitSuccess" noise in GHCi- if code == ExitSuccess- then return ()- else (Base.throwIO code)+ cancel l+ cancel o + -- 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+ 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+ 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--{-|-Retreive the current terminal's width, in characters.+ context <- ask+ liftIO $ do+ let v = programNameFrom context+ readMVar v -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--{-|-Get the user supplied application state as originally supplied to-'configure' and modified subsequntly by replacement with-'setApplicationState'.+ context <- ask+ let width = terminalWidthFrom context+ return width -@- 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--{-|-Update the user supplied top-level application state.+ context <- ask+ liftIO $ do+ let v = applicationDataFrom context+ readMVar v -@- 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) -{-|-Alias for 'getApplicationState'.--}+-- |+-- Alias for 'getApplicationState'. retrieve :: Program τ τ retrieve = getApplicationState -{-|-Alias for 'setApplicationState'.--}+-- |+-- Alias for 'setApplicationState'. 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). output :: Handle -> Bytes -> Program τ () output handle contents = liftIO (hOutput handle contents) -{-|-Read the (entire) contents of the specified @Handle@.--}+-- |+-- Read the (entire) contents of the specified @Handle@. input :: Handle -> Program τ Bytes input handle = liftIO (hInput handle) -{-|-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') fork :: Program τ α -> Program τ (Thread α) fork program = do- context <- ask- liftIO $ do- a <- async $ do- subProgram context program- link a- return (Thread a)--{-|-Pause the current thread for the given number of seconds. For-example, to delay a second and a half, do:+ context <- ask+ liftIO $ do+ a <- async $ do+ subProgram context program+ link a+ return (Thread a) -@- 'sleep' 1.5-@+-- |+-- 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') -(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--{-|-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?"+ let us = floor (toRational (seconds * 1e6))+ in liftIO $ threadDelay us -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).--}+-- |+-- 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
@@ -1,358 +1,350 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# 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.+-- |+-- 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 (..), -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.+ -- * Normal output+ write,+ writeS,+ writeR, -== Logging channel+ -- * Event tracing+ event, -/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 -}- , write- , writeS- , writeR- {-* Event tracing -}- , event- {-* Debugging -}- , debug- , debugS- , debugR- ) where+ -- * Debugging+ debug,+ debugS,+ debugR,+ )+where -import Chrono.TimeStamp (TimeStamp(..), getCurrentTimeNanoseconds)+import Chrono.TimeStamp (TimeStamp (..), getCurrentTimeNanoseconds) import Control.Concurrent.MVar (readMVar) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TQueue (writeTQueue) import Control.Exception (evaluate) import Control.Monad (when)-import Control.Monad.Reader.Class (MonadReader(ask))-import Data.Fixed-import Data.Hourglass (timePrint, TimeFormatElem(..))-import qualified Data.Text.Short as S (replicate)-+import Control.Monad.Reader.Class (MonadReader (ask))+import Core.Program.Context+import Core.System.Base import Core.Text.Rope import Core.Text.Utilities-import Core.System.Base-import Core.Program.Context+import Data.Fixed+import Data.Hourglass (TimeFormatElem (..), timePrint)+import qualified Data.Text.Short as S (replicate) {- class Monad m => MonadLog a m where- logMessage :: Monoid a => Severity -> a -> m () + logMessage :: Monoid a => Severity -> a -> m () -} 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 display = case potentialValue of- Just value ->- if containsCharacter '\n' value- then text <> " =\n" <> value- else text <> " = " <> value- Nothing -> text+ let start = startTimeFrom context+ let output = outputChannelFrom context+ let logger = loggerChannelFrom context - let result = formatLogMessage start now display+ let display = case potentialValue of+ Just value ->+ if containsCharacter '\n' value+ then text <> " =\n" <> value+ else text <> " = " <> value+ Nothing -> text - atomically $ do- writeTQueue output result- writeTQueue logger message+ let result = formatLogMessage start now display + 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 9 (show elapsed),+ ") ",+ message ] ------ | Utility function to prepend \'0\' characters to a string representing a+-- |+-- 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-- !text' <- evaluate text- atomically (writeTQueue out text')+ context <- ask+ liftIO $ do+ let out = outputChannelFrom context -{-|-Call 'show' on the supplied argument and write the resultant text to-@stdout@.+ !text' <- evaluate text+ atomically (writeTQueue out text') -(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-- 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...+ context <- ask+ liftIO $ do+ let out = outputChannelFrom context+ let columns = terminalWidthFrom context -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).+ let text = render columns thing+ !text' <- evaluate text+ atomically (writeTQueue out text') -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 (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. 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 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.+ Output -> False+ Event -> False+ Debug -> True -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 (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. 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-- let columns = terminalWidthFrom context+ context <- ask+ liftIO $ do+ level <- readMVar (verbosityLevelFrom context)+ when (isDebug level) $ do+ now <- getCurrentTimeNanoseconds - -- 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'))+ 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'))
lib/Core/Program/Metadata.hs view
@@ -1,127 +1,126 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE OverloadedStrings #-}--{-|-Dig metadata out of the description of your project.+{-# LANGUAGE TemplateHaskell #-} -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.--}+-- |+-- 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- {-* Internals -}- , versionNumberFrom- , projectNameFrom- , projectSynopsisFrom-)+ ( Version,++ -- * Splice+ fromPackage,++ -- * Internals+ versionNumberFrom,+ projectNameFrom,+ projectSynopsisFrom,+ ) where import Core.Data+import Core.System (IOMode (..), withFile) import Core.Text-import Core.System (withFile, IOMode(..)) import Data.List (intersperse)-import qualified Data.List as List (isSuffixOf, find)+import qualified Data.List as List (find, isSuffixOf) import Data.Maybe (fromMaybe) import Data.String import Language.Haskell.TH (Q, runIO)-import Language.Haskell.TH.Syntax (Lift, Exp(..))+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.--}-data Version = Version {- projectNameFrom :: String- , projectSynopsisFrom :: String- , versionNumberFrom :: String-} deriving (Show, Lift)+-- |+-- 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) emptyVersion :: Version emptyVersion = Version "" "" "0" instance IsString Version where- 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' ...-@+ fromString x = emptyVersion {versionNumberFrom = x} -(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-- let name = fromMaybe "" . lookupKeyValue "name" $ pairs- let synopsis = fromMaybe "" . lookupKeyValue "synopsis" $ pairs- let version = fromMaybe "" . lookupKeyValue "version" $ pairs+ pairs <- readCabalFile - let result = Version- { projectNameFrom = fromRope name- , projectSynopsisFrom = fromRope synopsis- , versionNumberFrom = fromRope version- }+ let name = fromMaybe "" . lookupKeyValue "name" $ pairs+ let synopsis = fromMaybe "" . lookupKeyValue "synopsis" $ pairs+ let version = fromMaybe "" . lookupKeyValue "version" $ pairs --- I would have preferred------ let e = AppE (VarE ...--- return e------ but that's not happening. So more voodoo TH nonsense instead.+ let result =+ Version+ { projectNameFrom = fromRope name,+ projectSynopsisFrom = fromRope synopsis,+ versionNumberFrom = fromRope version+ } - [e|result|]+ -- I would have preferred+ --+ -- let e = AppE (VarE ...+ -- return e+ --+ -- but that's not happening. So more voodoo TH nonsense instead. + [e|result|] {- Locate the .cabal file in the present working directory (assumed to be the@@ -131,40 +130,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 :: (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,34 +1,32 @@ {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK prune #-} -{-|-Helpers for watching files for changes and taking action in the event of a-change.--}+-- |+-- Helpers for watching files for changes and taking action in the event of a+-- change. module Core.Program.Notify- ( {-* Notify -}- waitForChange- ) where+ ( -- * Notify+ waitForChange,+ )+where import Control.Concurrent.MVar (newEmptyMVar, putMVar, readMVar)-import Data.Foldable (foldr, foldrM)-import System.FilePath (dropFileName)-import System.FSNotify (Event(..), withManager, watchDir, eventPath)-+import Control.Monad.IO.Class (liftIO) import Core.Data.Structures import Core.Program.Execute import Core.Program.Logging import Core.Program.Unlift-+import Data.Foldable (foldr, foldrM) import System.Directory (canonicalizePath)-import Control.Monad.IO.Class (liftIO)+import System.FSNotify (Event (..), eventPath, watchDir, withManager)+import System.FilePath (dropFileName) -{-|-Watch for changes to a given list of files.+-- |+-- 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. -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 -- doesn't work when programs like vim move the original file, save a new one,@@ -41,38 +39,45 @@ -- waitForChange :: [FilePath] -> Program τ () waitForChange files =- let- f :: FilePath -> Set FilePath -> Set FilePath- f path acc = insertElement path acc+ let f :: FilePath -> Set FilePath -> Set FilePath+ f path acc = insertElement path acc - g :: FilePath -> Set FilePath -> Set FilePath- g path acc = insertElement (dropFileName path) acc- in do- event "Watching for changes"+ g :: FilePath -> Set FilePath -> Set FilePath+ g path acc = insertElement (dropFileName path) acc+ in do+ event "Watching for changes" - canonical <- mapM (liftIO . canonicalizePath) files- let paths = foldr f emptySet canonical- let dirs = foldr g emptySet files+ canonical <- mapM (liftIO . canonicalizePath) files+ let paths = foldr f emptySet canonical+ let dirs = foldr g emptySet files - withContext $ \runProgram -> do- block <- newEmptyMVar- withManager $ \manager -> do+ withContext $ \runProgram -> do+ block <- newEmptyMVar+ withManager $ \manager -> do -- setup watches- stoppers <- foldrM (\dir acc -> do- runProgram (debugS "watching" dir)- stopper <- watchDir manager dir- (\trigger -> case trigger of- Modified file _ _ -> do- if containsElement file paths+ stoppers <-+ foldrM+ ( \dir acc -> do+ runProgram (debugS "watching" dir)+ stopper <-+ watchDir+ manager+ dir+ ( \trigger -> case trigger of+ Modified file _ _ -> do+ if containsElement file paths then True else False- _ -> False- )- (\trigger -> do- runProgram (debugS "trigger" (eventPath trigger))- putMVar block False- )- return (stopper:acc)) [] dirs+ _ -> False+ )+ ( \trigger -> do+ runProgram (debugS "trigger" (eventPath trigger))+ putMVar block False+ )+ return (stopper : acc)+ )+ []+ dirs -- wait _ <- readMVar block@@ -80,4 +85,4 @@ sequence_ stoppers return () - sleep 0.1+ sleep 0.1
lib/Core/Program/Signal.hs view
@@ -1,26 +1,29 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} module Core.Program.Signal-(- setupSignalHandlers-)+ ( setupSignalHandlers,+ ) where -import Control.Concurrent.MVar (MVar, putMVar, modifyMVar_)-import Foreign.C.Types (CInt)-import System.Exit (ExitCode(..))-import System.IO (hPutStrLn, hFlush, stdout)-import System.Posix.Signals (Handler(Catch), installHandler,- sigINT, sigTERM, sigUSR1)-+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),+ 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.--- code :: CInt -> ExitCode code signal = ExitFailure (128 + fromIntegral signal) @@ -32,32 +35,35 @@ 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.--- 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
@@ -1,160 +1,159 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# 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.--}+-- |+-- 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+ ( -- * Unlifting+ withContext, + -- * Internals+ getContext,+ subProgram,+ )+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:+-- |+-- 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+-- ...+-- @ -@- 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 τ α+withContext ::+ ((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.hs view
@@ -1,51 +1,47 @@ {-# OPTIONS_HADDOCK not-home #-} -{-|-Common elements from the rest of the Haskell ecosystem. This is mostly-about re-exports. There are numerous types and functions that are more or-less assumed to be in scope when you're doing much of anything in Haskell;-this module is a convenience to pull in the ones we rely on for the rest of-this library.--You can just import this directly:--@-import "Core.System"-@+-- |+-- Common elements from the rest of the Haskell ecosystem. This is mostly+-- about re-exports. There are numerous types and functions that are more or+-- less assumed to be in scope when you're doing much of anything in Haskell;+-- this module is a convenience to pull in the ones we rely on for the rest of+-- this library.+--+-- You can just import this directly:+--+-- @+-- import "Core.System"+-- @+--+-- as there's no particular benefit to cherry-picking the various sub-modules.+module Core.System+ ( -- * Base libraries -as there's no particular benefit to cherry-picking the various sub-modules.+ -- |+ -- Re-exports from foundational libraries supplied by the compiler runtime,+ -- or from re-implementations of those areas.+ module Core.System.Base, --}-module Core.System- (- {-* Base libraries -}-{-|-Re-exports from foundational libraries supplied by the compiler runtime,-or from re-implementations of those areas.--}- module Core.System.Base+ -- * External dependencies - {-* External dependencies -}-{-|-Dependencies from libraries outside the traditional ecosystem of Haskell.-These are typically special cases or custom re-implementations of things-which are maintained either by ourselves or people we are in regular-contact with.--}- , module Core.System.External+ -- |+ -- Dependencies from libraries outside the traditional ecosystem of Haskell.+ -- These are typically special cases or custom re-implementations of things+ -- which are maintained either by ourselves or people we are in regular+ -- contact with.+ module Core.System.External, - {-* Pretty Printing -}-{-|-When using the Render typeclass from "Core.Text.Utilities" you are-presented with the @Doc a@ type for accumulating a \"document\" to be-pretty printed. There are a large family of combinators used when doing-this. For convenience they are exposed here.--}- , module Core.System.Pretty+ -- * Pretty Printing - ) where+ -- |+ -- When using the Render typeclass from "Core.Text.Utilities" you are+ -- presented with the @Doc a@ type for accumulating a \"document\" to be+ -- pretty printed. There are a large family of combinators used when doing+ -- this. For convenience they are exposed here.+ module Core.System.Pretty,+ )+where import Core.System.Base import Core.System.External import Core.System.Pretty-
lib/Core/System/Base.hs view
@@ -2,38 +2,52 @@ {-# 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 -}- {-** from Control.Monad.IO.Class -}- {-| Re-exported from "Control.Monad.IO.Class" in __base__: -}- liftIO- , MonadIO- {-** from System.IO -}- {-| Re-exported from "System.IO" in __base__: -}- , Handle- , IOMode(..)- , withFile- , stdin, stdout, stderr- , hFlush- , unsafePerformIO- {-* Exception handling -}- {-** from Control.Exception.Safe -}- {-| Re-exported from "Control.Exception.Safe" in the __safe-exceptions__ package: -}- , Exception(..)- , SomeException- , throw- , impureThrow- , bracket- , catch- , finally- ) where+ ( -- * Input/Output -import Control.Exception.Safe (Exception(..), SomeException, throw- , bracket, catch, finally, impureThrow)+ -- ** from Control.Monad.IO.Class++ -- | Re-exported from "Control.Monad.IO.Class" in __base__:+ liftIO,+ MonadIO,++ -- ** from System.IO++ -- | Re-exported from "System.IO" in __base__:+ Handle,+ IOMode (..),+ withFile,+ stdin,+ stdout,+ stderr,+ hFlush,+ unsafePerformIO,++ -- * Exception handling++ -- ** from Control.Exception.Safe++ -- | Re-exported from "Control.Exception.Safe" in the __safe-exceptions__ package:+ Exception (..),+ SomeException,+ throw,+ impureThrow,+ bracket,+ catch,+ finally,+ )+where++import Control.Exception.Safe+ ( Exception (..),+ SomeException,+ bracket,+ catch,+ finally,+ impureThrow,+ throw,+ ) import Control.Monad.IO.Class (MonadIO, liftIO)-import System.IO (Handle, IOMode(..), withFile, stdin, stdout, stderr, hFlush)+import System.IO (Handle, IOMode (..), hFlush, stderr, stdin, stdout, withFile) import System.IO.Unsafe (unsafePerformIO)-
lib/Core/System/External.hs view
@@ -1,15 +1,15 @@ {-# OPTIONS_HADDOCK not-home #-} --- -- | 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+ ( -- * Time -import Chrono.TimeStamp (TimeStamp(..), getCurrentTimeNanoseconds)+ -- ** from Chrono.TimeStamp + -- | Re-exported from "Chrono.TimeStamp" in __chronologique__:+ TimeStamp (..),+ getCurrentTimeNanoseconds,+ )+where++import Chrono.TimeStamp (TimeStamp (..), getCurrentTimeNanoseconds)
lib/Core/System/Pretty.hs view
@@ -1,55 +1,56 @@ {-# OPTIONS_HADDOCK not-home #-} --- -- | Re-exports of combinators for use when building 'Render' instances.--- 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__: -}- Doc- , Pretty(pretty)- , dquote- , squote- , comma- , punctuate- , enclose- , lbracket- , rbracket- , (<+>)- , lbrace- , rbrace- , lparen- , rparen- , emptyDoc- , sep- , hsep- , vsep- , fillCat- , fillSep- , flatAlt- , hcat- , vcat- , annotate- , unAnnotate- , line- , line'- , softline- , softline'- , hardline- , group- , hang- , indent- , nest- , concatWith- , color- , colorDull- , Color(..)- , AnsiStyle- , bold- ) where+ ( -- * 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__:+ Doc,+ Pretty (pretty),+ dquote,+ squote,+ comma,+ punctuate,+ enclose,+ lbracket,+ rbracket,+ (<+>),+ lbrace,+ rbrace,+ lparen,+ rparen,+ emptyDoc,+ sep,+ hsep,+ vsep,+ fillCat,+ fillSep,+ flatAlt,+ hcat,+ vcat,+ annotate,+ unAnnotate,+ line,+ line',+ softline,+ softline',+ hardline,+ group,+ hang,+ indent,+ nest,+ concatWith,+ color,+ colorDull,+ Color (..),+ AnsiStyle,+ bold,+ )+where import Data.Text.Prettyprint.Doc import Data.Text.Prettyprint.Doc.Render.Terminal