summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndrewCowie <>2020-10-17 22:46:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-10-17 22:46:00 (GMT)
commit0e07d8661e508090bef3eb41bcd57389f2e0282b (patch)
tree2060ca7b8f214add4cdc38f2f4d6a69e15b48580
parent5e9552ae212ddeef9ccf14f017be189fbddafdff (diff)
version 0.2.5.0HEAD0.2.5.0master
-rw-r--r--core-program.cabal14
-rw-r--r--lib/Core/Program.hs84
-rw-r--r--lib/Core/Program/Arguments.hs1207
-rw-r--r--lib/Core/Program/Context.hs489
-rw-r--r--lib/Core/Program/Execute.hs848
-rw-r--r--lib/Core/Program/Logging.hs580
-rw-r--r--lib/Core/Program/Metadata.hs241
-rw-r--r--lib/Core/Program/Notify.hs95
-rw-r--r--lib/Core/Program/Signal.hs62
-rw-r--r--lib/Core/Program/Unlift.hs283
-rw-r--r--lib/Core/System.hs76
-rw-r--r--lib/Core/System/Base.hs76
-rw-r--r--lib/Core/System/External.hs18
-rw-r--r--lib/Core/System/Pretty.hs97
14 files changed, 2086 insertions, 2084 deletions
diff --git a/core-program.cabal b/core-program.cabal
index 6289c95..e28f21f 100644
--- a/core-program.cabal
+++ b/core-program.cabal
@@ -4,10 +4,10 @@ cabal-version: 1.12
--
-- 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 @@ category: System
stability: experimental
homepage: https://github.com/aesiniath/unbeliever#readme
bug-reports: https://github.com/aesiniath/unbeliever/issues
-author: Andrew Cowie <andrew@operationaldynamics.com>
-maintainer: Andrew Cowie <andrew@operationaldynamics.com>
+author: Andrew Cowie <istathar@gmail.com>
+maintainer: Andrew Cowie <istathar@gmail.com>
copyright: © 2018-2020 Athae Eredh Siniath and Others
license: BSD3
license-file: LICENSE
-tested-with: GHC == 8.8.3
+tested-with: GHC == 8.8.4
build-type: Simple
source-repository head
@@ -64,10 +64,10 @@ library
, 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
index 6fb6bd6..bb72036 100644
--- a/lib/Core/Program.hs
+++ b/lib/Core/Program.hs
@@ -1,49 +1,48 @@
{-# 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.
+
+-- |
+-- 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 -}
-{-|
-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
-
-{-|
-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
+ ( -- * 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,
+ -- |
+ -- 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
@@ -51,4 +50,3 @@ 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
index 4c7b520..04f68df 100644
--- a/lib/Core/Program/Arguments.hs
+++ b/lib/Core/Program/Arguments.hs
@@ -1,105 +1,114 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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.
--}
+-- |
+-- 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))
+ ( -- * 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.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 Data.Text.Prettyprint.Doc
+ ( Doc,
+ Pretty (..),
+ align,
+ emptyDoc,
+ fillBreak,
+ fillCat,
+ fillSep,
+ hardline,
+ indent,
+ nest,
+ softline,
+ (<+>),
+ )
+import Data.Text.Prettyprint.Doc.Util (reflow)
import System.Environment (getProgName)
-import Core.Data.Structures
-import Core.System.Base
-import Core.Text.Rope
-import Core.Text.Utilities
-import Core.Program.Metadata
-
-{-|
-Single letter "short" options (omitting the "@-@" prefix, obviously).
--}
+-- |
+-- 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).
--}
+-- |
+-- 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.
--}
+-- |
+-- 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)
+ deriving (Show, IsString, Eq, Hashable, Ord)
instance Key LongName
instance Pretty LongName where
- pretty (LongName name) = pretty name
+ 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'.
--}
+ 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]
+ = Blank
+ | Simple [Options]
+ | Complex [Commands]
--
-- Those constructors are not exposed [and functions wrapping them are] partly
@@ -109,312 +118,313 @@ data Config
-- 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'.
--}
+-- |
+-- 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".
--}
+-- |
+-- 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".
--}
+-- |
+-- 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."
- , ...
- ]
-@
--}
+-- |
+-- 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).
--}
+ = 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)
+ = 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)
+ 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|
+ [ 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|
+ |],
+ Option
+ "debug"
+ Nothing
+ Empty
+ [quote|
Turn on debug level logging. Implies --verbose.
|]
- ]
+ ]
-{-|
-Different ways parsing a simple or complex command-line can fail.
--}
+-- |
+-- 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)
+ = -- | 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|
+ 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
@@ -435,156 +445,147 @@ with complex values escaped according to the rules of your shell:
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|
+ 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|
+|]
+ ++ quoted
+ ++ [quote|
For arguments expected by this program, please see --help.
|]
- UnknownCommand first -> "Hm. Command '" ++ first ++ "' not recognized."
- NoCommandFound -> [quote|
+ 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]
+ |]
+ ++ 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 -> ""
+ -- 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).
--}
+-- |
+-- 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
+ 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)
+ 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))
+ 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)]
+ ('-' : _) -> 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)
+ "--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
+ 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')
+ in if containsElement candidate valids
+ then Right (candidate, value')
else Left (UnknownOption ("--" ++ name))
- considerShortOption :: Char -> Either InvalidCommandLine (LongName,ParameterValue)
+ 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)]
+ 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 :: [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
+ 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)
+ Right list -> Right ((name, Value arg) : list)
-parseIndicatedCommand
- :: Map LongName [Options]
- -> String
- -> Either InvalidCommandLine (LongName,[Options])
+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)
+ let candidate = LongName first
+ in case lookupKeyValue candidate modes of
+ Just options -> Right (candidate, options)
Nothing -> Left (UnknownCommand first)
--
@@ -593,7 +594,7 @@ parseIndicatedCommand modes first =
extractValidNames :: [Options] -> Set LongName
extractValidNames options =
- foldr f emptySet options
+ foldr f emptySet options
where
f :: Options -> Set LongName -> Set LongName
f (Option longname _ _ _) valids = insertElement longname valids
@@ -601,25 +602,25 @@ extractValidNames options =
extractShortNames :: [Options] -> Map ShortName LongName
extractShortNames options =
- foldr g emptyMap 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
+ Just shortchar -> insertKeyValue shortchar longname shorts
+ Nothing -> shorts
g _ shorts = shorts
extractRequiredArguments :: [Options] -> [LongName]
extractRequiredArguments arguments =
- foldr h [] arguments
+ foldr h [] arguments
where
h :: Options -> [LongName] -> [LongName]
- h (Argument longname _) needed = longname:needed
+ h (Argument longname _) needed = longname : needed
h _ needed = needed
extractGlobalOptions :: [Commands] -> [Options]
extractGlobalOptions commands =
- foldr j [] commands
+ foldr j [] commands
where
j :: Commands -> [Options] -> [Options]
j (Global options) valids = options ++ valids
@@ -627,37 +628,32 @@ extractGlobalOptions commands =
extractValidModes :: [Commands] -> Map LongName [Options]
extractValidModes commands =
- foldr k emptyMap 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.
--}
+-- |
+-- 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
+ let (possibles, remainder) = List.span isOption args
+ in if null possibles && null remainder
then Left NoCommandFound
- else Right (possibles,remainder)
+ 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)
+ let x = List.uncons argv'
+ in case x of
+ Just (mode, remainingArgs) -> Right (mode, remainingArgs)
Nothing -> Left NoCommandFound
--
@@ -666,39 +662,32 @@ splitCommandLine2 argv' =
extractValidEnvironments :: Maybe LongName -> Config -> Set LongName
extractValidEnvironments mode config = case config of
- Blank -> emptySet
-
- Simple options -> extractVariableNames options
-
- Complex commands ->
- let
- globals = extractGlobalOptions commands
+ 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
+ in variables1 <> variables2
extractLocalVariables :: [Commands] -> LongName -> [Options]
extractLocalVariables commands mode =
- foldr k [] commands
+ 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
+ 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.
@@ -708,63 +697,74 @@ extractVariableNames options =
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
+ 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
-
+ (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
+ partitionParameters :: [Options] -> ([Options], [Options])
+ partitionParameters options = foldr f ([], []) options
optionsSummary :: [Options] -> Doc ann
optionsSummary os = if length os > 0 then softline <> "[OPTIONS]" else emptyDoc
@@ -772,19 +772,21 @@ buildUsage config mode = case config of
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
+ 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
+ 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..."
+ Just (LongName name) -> pretty name
+ Nothing -> "COMMAND..."
argumentsSummary :: [Options] -> Doc ann
argumentsSummary as = " " <> fillSep (fmap pretty (extractRequiredArguments as))
@@ -795,67 +797,58 @@ buildUsage config mode = case config of
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)
+ 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.
---
+ --
+ -- 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
-
+ 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
+ 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
+ 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
+ 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)
+ pretty (projectNameFrom version)
<+> "v"
<> pretty (versionNumberFrom version)
<> hardline
-
diff --git a/lib/Core/Program/Context.hs b/lib/Core/Program/Context.hs
index 355e423..117fe80 100644
--- 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 @@ application data of type @τ@ which can be retrieved with
-- 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.
+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 τ
+ }
+
+-- 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
+
+-- |
+-- 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})
+
+-- |
+-- 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.
+ deriving (Show)
-The first type variable, @τ@, is your application's state. This is an
-object that will be threaded through the computation and made available to
-your code in the 'Program' monad. While this is a common requirement of the
-outer code layer in large programs, it is often /not/ necessary in small
-programs or when starting new projects. You can mark that there is no
-top-level application state required using 'None' and easily change it
-later if your needs evolve.
-
-The return type, @α@, is usually unit as this effectively being called
-directly from @main@ and Haskell programs have type @'IO' ()@. That is,
-they don't return anything; I/O having already happened as side effects.
-
-/Programs in separate modules/
-
-One of the quirks of Haskell is that it is difficult to refer to code in
-the Main module when you've got a number of programs kicking around in a
-project each with a @main@ function. So you're best off putting your
-top-level 'Program' actions in a separate modules so you can refer to them
-from test suites and example snippets.
--}
+-- |
+-- The type of a top-level program.
+--
+-- You would use this by writing:
+--
+-- @
+-- module Main where
+--
+-- import "Core.Program"
+--
+-- main :: 'IO' ()
+-- main = 'Core.Program.Execute.execute' program
+-- @
+--
+-- and defining a program that is the top level of your application:
+--
+-- @
+-- program :: 'Program' 'None' ()
+-- @
+--
+-- Such actions are combinable; you can sequence them (using bind in
+-- do-notation) or run them in parallel, but basically you should need one
+-- such object at the top of your application.
+--
+-- /Type variables/
+--
+-- A 'Program' has a user-supplied application state and a return type.
+--
+-- The first type variable, @τ@, is your application's state. This is an
+-- object that will be threaded through the computation and made available to
+-- your code in the 'Program' monad. While this is a common requirement of the
+-- outer code layer in large programs, it is often /not/ necessary in small
+-- programs or when starting new projects. You can mark that there is no
+-- top-level application state required using 'None' and easily change it
+-- later if your needs evolve.
+--
+-- The return type, @α@, is usually unit as this effectively being called
+-- directly from @main@ and Haskell programs have type @'IO' ()@. That is,
+-- they don't return anything; I/O having already happened as side effects.
+--
+-- /Programs in separate modules/
+--
+-- One of the quirks of Haskell is that it is difficult to refer to code in
+-- the Main module when you've got a number of programs kicking around in a
+-- project each with a @main@ function. So you're best off putting your
+-- top-level 'Program' actions in a separate modules so you can refer to them
+-- from test suites and example snippets.
newtype Program τ α = Program (ReaderT (Context τ) IO α)
- deriving (Functor, Applicative, Monad, MonadIO, MonadReader (Context τ))
+ deriving (Functor, Applicative, Monad, MonadIO, MonadReader (Context τ))
unProgram :: Program τ α -> ReaderT (Context τ) IO α
unProgram (Program r) = r
-{-|
-Get the internal @Context@ of the running @Program@. There is ordinarily no
-reason to use this; to access your top-level application data @τ@ within
-the @Context@ use 'Core.Program.Execute.getApplicationState'.
--}
+-- |
+-- Get the internal @Context@ of the running @Program@. There is ordinarily no
+-- reason to use this; to access your top-level application data @τ@ within
+-- the @Context@ use 'Core.Program.Execute.getApplicationState'.
getContext :: Program τ (Context τ)
getContext = do
- context <- ask
- return context
+ context <- ask
+ return context
-{-|
-Run a subprogram from within a lifted @IO@ block.
--}
+-- |
+-- Run a subprogram from within a lifted @IO@ block.
subProgram :: Context τ -> Program τ α -> IO α
subProgram context (Program r) = do
- runReaderT r context
+ runReaderT r context
--
-- This is complicated. The **safe-exceptions** library exports a
@@ -193,85 +202,89 @@ subProgram context (Program r) = do
-- 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.
-
-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.
--}
+ (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
- }
+ 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
+ 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 @@ getConsoleWidth = do
-}
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
index cef4a69..5bb7f74 100644
--- 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.
-
-/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'.
--}
+-- |
+-- Embelish a Haskell command-line program with useful behaviours.
+--
+-- /Runtime/
+--
+-- Sets number of capabilities (heavy-weight operating system threads used by
+-- the GHC runtime to run Haskell green threads) to the number of CPU cores
+-- available (for some reason the default is 1 capability only, which is a bit
+-- silly on a multicore system).
+--
+-- Install signal handlers to properly terminate the program performing
+-- cleanup as necessary.
+--
+-- Encoding is set to UTF-8, working around confusing bugs that sometimes
+-- occur when applications are running in Docker containers.
+--
+-- /Logging and output/
+--
+-- The 'Program' monad provides functions for both normal output and debug
+-- logging. A common annoyance when building command line tools and daemons is
+-- getting program output to @stdout@ and debug messages interleaved, made
+-- even worse when error messages written to @stderr@ land in the same
+-- console. To avoid this, when all output is sent through a single channel.
+-- This includes both normal output and log messages.
+--
+-- /Exceptions/
+--
+-- Ideally your code should handle (and not leak) exceptions, as is good
+-- practice anywhere in the Haskell ecosystem. As a measure of last resort
+-- however, if an exception is thrown (and not caught) by your program it will
+-- be caught at the outer 'execute' entrypoint, logged for debugging, and then
+-- your program will exit.
+--
+-- /Customizing the execution context/
+--
+-- The 'execute' function will run your 'Program' in a basic 'Context'
+-- initialized with appropriate defaults. Most settings can be changed at
+-- runtime, but to specify the allowed command-line options and expected
+-- arguments you can initialize your program using 'configure' and then run
+-- with 'executeWith'.
module Core.Program.Execute
- ( Program ()
- {-* Running programs -}
- , configure
- , execute
- , 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
+ ( 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
-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 @@ executeAction context program =
-- 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 @@ escapeHandlers context = [
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 @@ escapeHandlers context = [
--
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
-
-{-|
-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.
--}
+ 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)
-
+ -- 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)
+ 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
-
-{-|
-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.
--}
+ 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. @:/@
--}
+ 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').
--}
+ 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
-
-{-|
-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).
--}
+ context <- ask
+ liftIO $ do
+ let v = programNameFrom context
+ readMVar v
+
+-- |
+-- Retreive the current terminal's width, in characters.
+--
+-- If you are outputting an object with a 'Core.Text.Untilities.Render'
+-- instance then you may not need this; you can instead use 'wrteR' which is
+-- aware of the width of your terminal and will reflow (in as much as the
+-- underlying type's @Render@ instance lets it).
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'.
-
-@
- state <- getApplicationState
-@
--}
+ context <- ask
+ let width = terminalWidthFrom context
+ return width
+
+-- |
+-- Get the user supplied application state as originally supplied to
+-- 'configure' and modified subsequntly by replacement with
+-- 'setApplicationState'.
+--
+-- @
+-- state <- getApplicationState
+-- @
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'
-@
--}
+ 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'.
--}
+ context <- ask
+ liftIO $ do
+ let v = applicationDataFrom context
+ modifyMVar_ v (\_ -> pure user)
+
+-- |
+-- 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:
-
-@
- 'sleep' 1.5
-@
-
-(this wraps __base__'s 'threadDelay')
--}
+ 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).
--}
+ 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)
+ 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
-
-{-|
-Look to see if the user supplied a valued option and if so, what its value
-was.
--}
+ 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.
--}
+ 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.
--}
+ 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"
diff --git a/lib/Core/Program/Logging.hs b/lib/Core/Program/Logging.hs
index 401a600..1a56113 100644
--- 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 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 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
+ 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
+ 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
+-- |
+-- 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...
-
-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.
--}
+ 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)
+ 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.
-
-Messages sent to syslog will be logged at @Debug@ level severity.
--}
+ 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
--}
+ 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).
--}
+-- |
+-- 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'))
-
+ 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'))
diff --git a/lib/Core/Program/Metadata.hs b/lib/Core/Program/Metadata.hs
index 80c5b7f..9d6f27b 100644
--- a/lib/Core/Program/Metadata.hs
+++ b/lib/Core/Program/Metadata.hs
@@ -1,127 +1,126 @@
-{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
-{-|
-Dig metadata out of the description of your project.
-
-This uses the evil /Template Haskell/ to run code at compile time that
-parses the /.cabal/ file for your Haskell project and extracts various
-meaningful fields.
--}
+-- |
+-- 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' ...
-@
-
-(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)
--}
+ 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
+ pairs <- readCabalFile
- let name = fromMaybe "" . lookupKeyValue "name" $ pairs
- let synopsis = fromMaybe "" . lookupKeyValue "synopsis" $ pairs
- let version = fromMaybe "" . lookupKeyValue "version" $ pairs
+ let name = fromMaybe "" . lookupKeyValue "name" $ pairs
+ let synopsis = fromMaybe "" . lookupKeyValue "synopsis" $ pairs
+ let version = fromMaybe "" . lookupKeyValue "version" $ pairs
- let result = Version
- { projectNameFrom = fromRope name
- , projectSynopsisFrom = fromRope synopsis
- , versionNumberFrom = fromRope version
- }
-
--- 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 @@ 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"
+ 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
index d9b76e1..8cab2d1 100644
--- 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 @@ finish its write and switcheroo sequence.
--
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 @@ waitForChange files =
sequence_ stoppers
return ()
- sleep 0.1
+ sleep 0.1
diff --git a/lib/Core/Program/Signal.hs b/lib/Core/Program/Signal.hs
index d80d1b1..8af3a51 100644
--- 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 @@ code signal = ExitFailure (128 + fromIntegral signal)
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
index 175b0a9..6004457 100644
--- 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)
+-- |
+-- 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
+-- ...
+-- @
- ...
-
- 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 ::
+ ((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
index deea65e..3950ea8 100644
--- 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:
+-- |
+-- 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
-@
-import "Core.System"
-@
+ -- |
+ -- Re-exports from foundational libraries supplied by the compiler runtime,
+ -- or from re-implementations of those areas.
+ module Core.System.Base,
-as there's no particular benefit to cherry-picking the various sub-modules.
+ -- * External dependencies
--}
-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
+ -- |
+ -- 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,
- {-* 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
+ -- * Pretty Printing
- {-* 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
-
- ) 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
index 27c1bbb..6434c41 100644
--- 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
-
-import Control.Exception.Safe (Exception(..), SomeException, throw
- , bracket, catch, finally, impureThrow)
+ ( -- * 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,
+ 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
index bc43d75..9cfd0c8 100644
--- 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
index 58e3841..fa28ce7 100644
--- 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