core-program (empty) → 0.2.0.0
raw patch · 13 files changed
+2718/−0 lines, 13 filesdep +asyncdep +basedep +bytestring
Dependencies added: async, base, bytestring, chronologique, core-data, core-text, directory, exceptions, hashable, hourglass, mtl, prettyprinter, prettyprinter-ansi-terminal, safe-exceptions, stm, template-haskell, terminal-size, text, text-short, transformers, unix
Files
- LICENCE +32/−0
- core-program.cabal +69/−0
- lib/Core/Program.hs +46/−0
- lib/Core/Program/Arguments.hs +841/−0
- lib/Core/Program/Context.hs +346/−0
- lib/Core/Program/Execute.hs +538/−0
- lib/Core/Program/Logging.hs +358/−0
- lib/Core/Program/Metadata.hs +171/−0
- lib/Core/Program/Signal.hs +63/−0
- lib/Core/Program/Unlift.hs +160/−0
- lib/Core/System.hs +40/−0
- lib/Core/System/Base.hs +39/−0
- lib/Core/System/External.hs +15/−0
+ LICENCE view
@@ -0,0 +1,32 @@+Opinionated Haskell Interoperability++Copyright © 2018-2019 Operational Dynamics Consulting, Pty Ltd and Others+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ 1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ 2. Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.+ + 3. Neither the name of the project nor the names of its contributors+ may be used to endorse or promote products derived from this + software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ core-program.cabal view
@@ -0,0 +1,69 @@+cabal-version: 1.12+name: core-program+version: 0.2.0.0+license: BSD3+license-file: LICENCE+copyright: © 2018-2019 Operational Dynamics Consulting Pty Ltd, and Others+maintainer: Andrew Cowie <andrew@operationaldynamics.com>+author: Andrew Cowie <andrew@operationaldynamics.com>+stability: experimental+tested-with: ghc ==8.6.5+homepage: https://github.com/oprdyn/unbeliever#readme+bug-reports: https://github.com/oprdyn/unbeliever/issues+synopsis: Opinionated Haskell Interoperability+description:+ A library to help build command-line programs, both tools and+ longer-running daemons.+ .+ A description of this package, a list of features, and some background+ to its design is contained in the+ <https://github.com/oprdyn/unbeliever/blob/master/README.markdown README>+ on GitHub.+ .+ See "Core.Program.Execute" to get started.+category: System+build-type: Simple++source-repository head+ type: git+ location: https://github.com/oprdyn/unbeliever++library+ exposed-modules:+ Core.Program+ Core.Program.Arguments+ Core.Program.Execute+ Core.Program.Logging+ Core.Program.Metadata+ Core.Program.Unlift+ Core.System+ Core.System.Base+ Core.System.External+ hs-source-dirs: lib+ other-modules:+ Core.Program.Context+ Core.Program.Signal+ default-language: Haskell2010+ ghc-options: -Wall -Wwarn -fwarn-tabs+ build-depends:+ async >=2.2.2 && <2.3,+ base >=4.11 && <5,+ bytestring >=0.10.8.2 && <0.11,+ chronologique >=0.3.1.1 && <0.4,+ core-data >=0.2.0.0 && <0.3,+ core-text >=0.2.0.0 && <0.3,+ directory >=1.3.3.0 && <1.4,+ exceptions >=0.10.2 && <0.11,+ hashable >=1.2.7.0 && <1.3,+ hourglass >=0.2.12 && <0.3,+ mtl >=2.2.2 && <2.3,+ prettyprinter >=1.2.1 && <1.3,+ prettyprinter-ansi-terminal >=1.1.1.2 && <1.2,+ safe-exceptions >=0.1.7.0 && <0.2,+ stm >=2.5.0.0 && <2.6,+ template-haskell >=2.14.0.0 && <2.15,+ terminal-size >=0.3.2.1 && <0.4,+ text >=1.2.3.1 && <1.3,+ text-short >=0.1.2 && <0.2,+ transformers >=0.5.6.2 && <0.6,+ unix >=2.7.2.2 && <2.8
+ lib/Core/Program.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_HADDOCK not-home #-}++{-|+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.+-}+-- 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 -}+{-|+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+ ) where++import Core.Program.Arguments+import Core.Program.Execute+import Core.Program.Logging+import Core.Program.Metadata+import Core.Program.Unlift+
+ lib/Core/Program/Arguments.hs view
@@ -0,0 +1,841 @@+{-# 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++{-|+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,first,remainingArgs) <- splitCommandLine argv+ params1 <- extractor Nothing globalOptions possibles+ (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++splitCommandLine :: [String] -> Either InvalidCommandLine ([String], String, [String])+splitCommandLine args =+ let+ (possibles,remainder) = List.span isOption args+ x = List.uncons remainder+ in+ case x of+ Just (mode,remainingArgs) -> Right (possibles,mode,remainingArgs)+ Nothing -> if (List.elem "--help" possibles)+ then Left (HelpRequest Nothing)+ else Left NoCommandFound++--+-- Environment variable handling+--++extractValidEnvironments :: Maybe LongName -> Config -> Set LongName+extractValidEnvironments mode config = case config of+ Blank -> emptySet++ Simple options -> extractVariableNames options++ Complex commands ->+ let+ globals = extractGlobalOptions commands+ variables1 = extractVariableNames globals++ locals = extractLocalVariables commands (fromMaybe "" mode)+ variables2 = extractVariableNames locals+ in+ variables1 <> variables2++extractLocalVariables :: [Commands] -> LongName -> [Options]+extractLocalVariables commands mode =+ foldr k [] commands+ where+ k :: Commands -> [Options] -> [Options]+ k (Command name _ options) acc = if name == mode then options else acc+ k _ acc = acc+++extractVariableNames :: [Options] -> Set LongName+extractVariableNames options =+ foldr f emptySet options+ where+ f :: Options -> Set LongName -> Set LongName+ f (Variable longname _) valids = insertElement longname valids+ f _ valids = valids++++--+-- The code from here on is formatting code. It's fairly repetative+-- and crafted to achieve a specific aesthetic output. Rather messy.+-- I'm sure it could be done "better" but no matter; this is on the+-- path to an exit and return to user's command line.+--++buildUsage :: Config -> Maybe LongName -> Doc ann+buildUsage config mode = case config of+ Blank -> emptyDoc++ Simple options ->+ let+ (o,a) = partitionParameters options+ in+ "Usage:" <> hardline <> hardline+ <> indent 4 (nest 4 (fillCat+ [ pretty programName+ , optionsSummary o+ , argumentsSummary a+ ])) <> hardline+ <> optionsHeading o+ <> formatParameters o+ <> argumentsHeading a+ <> formatParameters a++ Complex commands ->+ let+ globalOptions = extractGlobalOptions commands+ modes = extractValidModes commands++ (oG,_) = partitionParameters globalOptions+ in+ "Usage:" <> hardline <> hardline <> case mode of+ Nothing ->+ indent 2 (nest 4 (fillCat+ [ pretty programName+ , globalSummary oG+ , commandSummary modes+ ])) <> hardline+ <> globalHeading oG+ <> formatParameters oG+ <> commandHeading modes+ <> formatCommands commands++ Just longname ->+ let+ (oL,aL) = case lookupKeyValue longname modes of+ Just localOptions -> partitionParameters localOptions+ Nothing -> error "Illegal State"+ in+ indent 2 (nest 4 (fillCat+ [ pretty programName+ , globalSummary oG+ , commandSummary modes+ , localSummary oL+ , argumentsSummary aL+ ])) <> hardline+ <> localHeading oL+ <> formatParameters oL+ <> argumentsHeading aL+ <> formatParameters aL++ where+ partitionParameters :: [Options] -> ([Options],[Options])+ partitionParameters options = foldr f ([],[]) options++ optionsSummary :: [Options] -> Doc ann+ optionsSummary os = if length os > 0 then softline <> "[OPTIONS]" else emptyDoc++ optionsHeading os = if length os > 0 then hardline <> "Available options:" <> hardline else emptyDoc++ globalSummary os = if length os > 0 then softline <> "[GLOBAL OPTIONS]" else emptyDoc+ globalHeading os = if length os > 0+ then hardline <> "Global options:" <> hardline+ else emptyDoc++ localSummary os = if length os > 0 then softline <> "[LOCAL OPTIONS]" else emptyDoc+ localHeading os = if length os > 0+ then hardline <> "Options to the '" <> commandName <> "' command:" <> hardline+ else emptyDoc++ commandName :: Doc ann+ commandName = case mode of+ Just (LongName name) -> pretty name+ Nothing -> "COMMAND..."++ argumentsSummary :: [Options] -> Doc ann+ argumentsSummary as = " " <> fillSep (fmap pretty (extractRequiredArguments as))++ argumentsHeading as = if length as > 0 then hardline <> "Required arguments:" <> hardline else emptyDoc++ -- there is a corner case of complex config with no commands+ commandSummary modes = if length modes > 0 then softline <> commandName else emptyDoc+ commandHeading modes = if length modes > 0 then hardline <> "Available commands:" <> hardline else emptyDoc++ f :: Options -> ([Options],[Options]) -> ([Options],[Options])+ f o@(Option _ _ _ _) (opts,args) = (o:opts,args)+ f a@(Argument _ _) (opts,args) = (opts,a:args)+ f (Variable _ _) (opts,args) = (opts,args)++ formatParameters :: [Options] -> Doc ann+ formatParameters [] = emptyDoc+ formatParameters options = hardline <> foldr g emptyDoc options++--+-- 16 characters width for short option, long option, and two spaces. If the+-- long option's name is wider than this the description will be moved to+-- the next line.+--+-- Arguments are aligned to the character of the short option; looks+-- pretty good and better than waiting until column 8.+--++ g :: Options -> Doc ann -> Doc ann+ g (Option longname shortname valued description) acc =+ let+ s = case shortname of+ Just shortchar -> " -" <> pretty shortchar <> ", --"+ Nothing -> " --"+ l = pretty longname+ d = fromRope description+ in case valued of+ Empty ->+ fillBreak 16 (s <> l <> " ") <+> align (reflow d) <> hardline <> acc+ Value label ->+ fillBreak 16 (s <> l <> "=" <> pretty label <> " ") <+> align (reflow d) <> hardline <> acc++ g (Argument longname description) acc =+ let+ l = pretty longname+ d = fromRope description+ in+ fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc+ g (Variable longname description) acc =+ let+ l = pretty longname+ d = fromRope description+ in+ fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc++ formatCommands :: [Commands] -> Doc ann+ formatCommands commands = hardline <> foldr h emptyDoc commands++ h :: Commands -> Doc ann -> Doc ann+ h (Command longname description _) acc =+ let+ l = pretty longname+ d = fromRope description+ in+ fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc+ h _ acc = acc++buildVersion :: Version -> Doc ann+buildVersion version =+ pretty (projectNameFrom version)+ <+> "v"+ <> pretty (versionNumberFrom version)+ <> hardline+
+ lib/Core/Program/Context.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# 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+ , getConsoleWidth+ ) where++import Prelude hiding (log)+import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds)+import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar)+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 Data.Foldable (foldrM)+import Data.Text.Prettyprint.Doc (layoutPretty, LayoutOptions(..), PageWidth(..))+import Data.Text.Prettyprint.Doc.Render.Text (renderIO)+import qualified System.Console.Terminal.Size as Terminal (Window(..), size)+import System.Environment (getArgs, getProgName, lookupEnv)+import System.Exit (ExitCode(..), exitWith)++import 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'.+-}+--+-- The fieldNameFrom idiom is an experiment. Looks very strange,+-- certainly, here in the record type definition and when setting+-- fields, but for the common case of getting a value out of the+-- record, a call like+--+-- fieldNameFrom context+--+-- isn't bad at all, and no worse than the leading underscore+-- convention.+--+-- _fieldName context+--+-- (I would argue better, since _ is already so overloaded as the+-- wildcard symbol in Haskell). Either way, the point is to avoid a+-- 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 τ+}++{-|+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)++isNone :: None -> Bool+isNone _ = True+++data Message = Message TimeStamp Verbosity Rope (Maybe Rope)++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/++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 τ))++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'.+-}+getContext :: Program τ (Context τ)+getContext = do+ context <- ask+ return context++{-|+Run a subprogram from within a lifted @IO@ block.+-}+subProgram :: Context τ -> Program τ α -> IO α+subProgram context (Program r) = do+ runReaderT r context++--+-- This is complicated. The **safe-exceptions** library exports a+-- `throwM` which is not the `throwM` class method from MonadThrow.+-- See https://github.com/fpco/safe-exceptions/issues/31 for+-- discussion. In any event, the re-exports flow back to+-- Control.Monad.Catch from **exceptions** and Control.Exceptions in+-- **base**. In the execute actions, we need to catch everything (including+-- asynchronous exceptions); elsewhere we will use and wrap/export+-- **safe-exceptions**'s variants of the functions.+--+instance MonadThrow (Program τ) where+ throwM = liftIO . Safe.throw++unHandler :: (ε -> Program τ α) -> (ε -> ReaderT (Context τ) IO α)+unHandler = fmap unProgram++instance MonadCatch (Program τ) where+ catch :: Exception ε => (Program τ) α -> (ε -> (Program τ) α) -> (Program τ) α+ catch program handler =+ let+ r = unProgram program+ h = unHandler handler+ in do+ context <- ask+ liftIO $ do+ Safe.catch+ (runReaderT r context)+ (\e -> runReaderT (h e) context)++{-|+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++ arg0 <- getProgName+ n <- newMVar (intoRope arg0)+ p <- handleCommandLine version config+ q <- newEmptyMVar+ columns <- getConsoleWidth+ out <- newTQueueIO+ log <- newTQueueIO+ u <- newMVar t++ l <- handleVerbosityLevel p++ return $! Context {+ programNameFrom = n+ , versionFrom = version+ , commandLineFrom = p+ , exitSemaphoreFrom = q+ , startTimeFrom = start+ , terminalWidthFrom = columns+ , verbosityLevelFrom = l+ , outputChannelFrom = out+ , loggerChannelFrom = log+ , applicationDataFrom = u+ }++--+-- | 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++--+-- | 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+ called that in Core.Program.Arguments). And, returning here lets us set+ up the layout width to match (one off the) actual width of console.+-}+handleCommandLine :: Version -> Config -> IO Parameters+handleCommandLine version config = do+ argv <- getArgs+ let result = parseCommandLine config argv+ case result of+ Right parameters -> do+ pairs <- lookupEnvironmentVariables config parameters+ return parameters { environmentValuesFrom = pairs }+ Left e -> case e of+ HelpRequest mode -> do+ render (buildUsage config mode)+ exitWith (ExitFailure 1)+ VersionRequest -> do+ render (buildVersion version)+ exitWith (ExitFailure 1)+ _ -> do+ putStr "error: "+ putStrLn (displayException e)+ hFlush stdout+ exitWith (ExitFailure 1)+ where+ render message = do+ columns <- getConsoleWidth+ let options = LayoutOptions (AvailablePerLine (columns - 1) 1.0)+ renderIO stdout (layoutPretty options message)+ hFlush stdout+++lookupEnvironmentVariables :: Config -> Parameters -> IO (Map LongName ParameterValue)+lookupEnvironmentVariables config params = do+ let mode = commandNameFrom params+ let valids = extractValidEnvironments mode config++ result <- foldrM f emptyMap valids+ return result+ where+ f :: LongName -> (Map LongName ParameterValue) -> IO (Map LongName ParameterValue)+ f name@(LongName var) acc = do+ result <- lookupEnv var+ return $ case result of+ Just value -> insertKeyValue name (Value value) acc+ Nothing -> acc+++handleVerbosityLevel :: Parameters -> IO (MVar Verbosity)+handleVerbosityLevel params = do+ let result = queryVerbosityLevel params+ case result of+ Right level -> do+ newMVar level+ Left exit -> do+ putStrLn "error: To set logging level use --verbose or --debug; neither take values."+ hFlush stdout+ exitWith exit++queryVerbosityLevel :: Parameters -> Either ExitCode Verbosity+queryVerbosityLevel params =+ let+ debug = lookupKeyValue "debug" (parameterValuesFrom params)+ verbose = lookupKeyValue "verbose" (parameterValuesFrom params)+ in+ case debug of+ Just value -> case value of+ Empty -> Right Debug+ Value _ -> Left (ExitFailure 2)+ Nothing -> case verbose of+ Just value -> case value of+ Empty -> Right Event+ Value _ -> Left (ExitFailure 2)+ Nothing -> Right Output
+ lib/Core/Program/Execute.hs view
@@ -0,0 +1,538 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# 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.++/Logging and output/++The 'Program' monad provides functions for both normal output and debug+logging. A common annoyance when building command line tools and daemons is+getting program output to @stdout@ and debug messages interleaved, made+even worse when error messages written to @stderr@ land in the same+console. To avoid this, when all output is sent through a single channel.+This includes both normal output and log messages.++/Exceptions/++Ideally your code should handle (and not leak) exceptions, as is good+practice anywhere in the Haskell ecosystem. As a measure of last resort+however, if an exception is thrown (and not caught) by your program it will+be caught at the outer 'execute' entrypoint, logged for debugging, and then+your program will exit.++/Customizing the execution context/++The 'execute' function will run your 'Program' in a basic 'Context'+initialized with appropriate defaults. Most settings can be changed at+runtime, but to specify the allowed command-line options and expected+arguments you can initialize your program using 'configure' and then run+with 'executeWith'.+-}+module Core.Program.Execute+ ( Program ()+ {-* Running programs -}+ , configure+ , execute+ , executeWith+ {-* Exiting a program -}+ , terminate+ {-* Accessing program context -}+ , getCommandLine+ , lookupOptionFlag+ , lookupOptionValue+ , lookupArgument+ , getProgramName+ , setProgramName+ , getVerbosityLevel+ , setVerbosityLevel+ , getApplicationState+ , setApplicationState+ , retrieve+ , update+ {-* Useful actions -}+ , output+ , input+ {-* Concurrency -}+ , Thread+ , fork+ , sleep+ {-* 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.STM (atomically, check)+import Control.Concurrent.STM.TQueue (TQueue, readTQueue, isEmptyTQueue)+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.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 Core.Data.Structures+import Core.Text.Bytes+import Core.Text.Rope+import Core.System.Base+import Core.Program.Context+import Core.Program.Logging+import Core.Program.Signal+import Core.Program.Arguments++-- execute actual "main"+executeAction :: Context τ -> Program τ α -> IO ()+executeAction context program =+ let+ quit = exitSemaphoreFrom context+ in do+ _ <- subProgram context program+ putMVar quit ExitSuccess++--+-- If an exception escapes, we'll catch it here. The displayException+-- value for some exceptions is really quit unhelpful, so we pattern+-- match the wrapping gumpf away for cases as we encounter them. The+-- final entry is the catch-all; the first is what we get from the+-- 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)+ ]+ where+ quit = exitSemaphoreFrom context++ pass :: IO ()+ pass = return ()++ done :: ExitCode -> IO ()+ done exit = do+ 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)++--+-- If an exception occurs in one of the output handlers, its failure causes+-- a subsequent race condition when the program tries to clean up and drain+-- the queues. So we use `exitImmediately` (which we normally avoid, as it+-- unhelpfully destroys the parent process if you're in ghci) because we+-- really need the process to go down and we're in an inconsistent state+-- where debug or console output is no longer possible.+--+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))+ ]++{-|+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++{-|+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++ let quit = exitSemaphoreFrom context+ level = verbosityLevelFrom context+ out = outputChannelFrom context+ log = loggerChannelFrom context++ -- set up standard output+ o <- async $ do+ Safe.catchesAsync+ (processStandardOutput out)+ (collapseHandlers)++ -- set up debug logger+ l <- async $ do+ Safe.catchesAsync+ (processDebugMessages log)+ (collapseHandlers)++ -- set up signal handlers+ _ <- async $ do+ setupSignalHandlers quit level++ -- run actual program, ensuring to trap uncaught exceptions+ m <- async $ do+ Safe.catchesAsync+ (executeAction context program)+ (escapeHandlers context)++ code <- readMVar quit+ cancel m++ -- drain message queues. Allow 0.1 seconds, then timeout, in case+ -- something has gone wrong and queues don't empty.+ race_+ (do+ atomically $ do+ done2 <- isEmptyTQueue log+ check done2++ done1 <- isEmptyTQueue out+ check done1)+ (do+ threadDelay 100000+ putStrLn "error: Timeout")++ threadDelay 100 -- instead of yield+ hFlush stdout++ 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)++ 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)++ return ()++{-|+Safely exit the program with the supplied exit code. Current output and+debug queues will be flushed, and then the process will terminate.+-}+-- putting to the quit MVar initiates the cleanup and exit sequence,+-- but throwing the exception also aborts execution and starts unwinding+-- back up the stack.+terminate :: Int -> Program τ α+terminate code =+ let+ exit = case code of+ 0 -> ExitSuccess+ _ -> ExitFailure code+ in do+ context <- ask+ let quit = exitSemaphoreFrom context+ liftIO $ do+ putMVar quit exit+ Safe.throw exit++-- undocumented+getVerbosityLevel :: Program τ Verbosity+getVerbosityLevel = do+ 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.+-}+setVerbosityLevel :: Verbosity -> Program τ ()+setVerbosityLevel level = do+ 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. @:/@+-}+setProgramName :: Rope -> Program τ ()+setProgramName name = do+ 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').+-}+getProgramName :: Program τ Rope+getProgramName = do+ context <- ask+ liftIO $ do+ let v = programNameFrom context+ readMVar v++{-|+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.++@+ let state' = state { answer = 42 }+ setApplicationState state'+@+-}+setApplicationState :: τ -> Program τ ()+setApplicationState user = do+ context <- ask+ liftIO $ do+ let v = applicationDataFrom context+ modifyMVar_ v (\_ -> pure user)++{-|+Alias for 'getApplicationState'.+-}+retrieve :: Program τ τ+retrieve = getApplicationState++{-|+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).+-}+output :: Handle -> Bytes -> Program τ ()+output handle contents = liftIO (hOutput handle contents)++{-|+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')+-}+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 :: 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:++@+ 'sleep' 1.5+@++(this wraps __base__'s 'threadDelay')+-}+--+-- FIXME is this the right type, given we want to avoid type default warnings?+--+sleep :: Rational -> Program τ ()+sleep seconds =+ let+ us = floor (toRational (seconds * 1e6))+ in+ liftIO $ threadDelay us++{-|+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)++{-|+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++{-|+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++{-|+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+++{-|+Illegal internal state resulting from what should be unreachable code+or otherwise a programmer error.+-}+invalid :: Program τ α+invalid = error "Invalid State"
+ lib/Core/Program/Logging.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_HADDOCK prune #-}++{-|+Output and Logging from your program.++Broadly speaking, there are two kinds of program: console tools invoked for+a single purpose, and long-running daemons that effectively run forever.++Tools tend to be run to either have an effect (in which case they tend not+to a say much of anything) or to report a result. This tends to be written+to \"standard output\"—traditionally abbreviated in code as @stdout@—which+is usually printed to your terminal.++Daemons, on the other hand, don't write their output to file descriptor 1;+rather they tend to respond to requests by writing to files, replying over+network sockets, or sending up smoke signals (@ECPUTOOHOT@, in case you're+curious). What daemons /do/ output, however, is log messages.++While there are many sophisticated logging services around that you can+interact with directly, from the point of view of an individual /program/+these tend to have faded away and have become more an aspect of the+Infrastructure- or Platform-as-a-Service you're running on. Over the past+few years containerization mechanisms like __docker__, then more recently+container orchestration layers like __kubernetes__, have generally simply+captured programs' standard output /as if it were the program's log output/+and then sent that down external logging channels to whatever log analysis+system is available. Even programs running locally under __systemd__ or+similar tend to follow the same pattern; services write to @stdout@ and+that output, as "logs", ends up being fed to the system journal.++So with that in mind, in your program you will either be outputting results+to @stdout@ or not writing there at all, and you will either be describing+extensively what your application is up to, or not at all. ++There is also a \"standard error\" file descriptor available. We recommend+not using it. At best it is unclear what is written to @stderr@ and what+isn't; at worse it is lost as many environments in the wild discard+@stderr@ entirely. To avoid this most of the time people just combine them+in the invoking shell with @2>&1@, which inevitably results in @stderr@+text appearing in the middle of normal @stdout@ lines corrupting them.++The original idea of standard error was to provde a way to report adverse+conditions without interrupting normal text output, but as we have just+observed if it happens without context or out of order there isn't much+point. Instead this library offers a mechanism which caters for the+different /kinds/ of output in a unified, safe manner.++== Three kinds of output/logging messages++/Standard output/++Your program's normal output to the terminal. This library provides the+'write' (and 'writeS' and 'writeR') functions to send output to @stdout@.++/Events/++When running a tool, you sometimes need to know /what it is doing/ as it is+carrying out its steps. The 'event' function allows you to emit descriptive+messages to the log channel tracing the activities of your program.++Ideally you would never need to turn this on in a command-line tool, but+sometimes a user or operations engineer needs to see what an application is+up to. These should be human readable status messages to convey a sense of+progress.++In the case of long-running daemons, 'event' can be used to describe+high-level lifecycle events, to document individual requests, or even+describing individual transitions in a request handler's state machine, all+depending on the nature of your program.++/Debugging/++Programmers, on the other hand, often need to see the internal state of+the program when /debugging/.++You almost always you want to know the value of some variable or parameter,+so the 'debug' (and 'debugS' and 'debugR') utility functions here send+messages to the log channel prefixed with a label that is, by convention,+the name of the value you are examining.++The important distinction here is that such internal values are almost+never useful for someone other than the person or team who wrote the code+emitting it. Operations engineers might be asked by developers to turn on+@--debug@ing and report back the results; but a user of your program is not+going to do that in and of themselves to solve a problem.++== Single output channel++It is the easy to make the mistake of having multiple subsystems attempting+to write to @stdout@ and these outputs corrupting each other, especially in+a multithreaded language like Haskell. The output actions described here+send all output to terminal down a single thread-safe channel. Output will+be written in the order it was executed, and (so long as you don't use the+@stdout@ Handle directly yourself) your terminal output will be sound.++Passing @--verbose@ on the command-line of your program will cause 'event'+to write its tracing messages to the terminal. This shares the same output+channel as the 'write'@*@ functions and will /not/ cause corruption of your+program's normal output.++Passing @--debug@ on the command-line of your program will cause the+'debug'@*@ actions to write their debug-level messages to the terminal.+This shares the same output channel as above and again will not cause+corruption of your program's normal output.++== Logging channel++/Event and debug messages are internally also sent to a "logging channel",/+/as distinct from the "output" one. This would allow us to send them/+/directly to a file, syslog, or network logging service, but this is/+/as-yet unimplemented./+-}+module Core.Program.Logging+ (+ putMessage+ , Verbosity+ {-* Normal output -}+ , write+ , writeS+ , writeR+ {-* Event tracing -}+ , event+ {-* Debugging -}+ , debug+ , debugS+ , debugR+ ) where++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 Core.Text.Rope+import Core.Text.Utilities+import Core.System.Base+import Core.Program.Context++{-+class Monad m => MonadLog a m where+ 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 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++ -- 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+-- number.+--+{-+ Cloned from **locators** package Data.Locators.Hashes, BSD3 licence+-}+padWithZeros :: Int -> String -> Rope+padWithZeros digits 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 :: Rope -> Program τ ()+write text = do+ context <- ask+ liftIO $ do+ let out = outputChannelFrom context++ !text' <- evaluate text+ atomically (writeTQueue out text')++{-|+Call 'show' on the supplied argument and write the resultant text to+@stdout@.++(This is the equivalent of 'print' from __base__)+-}+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.+-}+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...++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)++isEvent :: Verbosity -> Bool+isEvent level = case level of+ 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.++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'))++{-|+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).+-}+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++ -- TODO take into account 22 width already consumed by timestamp+ -- TODO move render to putMessage? putMessageR?+ let value = render columns thing+ !value' <- evaluate value+ putMessage context (Message now Debug label (Just value'))+
+ lib/Core/Program/Metadata.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+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+)+where++import Core.Data+import Core.Text+import Core.System (withFile, IOMode(..))+import Data.List (intersperse)+import qualified Data.List as List (isSuffixOf, find)+import Data.Maybe (fromMaybe)+import Data.String+import Language.Haskell.TH (Q, runIO)+import Language.Haskell.TH.Syntax (Lift, Exp(..))+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)++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' ...+@++(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++ let result = Version+ { projectNameFrom = fromRope name+ , projectSynopsisFrom = fromRope synopsis+ , versionNumberFrom = fromRope version+ }++-- I would have preferred+--+-- let e = AppE (VarE ...+-- return e+--+-- but that's not happening. So more voodoo TH nonsense instead.++ [e|result|]+++{-+Locate the .cabal file in the present working directory (assumed to be the+build root) and use the **Cabal** library to parse the few bits we need out+of it.+-}++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"++readCabalFile :: Q (Map Rope Rope)+readCabalFile = runIO $ do+ -- Find .cabal file+ file <- findCabalFile++ -- 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++-- this should probably be a function in Core.Text.Rope+breakRope :: (Char -> Bool) -> Rope -> (Rope,Rope)+breakRope predicate text =+ let+ pieces = take 2 (breakPieces predicate text)+ in+ case pieces of+ [] -> ("","")+ [one] -> (one,"")+ (one:two:_) -> (one, trimRope two)++-- knock off the whitespace in "name: hello"+trimRope :: Rope -> Rope+trimRope = mconcat . intersperse " " . breakWords
+ lib/Core/Program/Signal.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module Core.Program.Signal+(+ 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 Core.Program.Context++--+-- | 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)++{-+ Technique to have a blocking MVar and signal handlers to set it+ adapted from code in vaultaire-common package's Vaultaire.Program,+ BSD3 licenced.+-}++interruptHandler :: MVar ExitCode -> Handler+interruptHandler quit = Catch $ do+ 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)++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)++--+-- | 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 ()
+ lib/Core/Program/Unlift.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# 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 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++import Core.Program.Context+import Core.Program.Execute+import Core.Program.Logging+import Core.System.Base++{-|+This gives you a function that you can use within your lifted 'IO' actions+to return to the 'Program' monad.++The type signature of this function is a bit involved, but the example below+shows that the lambda gives you a /function/ as its argument (we recommend+you name it @__runProgram__@ for consistency) which gives you a way to run a+subprogram, be that a single action like writing to terminal or logging, or+a larger action in a do-notation block:++@+main :: IO ()+main = 'execute' $ do+ 'withContext' $ \\runProgram -> do+ -- in IO monad, lifted+ -- (just as if you had used liftIO)++ ...++ runProgram $ do+ -- now unlifted, back to Program monad++ ...+@++Think of this as 'liftIO' with an escape hatch.++This function is named 'withContext' because it is a convenience around the+following pattern:++@+ context <- 'getContext'+ liftIO $ do+ ...+ 'subProgram' context $ do+ -- now in Program monad+ ...+@+-}+-- 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 action = do+ context <- getContext+ let runThing = subProgram context+ liftIO (action runThing)+
+ lib/Core/System.hs view
@@ -0,0 +1,40 @@+{-# 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"+@++as there's no particular benefit to cherry-picking the various sub-modules.++-}+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 -}+{-|+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+ ) where++import Core.System.Base+import Core.System.External+
+ lib/Core/System/Base.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# 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++import Control.Exception.Safe (Exception(..), SomeException, throw+ , bracket, catch, finally, impureThrow)+import Control.Monad.IO.Class (MonadIO, liftIO)+import System.IO (Handle, IOMode(..), withFile, stdin, stdout, stderr, hFlush)+import System.IO.Unsafe (unsafePerformIO)+
+ lib/Core/System/External.hs view
@@ -0,0 +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++import Chrono.TimeStamp (TimeStamp(..), getCurrentTimeNanoseconds)+