diff --git a/core-program.cabal b/core-program.cabal --- a/core-program.cabal +++ b/core-program.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 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 -maintainer: Andrew Cowie +author: Andrew Cowie +maintainer: Andrew Cowie 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 diff --git a/lib/Core/Program.hs b/lib/Core/Program.hs --- a/lib/Core/Program.hs +++ b/lib/Core/Program.hs @@ -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 - diff --git a/lib/Core/Program/Arguments.hs b/lib/Core/Program/Arguments.hs --- a/lib/Core/Program/Arguments.hs +++ b/lib/Core/Program/Arguments.hs @@ -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 diff --git a/lib/Core/Program/Context.hs b/lib/Core/Program/Context.hs --- a/lib/Core/Program/Context.hs +++ b/lib/Core/Program/Context.hs @@ -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 diff --git a/lib/Core/Program/Execute.hs b/lib/Core/Program/Execute.hs --- a/lib/Core/Program/Execute.hs +++ b/lib/Core/Program/Execute.hs @@ -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" diff --git a/lib/Core/Program/Logging.hs b/lib/Core/Program/Logging.hs --- a/lib/Core/Program/Logging.hs +++ b/lib/Core/Program/Logging.hs @@ -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')) diff --git a/lib/Core/Program/Metadata.hs b/lib/Core/Program/Metadata.hs --- a/lib/Core/Program/Metadata.hs +++ b/lib/Core/Program/Metadata.hs @@ -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 diff --git a/lib/Core/Program/Notify.hs b/lib/Core/Program/Notify.hs --- a/lib/Core/Program/Notify.hs +++ b/lib/Core/Program/Notify.hs @@ -1,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 diff --git a/lib/Core/Program/Signal.hs b/lib/Core/Program/Signal.hs --- a/lib/Core/Program/Signal.hs +++ b/lib/Core/Program/Signal.hs @@ -1,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 () diff --git a/lib/Core/Program/Unlift.hs b/lib/Core/Program/Unlift.hs --- a/lib/Core/Program/Unlift.hs +++ b/lib/Core/Program/Unlift.hs @@ -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) diff --git a/lib/Core/System.hs b/lib/Core/System.hs --- a/lib/Core/System.hs +++ b/lib/Core/System.hs @@ -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 - diff --git a/lib/Core/System/Base.hs b/lib/Core/System/Base.hs --- a/lib/Core/System/Base.hs +++ b/lib/Core/System/Base.hs @@ -2,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) - diff --git a/lib/Core/System/External.hs b/lib/Core/System/External.hs --- a/lib/Core/System/External.hs +++ b/lib/Core/System/External.hs @@ -1,15 +1,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) diff --git a/lib/Core/System/Pretty.hs b/lib/Core/System/Pretty.hs --- a/lib/Core/System/Pretty.hs +++ b/lib/Core/System/Pretty.hs @@ -1,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