unbeliever 0.9.3.2 → 0.10.0.0
raw patch · 22 files changed
+21/−4578 lines, 22 filesdep +core-datadep +core-programdep +core-textdep −aesondep −asyncdep −chronologiquedep ~hspec
Dependencies added: core-data, core-program, core-text
Dependencies removed: aeson, async, chronologique, containers, deepseq, directory, exceptions, hashable, hourglass, mtl, prettyprinter, prettyprinter-ansi-terminal, scientific, stm, template-haskell, terminal-size, transformers, unbeliever, unix, unordered-containers, vector
Dependency ranges changed: hspec
Files
- lib/Core/Data.hs +0/−26
- lib/Core/Data/Structures.hs +0/−323
- lib/Core/Encoding.hs +0/−26
- lib/Core/Encoding/Json.hs +0/−346
- lib/Core/Program.hs +0/−46
- lib/Core/Program/Arguments.hs +0/−841
- lib/Core/Program/Context.hs +0/−346
- lib/Core/Program/Execute.hs +0/−536
- lib/Core/Program/Logging.hs +0/−358
- lib/Core/Program/Metadata.hs +0/−171
- lib/Core/Program/Signal.hs +0/−63
- lib/Core/Program/Unlift.hs +0/−160
- lib/Core/System.hs +0/−40
- lib/Core/System/Base.hs +0/−39
- lib/Core/System/External.hs +0/−15
- lib/Core/Text.hs +0/−36
- lib/Core/Text/Breaking.hs +0/−147
- lib/Core/Text/Bytes.hs +0/−202
- lib/Core/Text/Rope.hs +0/−482
- lib/Core/Text/Utilities.hs +0/−271
- tests/CheckBytesBehaviour.hs +2/−1
- unbeliever.cabal +19/−103
− lib/Core/Data.hs
@@ -1,26 +0,0 @@-{-# OPTIONS_HADDOCK not-home #-}--{-|-Wrappers and adaptors for various data structures common in the Haskell-ecosystem.--This is intended to be used directly:--@-import "Core.Data"-@--as this module re-exports all of its various components.--}-module Core.Data- (- {-* Wrappers -}-{-|-Exposes 'Map', a wrapper around a dictionary type, and 'Set', for-collections of elements.--}- module Core.Data.Structures- ) where--import Core.Data.Structures-
− lib/Core/Data/Structures.hs
@@ -1,323 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--{-|-Convenience wrappers around dictionary and collection types and tools-facilitating conversion between them and various map and set types in-common use in the Haskell ecosystem.--}-module Core.Data.Structures-(- {-* Map type -}- Map- , emptyMap- , singletonMap- , insertKeyValue- , containsKey- , lookupKeyValue-- {-* Conversions -}- , Dictionary(K, V, fromMap, intoMap)-- {-* Set type -}- , Set- , emptySet- , singletonSet- , insertElement- , containsElement-- {-* Conversions -}- , Collection(E, fromSet, intoSet)-- {-* Internals -}- , Key- , unMap- , unSet-)-where--import Data.Foldable (Foldable(..))-import Data.Hashable (Hashable)-import qualified Data.HashMap.Strict as HashMap-import qualified Data.HashSet as HashSet-import qualified Data.Map.Strict as OrdMap-import qualified Data.Set as OrdSet-import qualified Data.Text as T (Text)-import qualified Data.Text.Lazy as U (Text)-import qualified GHC.Exts as Exts (IsList(..))--import Core.Text.Rope (Rope)-import Core.Text.Bytes (Bytes)---- Naming convention used throughout this file is (Thing u) where u is the--- underlying structure [from unordered-containers] wrapped in the Thing--- newtype. Leaves p for our Map and s for our Set in tests.--{-|-A mapping from keys to values.--The keys in a map needs to be an instance of the 'Key' typeclass.-Instances are already provided for many common element types.--'Map' implements 'Foldable', 'Monoid', etc so many common operations such-as 'foldr' to reduce the structure with a right fold, 'length' to get the-number of key/value pairs in the dictionary, 'null' to test whether the-map is empty, and ('<>') to join two maps together are available.--To convert to other dictionary types see 'fromMap' below.--(this is a thin wrapper around __unordered-containers__'s-'Data.HashMap.Strict.HashMap', but if you use the conversion functions to-extract the key/value pairs in a list the list will be ordered according to-the keys' 'Ord' instance)--}-newtype Map κ ν = Map (HashMap.HashMap κ ν)- deriving (Show, Eq)--unMap :: Map κ ν -> HashMap.HashMap κ ν-unMap (Map u) = u-{-# INLINE unMap #-}--{-|-Types that can be used as keys in dictionaries or elements in collections.--To be an instance of 'Key' a type must implement both 'Hashable' and 'Ord'.-This requirement means we can subsequently offer easy conversion-between different the dictionary and collection types you might encounter-when interacting with other libraries.--Instances for this library's 'Rope' and 'Bytes' are provided here, along-with many other common types.--}-class (Hashable κ, Ord κ) => Key κ--instance Key String-instance Key Rope-instance Key Bytes-instance Key T.Text-instance Key U.Text-instance Key Char-instance Key Int--instance Foldable (Map κ) where- foldr f start (Map u) = HashMap.foldr f start u- null (Map u) = HashMap.null u- length (Map u) = HashMap.size u--{-|-A dictionary with no key/value mappings.--}-emptyMap :: Map κ ν-emptyMap = Map (HashMap.empty)--{-|-Construct a dictionary with only a single key/value pair.--}-singletonMap :: Key κ => κ -> ν -> Map κ ν-singletonMap k v = Map (HashMap.singleton k v)--{-|-Insert a key/value pair into the dictionary. If the key is already present-in the dictionary, the old value will be discarded and replaced with the-value supplied here.--}-insertKeyValue :: Key κ => κ -> ν -> Map κ ν -> Map κ ν-insertKeyValue k v (Map u) = Map (HashMap.insert k v u)--{-|-If the dictionary contains the specified key, return the value associated-with that key.--}-lookupKeyValue :: Key κ => κ -> Map κ ν -> Maybe ν-lookupKeyValue k (Map u) = HashMap.lookup k u--{-|-Does the dictionary contain the specified key?--}-containsKey :: Key κ => κ -> Map κ ν -> Bool-containsKey k (Map u) = HashMap.member k u--{-|--}-instance Key κ => Semigroup (Map κ ν) where- (<>) (Map u1) (Map u2) = Map (HashMap.union u1 u2)--instance Key κ => Monoid (Map κ ν) where- mempty = emptyMap- mappend = (<>)--instance Key κ => Exts.IsList (Map κ ν) where- type Item (Map κ ν) = (κ, ν)- fromList pairs = Map (HashMap.fromList pairs)- toList (Map u) = HashMap.toList u--{-|-Types that represent key/value pairs that can be converted to 'Map's.-Haskell's ecosystem has several such. This typeclass provides an adaptor to-get between them. It also allows you to serialize out to an association-list.--For example, to convert a 'Map' to an \"association list\" of key/value-pairs, use 'fromMap':--@- answers :: 'Map' 'Rope' 'Int'- answers = 'singletonMap' \"Life, The Universe, and Everything\" 42-- list :: [('Rope','Int')]- list = 'fromMap' answers-@--Instances are provided for __containers__'s 'Data.Map.Strict.Map' and-__unordered-containers__'s 'Data.HashMap.Strict.HashMap' in addition to the-instance for @[(κ,ν)]@ lists shown above.--}------ Getting an instance for [(κ,ν)] was very difficult. The approach--- implemented below was suggested by Xia Li-yao, @Lysxia was to use--- type families.------ > "Maybe you can change your type class to be indexed by the fully--- > applied dictionary type, instead of a type constructor * -> * -> *"------ https://stackoverflow.com/questions/53554687/list-instances-for-higher-kinded-types/53556313------ Many thanks for an elegant solution to the problem.----class Dictionary α where- type K α :: *- type V α :: *- fromMap :: Map (K α) (V α) -> α- intoMap :: α -> Map (K α) (V α)--instance Key κ => Dictionary (Map κ ν) where- type K (Map κ ν) = κ- type V (Map κ ν) = ν- fromMap = id- intoMap = id--{-| from "Data.HashMap.Strict" (and .Lazy) -}-instance Key κ => Dictionary (HashMap.HashMap κ ν) where- type K (HashMap.HashMap κ ν) = κ- type V (HashMap.HashMap κ ν) = ν- fromMap (Map u) = u- intoMap u = Map u--{-| from "Data.Map.Strict" (and .Lazy) -}-instance Key κ => Dictionary (OrdMap.Map κ ν) where- type K (OrdMap.Map κ ν) = κ- type V (OrdMap.Map κ ν) = ν- fromMap (Map u) = HashMap.foldrWithKey OrdMap.insert OrdMap.empty u- intoMap o = Map (OrdMap.foldrWithKey HashMap.insert HashMap.empty o)--instance Key κ => Dictionary [(κ,ν)] where- type K [(κ,ν)] = κ- type V [(κ,ν)] = ν- fromMap (Map u) = OrdMap.toList (HashMap.foldrWithKey OrdMap.insert OrdMap.empty u)- intoMap kvs = Map (HashMap.fromList kvs)--{-|-A set of unique elements.--The element type needs to be an instance of the same 'Key' typeclass that-is used for keys in the 'Map' type above. Instances are already provided-for many common element types.--'Set' implements 'Foldable', 'Monoid', etc so many common operations such-as 'foldr' to walk the elements and reduce them, 'length' to return the-size of the collection, 'null' to test whether is empty, and ('<>') to take-the union of two sets are available.--To convert to other collection types see 'fromSet' below.--(this is a thin wrapper around __unordered-containers__'s-'Data.HashSet.HashSet', but if you use the conversion functions to extract-a list the list will be ordered according to the elements' 'Ord' instance)--}-newtype Set ε = Set (HashSet.HashSet ε)- deriving (Show, Eq)--unSet :: Set ε -> HashSet.HashSet ε-unSet (Set u) = u-{-# INLINE unSet #-}--instance Foldable Set where- foldr f start (Set u) = HashSet.foldr f start u- null (Set u) = HashSet.null u- length (Set u) = HashSet.size u--instance Key ε => Semigroup (Set ε) where- (<>) (Set u1) (Set u2) = Set (HashSet.union u1 u2)--instance Key ε => Monoid (Set ε) where- mempty = emptySet- mappend = (<>)--{-|-An empty collection. This is used for example as an inital value when-building up a 'Set' using a fold.--}-emptySet :: Key ε => Set ε-emptySet = Set (HashSet.empty)--{-|-Construct a collection comprising only the supplied element.--}-singletonSet :: Key ε => ε -> Set ε-singletonSet e = Set (HashSet.singleton e)--{-|-Insert a new element into the collection. Since the 'Set' type does not-allow duplicates, inserting an element already in the collection has no-effect.--}-insertElement :: Key ε => ε -> Set ε -> Set ε-insertElement e (Set u) = Set (HashSet.insert e u)--{-|-Does the collection contain the specified element?--}-containsElement :: Key ε => ε -> Set ε -> Bool-containsElement e (Set u) = HashSet.member e u--{-|-Types that represent collections of elements that can be converted to-'Set's. Haskell's ecosystem has several such. This typeclass provides an-adaptor to convert between them.--This typeclass also provides a mechanism to serialize a 'Set' out to a-Haskell list. The list will be ordered according to the 'Ord' instance of-the element type.--Instances are provided for __containers__'s 'Data.Set.Set' and-__unordered-containers__'s 'Data.HashSet.HashSet' in addition to the-instance for @[ε]@ lists described above.--}-class Collection α where- type E α :: *- fromSet :: Set (E α) -> α- intoSet :: α -> Set (E α)--instance Key ε => Collection (Set ε) where- type E (Set ε) = ε- fromSet = id- intoSet = id--{-| from "Data.HashSet" -}-instance Key ε => Collection (HashSet.HashSet ε) where- type E (HashSet.HashSet ε) = ε- fromSet (Set u) = u- intoSet u = Set u--{-| from "Data.Set" -}-instance Key ε => Collection (OrdSet.Set ε) where- type E (OrdSet.Set ε) = ε- fromSet (Set u) = HashSet.foldr OrdSet.insert OrdSet.empty u- intoSet u = Set (OrdSet.foldr HashSet.insert HashSet.empty u)--instance Key ε => Collection [ε] where- type E [ε] = ε- fromSet (Set u) = OrdSet.toList (HashSet.foldr OrdSet.insert OrdSet.empty u)- intoSet es = Set (HashSet.fromList es)
− lib/Core/Encoding.hs
@@ -1,26 +0,0 @@-{-# OPTIONS_HADDOCK not-home #-}--{-|-Various formats used for serialization, data transfer, and configuration.--This can be used by simply importing the top level module:--@-import "Core.Encoding"-@--although the individual formats are quite usable indepedently.--Each of these encodings are backed by a popular and well tuned library in-wide use across the Haskell community; these modules are here as wrappers-providing for ease of use and interoperability across the various tools in-this package.---}-module Core.Encoding- (- module Core.Encoding.Json- ) where--import Core.Encoding.Json-
− lib/Core/Encoding/Json.hs
@@ -1,346 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE TypeFamilies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--{-|-Encoding and decoding UTF-8 JSON content.--This module is a thin wrapper around the most excellent __aeson__ library,-which has rich and powerful facilities for encoding Haskell types into-JSON.--Quite often, however, you find yourself having to create a Haskell type-/just/ to read some JSON coming from an external web service or API. This-can be challenging when the source of the JSON is complex or varying its-schema over time. For ease of exploration this module simply defines an-easy to use intermediate type representing JSON as a format.--Often you'll be working with literals directly in your code. While you can-write:--@- j = 'JsonObject' ('intoMap' [('JsonKey' "answer", 'JsonNumber' 42)])-@--and it would be correct, enabling:--@-\{\-\# LANGUAGE OverloadedStrings \#\-\}-\{\-\# LANGUAGE OverloadedLists \#\-\}-@--allows you to write:--@- j = 'JsonObject' [("answer", 42)]-@--which you is somewhat less cumbersome in declaration-heavy code. You're-certainly welcome to use the constructors if you find it makes for more-readable code or if you need the type annotations.--}------ As currently implemented this module, in conjunction with--- Core.Text, is the opposite of efficient. The idea right now is to--- experiment with the surface API. If it stabilizes, then the fact--- that our string objects are already in UTF-8 will make for a very--- efficient emitter.----module Core.Encoding.Json- ( {-* Encoding and Decoding -}- encodeToUTF8- , decodeFromUTF8- , JsonValue(..)- , JsonKey(..)- {-* Syntax highlighting -}-{-|-Support for pretty-printing JSON values with syntax highlighting using the-__prettyprinter__ library. To output a JSON structure to terminal-colourized with ANSI escape codes you can use the 'Render' instance:--@- debug "j" (render j)-@--will get you:--@-23:46:04Z (00000.007) j =-{- "answer": 42.0-}-@---}- , JsonToken(..)- , colourizeJson- , prettyKey- , prettyValue- ) where--import qualified Data.Aeson as Aeson-import Data.Coerce-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as HashMap-import Data.Hashable (Hashable)-import Data.Text.Prettyprint.Doc- ( Doc, Pretty(..), viaShow, dquote, comma, punctuate, lbracket- , rbracket, vsep, (<+>), indent, lbrace, rbrace- , line, sep, hcat, annotate- , unAnnotate, line', group, nest- )-import Data.Text.Prettyprint.Doc.Render.Terminal- ( color, colorDull, Color(..)- )-import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)-import Data.Scientific (Scientific)-import Data.String (IsString(..))-import qualified Data.Text as T-import qualified Data.Vector as V-import GHC.Generics--import Core.Data.Structures (Map, Key, fromMap, intoMap)-import Core.Text.Bytes (Bytes, intoBytes, fromBytes)-import Core.Text.Rope (Rope, Textual, intoRope, fromRope)-import Core.Text.Utilities (Render(..))--{-|-Given a JSON value, encode it to UTF-8 bytes--I know we're not /supposed/ to rely on types to document functions, but-really, this one does what it says on the tin.--}-encodeToUTF8 :: JsonValue -> Bytes-encodeToUTF8 = intoBytes . Aeson.encode . intoAeson--{-|-Given an array of bytes, attempt to decode it as a JSON value.--}-decodeFromUTF8 :: Bytes -> Maybe JsonValue-decodeFromUTF8 b =- let- x :: Maybe Aeson.Value- x = Aeson.decodeStrict' (fromBytes b)- in- fmap fromAeson x--{-|-A JSON value.--}-data JsonValue- = JsonObject (Map JsonKey JsonValue)- | JsonArray [JsonValue]- | JsonString Rope- | JsonNumber Scientific- | JsonBool Bool- | JsonNull- deriving (Eq, Show, Generic)------- Overloads so that Haskell code literals can be interpreted as JSON--- values. Obviously these are a lot on the partial side, but what else are--- you supposed to do? This is all Haskell gives us for getting at--- literals.----instance IsString JsonValue where- fromString :: String -> JsonValue- fromString = JsonString . intoRope--instance Num JsonValue where- fromInteger = JsonNumber . fromInteger- (+) = error "Sorry, you can't add JsonValues"- (-) = error "Sorry, you can't negate JsonValues"- (*) = error "Sorry, you can't multiply JsonValues"- abs = error "Sorry, not applicable for JsonValues"- signum = error "Sorry, not applicable for JsonValues"--instance Fractional JsonValue where- fromRational :: Rational -> JsonValue- fromRational = JsonNumber . fromRational- (/) = error "Sorry, you can't do division on JsonValues"---intoAeson :: JsonValue -> Aeson.Value-intoAeson value = case value of- JsonObject xm ->- let- kvs = fromMap xm- tvs = fmap (\(k, v) -> (fromRope (coerce k), intoAeson v)) kvs- tvm :: HashMap T.Text Aeson.Value- tvm = HashMap.fromList tvs- in- Aeson.Object tvm-- JsonArray xs ->- let- vs = fmap intoAeson xs- in- Aeson.Array (V.fromList vs)-- JsonString x -> Aeson.String (fromRope x)- JsonNumber x -> Aeson.Number x- JsonBool x -> Aeson.Bool x- JsonNull -> Aeson.Null--{-|- Keys in a JSON object.--}-newtype JsonKey- = JsonKey Rope- deriving (Eq, Show, Generic, IsString, Ord)--instance Hashable JsonKey-instance Key JsonKey----- FIXME what is this instance?-instance Aeson.ToJSON Rope where- toJSON text = Aeson.toJSON (fromRope text :: T.Text) -- BAD--instance Textual JsonKey where- fromRope t = coerce t- intoRope x = coerce x---fromAeson :: Aeson.Value -> JsonValue-fromAeson value = case value of- Aeson.Object o ->- let- tvs = HashMap.toList o- kvs = fmap (\(k, v) -> (JsonKey (intoRope k), fromAeson v)) tvs-- kvm :: Map JsonKey JsonValue- kvm = intoMap kvs- in- JsonObject kvm-- Aeson.Array v -> JsonArray (fmap fromAeson (V.toList v))- Aeson.String t -> JsonString (intoRope t)- Aeson.Number n -> JsonNumber n- Aeson.Bool x -> JsonBool x- Aeson.Null -> JsonNull------- Pretty printing-----data JsonToken- = SymbolToken- | QuoteToken- | KeyToken- | StringToken- | EscapeToken- | NumberToken- | BooleanToken- | LiteralToken--instance Render JsonValue where- type Token JsonValue = JsonToken- colourize = colourizeJson- intoDocA = prettyValue--instance Render JsonKey where- type Token JsonKey = JsonToken- colourize = colourizeJson- intoDocA = prettyKey--instance Render Aeson.Value where- type Token Aeson.Value = JsonToken- colourize = colourizeJson- intoDocA = prettyValue . fromAeson------- Ugh. If you want to experiment with narrower output, then:------ . layoutPretty (LayoutOptions {layoutPageWidth = AvailablePerLine 15 1.0}) . prettyValue----{-|-Used by the 'Render' instance to turn symbolic annotations into ANSI colours annotations.-If you're curious, the render pipeline looks like:--@- render = 'intoText' . 'renderStrict' . 'reAnnotateS' 'colourize'- . 'layoutPretty' 'defaultLayoutOptions' . 'prettyValue'-@--}-colourizeJson :: JsonToken -> AnsiStyle-colourizeJson token = case token of- SymbolToken -> color Black- QuoteToken -> color Black- KeyToken -> color Blue- StringToken -> colorDull Cyan- EscapeToken -> colorDull Yellow- NumberToken -> colorDull Green- BooleanToken -> color Magenta- LiteralToken -> colorDull Blue---instance Pretty JsonKey where- pretty = unAnnotate . prettyKey--prettyKey :: JsonKey -> Doc JsonToken-prettyKey (JsonKey t) =- annotate QuoteToken dquote <>- annotate KeyToken (pretty (fromRope t :: T.Text)) <>- annotate QuoteToken dquote--instance Pretty JsonValue where- pretty = unAnnotate . prettyValue--prettyValue :: JsonValue -> Doc JsonToken-prettyValue value = case value of- JsonObject xm ->- let- pairs = fromMap xm- entries = fmap (\(k, v) -> (prettyKey k) <> annotate SymbolToken ":" <+> clear v (prettyValue v)) pairs-- clear v doc = case v of- (JsonObject _) -> line <> doc- (JsonArray _) -> group doc- _ -> doc- in- if length entries == 0- then annotate SymbolToken (lbrace <> rbrace)- else annotate SymbolToken lbrace <> line <> indent 4 (vsep (punctuate (annotate SymbolToken comma) entries)) <> line <> annotate SymbolToken rbrace-- JsonArray xs ->- let- entries = fmap prettyValue xs- in- line' <>- nest 4 (- annotate SymbolToken lbracket <> -- first line not indented- line' <>- sep (punctuate (annotate SymbolToken comma) entries)- ) <>- line' <>- annotate SymbolToken rbracket-- JsonString x ->- annotate QuoteToken dquote <>- annotate StringToken (escapeText x) <>- annotate QuoteToken dquote-- JsonNumber x -> annotate NumberToken (viaShow x)-- JsonBool x -> case x of- True -> annotate BooleanToken "true"- False -> annotate BooleanToken "false"-- JsonNull -> annotate LiteralToken "null"-{-# INLINEABLE prettyValue #-}--escapeText :: Rope -> Doc JsonToken-escapeText text =- let- t = fromRope text :: T.Text- ts = T.split (== '"') t- ds = fmap pretty ts- in- hcat (punctuate (annotate EscapeToken "\\\"") ds)-{-# INLINEABLE escapeText #-}-
− lib/Core/Program.hs
@@ -1,46 +0,0 @@-{-# OPTIONS_HADDOCK not-home #-}--{-|-Support for building command-line programs, ranging from simple tools to-long-running daemons.--This is intended to be used directly:--@-import "Core.Program"-@--the submodules are mostly there to group documentation.--}--- actually, they're there to group implementation too, but hey.-module Core.Program- (- {-* Executing a program -}-{-|-A top-level Program type giving you unified access to logging, concurrency,-and more.--}- module Core.Program.Execute- , module Core.Program.Unlift- , module Core.Program.Metadata-- {-* Command-line argument parsing -}-{-|-Including declaring what options your program accepts, generating help, and-for more complex cases [sub]commands, mandatory arguments, and environment-variable handling.--}- , module Core.Program.Arguments- {-* Logging facilities -}-{-|-Facilities for noting events through your program and doing debugging.--}- , module Core.Program.Logging- ) where--import Core.Program.Arguments-import Core.Program.Execute-import Core.Program.Logging-import Core.Program.Metadata-import Core.Program.Unlift-
− lib/Core/Program/Arguments.hs
@@ -1,841 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE StrictData #-}-{-# OPTIONS_HADDOCK prune #-}--{-|-Invoking a command-line program (be it tool or daemon) consists of listing-the name of its binary, optionally supplying various options to adjust the-behaviour of the program, and then supplying mandatory arguments, if any-are specified.--On startup, we parse any arguments passed in from the shell into-@name,value@ pairs and incorporated into the resultant configuration stored-in the program's Context.--Additionally, this module allows you to specify environment variables that,-if present, will be incorporated into the stored configuration.--}-module Core.Program.Arguments- ( - {-* Setup -}- Config- , blank- , simple- , complex- , baselineOptions- , Parameters(..)- , ParameterValue(..)- {-* Options and Arguments -}- , LongName(..)- , ShortName- , Description- , Options(..)- {-* Programs with Commands -}- , Commands(..)- {-* Internals -}- , parseCommandLine- , extractValidEnvironments- , InvalidCommandLine(..)- , buildUsage- , buildVersion- ) where--import Control.Exception.Safe (Exception(displayException))-import Data.Hashable (Hashable)-import qualified Data.List as List-import Data.Maybe (fromMaybe)-import Data.Text.Prettyprint.Doc (Doc, Pretty(..), nest, fillCat- , emptyDoc, hardline, softline, fillBreak, align, (<+>), fillSep, indent)-import Data.Text.Prettyprint.Doc.Util (reflow)-import Data.String-import System.Environment (getProgName)--import Core.Data.Structures-import Core.System.Base-import Core.Text.Rope-import Core.Text.Utilities-import Core.Program.Metadata--{-|-Single letter "short" options (omitting the "@-@" prefix, obviously).--}-type ShortName = Char--{-|-The description of an option, command, or environment variable (for use-when rendering usage information in response to @--help@ on the-command-line).--}-type Description = Rope--{-|-The name of an option, command, or agument (omitting the "@--@" prefix in-the case of options). This identifier will be used to generate usage text-in response to @--help@ and by you later when retreiving the values of the-supplied parameters after the program has initialized.--Turn on __@OverloadedStrings@__ when specifying configurations, obviously.--}-newtype LongName = LongName String- deriving (Show, IsString, Eq, Hashable, Ord)--instance Key LongName--instance Pretty LongName where- pretty (LongName name) = pretty name--{-|-The setup for parsing the command-line arguments of your program. You build-a @Config@ with 'simple' or 'complex', and pass it to-'Core.Program.Context.configure'.--}-data Config- = Blank- | Simple [Options]- | Complex [Commands]------- Those constructors are not exposed [and functions wrapping them are] partly--- for documentation convenience, partly for aesthetics (after a point too many--- constructors got a bit hard to differentiate betwen), and mostly so that if--- configure's argument turns into a monad like RequestBuilder we have--- somewhere to make that change.-----{-|-A completely empty configuration, without the default debugging and logging-options. Your program won't process any command-line options or arguments,-which would be weird in most cases. Prefer 'simple'.--}-blank :: Config-blank = Blank--{-|-Declare a simple (as in normal) configuration for a program with any number-of optional parameters and mandatory arguments. For example:--@-main :: 'IO' ()-main = do- context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('simple'- [ 'Option' "host" ('Just' \'h\') 'Empty' ['quote'|- Specify an alternate host to connect to when performing the- frobnication. The default is \"localhost\".- |]- , 'Option' "port" ('Just' \'p\') 'Empty' ['quote'|- Specify an alternate port to connect to when frobnicating.- |]- , 'Option' "dry-run" 'Nothing' ('Value' \"TIME\") ['quote'|- Perform a trial run at the specified time but don't actually- do anything.- |]- , 'Option' "quiet" ('Just' \'q\') 'Empty' ['quote'|- Supress normal output.- |]- , 'Argument' "filename" ['quote'|- The file you want to frobnicate.- |]- ])-- 'Core.Program.Execute.executeWith' context program-@--which, if you build that into an executable called @snippet@ and invoke it-with @--help@, would result in:--@-$ __./snippet --help__-Usage:-- snippet [OPTIONS] filename--Available options:-- -h, --host Specify an alternate host to connect to when performing the- frobnication. The default is \"localhost\".- -p, --port Specify an alternate port to connect to when frobnicating.- --dry-run=TIME- Perform a trial run at the specified time but don't- actually do anything.- -q, --quiet Supress normal output.- -v, --verbose Turn on event tracing. By default the logging stream will go- to standard output on your terminal.- --debug Turn on debug level logging. Implies --verbose.--Required arguments:-- filename The file you want to frobnicate.-$ __|__-@--For information on how to use the multi-line string literals shown here,-see 'quote' in "Core.Text.Utilities".--}-simple :: [Options] -> Config-simple options = Simple (options ++ baselineOptions)--{-|-Declare a complex configuration (implying a larger tool with various-"[sub]commands" or "modes"} for a program. You can specify global options-applicable to all commands, a list of commands, and environment variables-that will be honoured by the program. Each command can have a list of local-options and arguments as needed. For example:--@-program :: 'Core.Program.Execute.Program' MusicAppStatus ()-program = ...--main :: 'IO' ()-main = do- context <- 'Core.Program.Execute.configure' ('Core.Program.Execute.fromPackage' version) 'mempty' ('complex'- [ 'Global'- [ 'Option' "station-name" 'Nothing' ('Value' \"NAME\") ['quote'|- Specify an alternate radio station to connect to when performing- actions. The default is \"BBC Radio 1\".- |]- , 'Variable' \"PLAYER_FORCE_HEADPHONES\" ['quote'|- If set to @1@, override the audio subsystem to force output- to go to the user's headphone jack.- |]- ]- , 'Command' \"play\" \"Play the music.\"- [ 'Option' "repeat" 'Nothing' 'Empty' ['quote'|- Request that they play the same song over and over and over- again, simulating the effect of listening to a Top 40 radio- station.- |]- ]- , 'Command' \"rate\" \"Vote on whether you like the song or not.\"- [ 'Option' "academic" 'Nothing' 'Empty' ['quote'|- The rating you wish to apply, from A+ to F. This is the- default, so there is no reason whatsoever to specify this.- But some people are obsessive, compulsive, and have time on- their hands.- |]- , 'Option' "numeric" 'Nothing' 'Empty' ['quote'|- Specify a score as a number from 0 to 100 instead of an- academic style letter grade. Note that negative values are- not valid scores, despite how vicerally satisfying that- would be for music produced in the 1970s.- |]- , 'Option' "unicode" ('Just' \'c\') 'Empty' ['quote'|- Instead of a score, indicate your rating with a single- character. This allows you to use emoji, so that you can- rate a piece \'💩\', as so many songs deserve.- |]- , 'Argument' "score" ['quote'|- The rating you wish to apply.- |]- ]- ])-- 'Core.Program.Execute.executeWith' context program-@--is a program with one global option (in addition to the default ones) [and-an environment variable] and two commands: @play@, with one option; and-@rate@, with two options and a required argument. It also is set up to-carry its top-level application state around in a type called-@MusicAppStatus@ (implementing 'Monoid' and so initialized here with-'mempty'. This is a good pattern to use given we are so early in the-program's lifetime).--The resultant program could be invoked as in these examples:--@-$ __./player --station-name=\"KBBL-FM 102.5\" play__-$-@--@-$ __./player -v rate --numeric 76__-$-@--For information on how to use the multi-line string literals shown here,-see 'quote' in "Core.Text.Utilities".--}-complex :: [Commands] -> Config-complex commands = Complex (commands ++ [Global baselineOptions])--{-|-Description of the command-line structure of a program which has-\"commands\" (sometimes referred to as \"subcommands\") representing-different modes of operation. This is familiar from tools like /git/-and /docker/.--}-data Commands - = Global [Options]- | Command LongName Description [Options]--{-|-Declaration of an optional switch or mandatory argument expected by a-program.--'Option' takes a long name for the option, a short single character-abbreviation if offered for convenience, whether or not the option takes a-value (and what label to show in help output) and a description for use-when displaying usage via @--help@.--'Argument' indicates a mandatory argument and takes the long name used-to identify the parsed value from the command-line, and likewise a-description for @--help@ output.--By convention option and argument names are both /lower case/. If the-identifier is two or more words they are joined with a hyphen. Examples:--@- [ 'Option' \"quiet\" ('Just' \'q'\) 'Empty' \"Keep the noise to a minimum.\"- , 'Option' \"dry-run\" 'Nothing' ('Value' \"TIME\") \"Run a simulation of what would happen at the specified time.\"- , 'Argument' \"username\" \"The user to delete from the system.\"- ]-@--By convention a /description/ is one or more complete sentences each of-which ends with a full stop. For options that take values, use /upper case/-when specifying the label to be used in help output.--'Variable' declares an /environment variable/ that, if present, will be-read by the program and stored in its runtime context. By convention these-are /upper case/. If the identifier is two or more words they are joined-with an underscore:--@- [ ...- , 'Variable' \"CRAZY_MODE\" "Specify how many crazies to activate."- , ...- ]-@--}-data Options- = Option LongName (Maybe ShortName) ParameterValue Description- | Argument LongName Description- | Variable LongName Description---{-|-Individual parameters read in off the command-line can either have a value-(in the case of arguments and options taking a value) or be empty (in the-case of options that are just flags).--}-data ParameterValue- = Value String- | Empty- deriving (Show, Eq)--instance IsString ParameterValue where- fromString x = Value x--{-|-Result of having processed the command-line and the environment. You get at-the parsed command-line options and arguments by calling-'Core.Program.Execute.getCommandLine' within a-'Core.Program.Execute.Program' block.--Each option and mandatory argument parsed from the command-line is either-standalone (in the case of switches and flags, such as @--quiet@) or has an-associated value. In the case of options the key is the name of the option,-and for arguments it is the implicit name specified when setting up the-program. For example, in:--@-$ ./submit --username=gbmh GraceHopper_Resume.pdf-@--the option has parameter name \"@username@\" and value \"@gmbh@\"; the-argument has parameter name \"filename\" (assuming that is what was-declared in the 'Argument' entry) and a value being the Admiral's CV. This-would be returned as:--@-'Parameters' 'Nothing' [("username","gbmh"), ("filename","GraceHopper_Resume.pdf")] []-@--The case of a complex command such as /git/ or /stack/, you get the specific-mode chosen by the user returned in the first position:--@-$ missiles launch --all-@--would be parsed as:--@-'Parameters' ('Just' \"launch\") [("all",Empty)] []-@---}-data Parameters- = Parameters {- commandNameFrom :: Maybe LongName- , parameterValuesFrom :: Map LongName ParameterValue- , environmentValuesFrom :: Map LongName ParameterValue- } deriving (Show, Eq)---baselineOptions :: [Options]-baselineOptions =- [ Option "verbose" (Just 'v') Empty [quote|- Turn on event tracing. By default the logging stream will go to- standard output on your terminal.- |]- , Option "debug" Nothing Empty [quote|- Turn on debug level logging. Implies --verbose.- |]- ]--{-|-Different ways parsing a simple or complex command-line can fail.--}-data InvalidCommandLine- = InvalidOption String {-^ Something was wrong with the way the user specified [usually a short] option. -}- | UnknownOption String {-^ User specified an option that doesn't match any in the supplied configuration. -}- | MissingArgument LongName- {-^ Arguments are mandatory, and this one is missing. -}- | UnexpectedArguments [String]- {-^ Arguments are present we weren't expecting. -}- | UnknownCommand String {-^ In a complex configuration, user specified a command that doesn't match any in the configuration. -}- | NoCommandFound {-^ In a complex configuration, user didn't specify a command. -}- | HelpRequest (Maybe LongName)- {-^ In a complex configuration, usage information was requested with @--help@, either globally or for the supplied command. -}- | VersionRequest- {-^ Display of the program version requested with @--version@. -}- deriving (Show, Eq)--instance Exception InvalidCommandLine where- displayException e = case e of- InvalidOption arg ->- let- one = "Option '" ++ arg ++ "' illegal.\n\n"- two = [quote|-Options must either be long form with a double dash, for example:-- --verbose--or, when available with a short version, a single dash and a single-character. They need to be listed individually:-- -v -a--When an option takes a value it has to be in long form and the value-indicated with an equals sign, for example:-- --tempdir=/tmp--with complex values escaped according to the rules of your shell:-- --username="Ada Lovelace"--For options valid in this program, please see --help.- |]- in- one ++ two- UnknownOption name -> "Sorry, option '" ++ name ++ "' not recognized."- MissingArgument (LongName name) -> "Mandatory argument '" ++ name ++ "' missing."- UnexpectedArguments args ->- let- quoted = List.intercalate "', '" args- in [quote|-Unexpected trailing arguments:--|] ++ quoted ++ [quote|--For arguments expected by this program, please see --help.-|]- UnknownCommand first -> "Hm. Command '" ++ first ++ "' not recognized."- NoCommandFound -> [quote|-No command specified.-Usage is of the form:-- |] ++ programName ++ [quote| [GLOBAL OPTIONS] COMMAND [LOCAL OPTIONS] [ARGUMENTS]--See --help for details.-|]- -- handled by parent module calling back into here buildUsage- HelpRequest _ -> ""-- -- handled by parent module calling back into here buildVersion- VersionRequest -> ""--programName :: String-programName = unsafePerformIO getProgName--{-|-Given a program configuration schema and the command-line arguments,-process them into key/value pairs in a Parameters object.--This results in 'InvalidCommandLine' on the left side if one of the passed-in options is unrecognized or if there is some other problem handling-options or arguments (because at that point, we want to rabbit right back-to the top and bail out; there's no recovering).--This isn't something you'll ever need to call directly; it's exposed for-testing convenience. This function is invoked when you call-'Core.Program.Context.configure' or 'Core.Program.Execute.execute' (which-calls 'configure' with a default @Config@ when initializing).--}-parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters-parseCommandLine config argv = case config of- Blank -> return (Parameters Nothing emptyMap emptyMap)-- Simple options -> do- params <- extractor Nothing options argv- return (Parameters Nothing params emptyMap)-- Complex commands ->- let- globalOptions = extractGlobalOptions commands- modes = extractValidModes commands- in do- (possibles,first,remainingArgs) <- splitCommandLine argv- params1 <- extractor Nothing globalOptions possibles- (mode,localOptions) <- parseIndicatedCommand modes first- params2 <- extractor (Just mode) localOptions remainingArgs- return (Parameters (Just mode) ((<>) params1 params2) emptyMap)- where-- extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine (Map LongName ParameterValue)- extractor mode options args =- let- (possibles,arguments) = List.partition isOption args- valids = extractValidNames options- shorts = extractShortNames options- needed = extractRequiredArguments options- in do- list1 <- parsePossibleOptions mode valids shorts possibles- list2 <- parseRequiredArguments needed arguments- return ((<>) (intoMap list1) (intoMap list2))--isOption :: String -> Bool-isOption arg = case arg of- ('-':_) -> True- _ -> False--parsePossibleOptions- :: Maybe LongName- -> Set LongName- -> Map ShortName LongName- -> [String]- -> Either InvalidCommandLine [(LongName,ParameterValue)]-parsePossibleOptions mode valids shorts args = mapM f args- where- f arg = case arg of- "--help" -> Left (HelpRequest mode)- "-?" -> Left (HelpRequest mode)- "--version" -> Left VersionRequest- ('-':'-':name) -> considerLongOption name- ('-':c:[]) -> considerShortOption c- _ -> Left (InvalidOption arg)-- considerLongOption :: String -> Either InvalidCommandLine (LongName,ParameterValue)- considerLongOption arg =- let- (name,value) = List.span (/= '=') arg - candidate = LongName name- -- lose the '='- value' = case List.uncons value of- Just (_,remainder) -> Value remainder- Nothing -> Empty- in- if containsElement candidate valids- then Right (candidate,value')- else Left (UnknownOption ("--" ++ name))-- considerShortOption :: Char -> Either InvalidCommandLine (LongName,ParameterValue)- considerShortOption c =- case lookupKeyValue c shorts of- Just name -> Right (name,Empty)- Nothing -> Left (UnknownOption ['-',c])--parseRequiredArguments- :: [LongName]- -> [String]- -> Either InvalidCommandLine [(LongName,ParameterValue)]-parseRequiredArguments needed argv = iter needed argv- where- iter :: [LongName] -> [String] -> Either InvalidCommandLine [(LongName,ParameterValue)]-- iter [] [] = Right []- -- more arguments supplied than expected- iter [] args = Left (UnexpectedArguments args)- -- more arguments required, not satisfied- iter (name:_) [] = Left (MissingArgument name)- iter (name:names) (arg:args) =- let- deeper = iter names args- in case deeper of- Left e -> Left e- Right list -> Right ((name,Value arg):list)--parseIndicatedCommand- :: Map LongName [Options]- -> String- -> Either InvalidCommandLine (LongName,[Options])-parseIndicatedCommand modes first =- let- candidate = LongName first- in- case lookupKeyValue candidate modes of- Just options -> Right (candidate,options)- Nothing -> Left (UnknownCommand first)------- Ok, the f,g,h,... was silly. But hey :)-----extractValidNames :: [Options] -> Set LongName-extractValidNames options =- foldr f emptySet options- where- f :: Options -> Set LongName -> Set LongName- f (Option longname _ _ _) valids = insertElement longname valids- f _ valids = valids--extractShortNames :: [Options] -> Map ShortName LongName-extractShortNames options =- foldr g emptyMap options- where- g :: Options -> Map ShortName LongName -> Map ShortName LongName- g (Option longname shortname _ _) shorts = case shortname of- Just shortchar -> insertKeyValue shortchar longname shorts- Nothing -> shorts- g _ shorts = shorts--extractRequiredArguments :: [Options] -> [LongName]-extractRequiredArguments arguments =- foldr h [] arguments- where- h :: Options -> [LongName] -> [LongName]- h (Argument longname _) needed = longname:needed- h _ needed = needed--extractGlobalOptions :: [Commands] -> [Options]-extractGlobalOptions commands =- foldr j [] commands- where- j :: Commands -> [Options] -> [Options]- j (Global options) valids = options ++ valids- j _ valids = valids--extractValidModes :: [Commands] -> Map LongName [Options]-extractValidModes commands =- foldr k emptyMap commands- where- k :: Commands -> Map LongName [Options] -> Map LongName [Options]- k (Command longname _ options) modes = insertKeyValue longname options modes- k _ modes = modes--splitCommandLine :: [String] -> Either InvalidCommandLine ([String], String, [String])-splitCommandLine args =- let- (possibles,remainder) = List.span isOption args- x = List.uncons remainder- in- case x of- Just (mode,remainingArgs) -> Right (possibles,mode,remainingArgs)- Nothing -> if (List.elem "--help" possibles)- then Left (HelpRequest Nothing)- else Left NoCommandFound------- Environment variable handling-----extractValidEnvironments :: Maybe LongName -> Config -> Set LongName-extractValidEnvironments mode config = case config of- Blank -> emptySet-- Simple options -> extractVariableNames options-- Complex commands ->- let- globals = extractGlobalOptions commands- variables1 = extractVariableNames globals-- locals = extractLocalVariables commands (fromMaybe "" mode)- variables2 = extractVariableNames locals- in- variables1 <> variables2--extractLocalVariables :: [Commands] -> LongName -> [Options]-extractLocalVariables commands mode =- foldr k [] commands- where- k :: Commands -> [Options] -> [Options]- k (Command name _ options) acc = if name == mode then options else acc- k _ acc = acc---extractVariableNames :: [Options] -> Set LongName-extractVariableNames options =- foldr f emptySet options- where- f :: Options -> Set LongName -> Set LongName- f (Variable longname _) valids = insertElement longname valids- f _ valids = valids--------- The code from here on is formatting code. It's fairly repetative--- and crafted to achieve a specific aesthetic output. Rather messy.--- I'm sure it could be done "better" but no matter; this is on the--- path to an exit and return to user's command line.-----buildUsage :: Config -> Maybe LongName -> Doc ann-buildUsage config mode = case config of- Blank -> emptyDoc-- Simple options ->- let- (o,a) = partitionParameters options- in- "Usage:" <> hardline <> hardline- <> indent 4 (nest 4 (fillCat- [ pretty programName- , optionsSummary o- , argumentsSummary a- ])) <> hardline- <> optionsHeading o- <> formatParameters o- <> argumentsHeading a- <> formatParameters a-- Complex commands ->- let- globalOptions = extractGlobalOptions commands- modes = extractValidModes commands-- (oG,_) = partitionParameters globalOptions- in- "Usage:" <> hardline <> hardline <> case mode of- Nothing ->- indent 2 (nest 4 (fillCat- [ pretty programName- , globalSummary oG- , commandSummary modes- ])) <> hardline- <> globalHeading oG- <> formatParameters oG- <> commandHeading modes- <> formatCommands commands-- Just longname ->- let- (oL,aL) = case lookupKeyValue longname modes of- Just localOptions -> partitionParameters localOptions- Nothing -> error "Illegal State"- in- indent 2 (nest 4 (fillCat- [ pretty programName- , globalSummary oG- , commandSummary modes- , localSummary oL- , argumentsSummary aL- ])) <> hardline- <> localHeading oL- <> formatParameters oL- <> argumentsHeading aL- <> formatParameters aL-- where- partitionParameters :: [Options] -> ([Options],[Options])- partitionParameters options = foldr f ([],[]) options-- optionsSummary :: [Options] -> Doc ann- optionsSummary os = if length os > 0 then softline <> "[OPTIONS]" else emptyDoc-- optionsHeading os = if length os > 0 then hardline <> "Available options:" <> hardline else emptyDoc-- globalSummary os = if length os > 0 then softline <> "[GLOBAL OPTIONS]" else emptyDoc- globalHeading os = if length os > 0- then hardline <> "Global options:" <> hardline- else emptyDoc-- localSummary os = if length os > 0 then softline <> "[LOCAL OPTIONS]" else emptyDoc- localHeading os = if length os > 0- then hardline <> "Options to the '" <> commandName <> "' command:" <> hardline- else emptyDoc-- commandName :: Doc ann- commandName = case mode of- Just (LongName name) -> pretty name- Nothing -> "COMMAND..."-- argumentsSummary :: [Options] -> Doc ann- argumentsSummary as = " " <> fillSep (fmap pretty (extractRequiredArguments as))-- argumentsHeading as = if length as > 0 then hardline <> "Required arguments:" <> hardline else emptyDoc-- -- there is a corner case of complex config with no commands- commandSummary modes = if length modes > 0 then softline <> commandName else emptyDoc- commandHeading modes = if length modes > 0 then hardline <> "Available commands:" <> hardline else emptyDoc-- f :: Options -> ([Options],[Options]) -> ([Options],[Options])- f o@(Option _ _ _ _) (opts,args) = (o:opts,args)- f a@(Argument _ _) (opts,args) = (opts,a:args)- f (Variable _ _) (opts,args) = (opts,args)-- formatParameters :: [Options] -> Doc ann- formatParameters [] = emptyDoc- formatParameters options = hardline <> foldr g emptyDoc options------- 16 characters width for short option, long option, and two spaces. If the--- long option's name is wider than this the description will be moved to--- the next line.------ Arguments are aligned to the character of the short option; looks--- pretty good and better than waiting until column 8.----- g :: Options -> Doc ann -> Doc ann- g (Option longname shortname valued description) acc =- let- s = case shortname of- Just shortchar -> " -" <> pretty shortchar <> ", --"- Nothing -> " --"- l = pretty longname- d = fromRope description- in case valued of- Empty ->- fillBreak 16 (s <> l <> " ") <+> align (reflow d) <> hardline <> acc- Value label ->- fillBreak 16 (s <> l <> "=" <> pretty label <> " ") <+> align (reflow d) <> hardline <> acc-- g (Argument longname description) acc =- let- l = pretty longname- d = fromRope description- in- fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc- g (Variable longname description) acc =- let- l = pretty longname- d = fromRope description- in- fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc-- formatCommands :: [Commands] -> Doc ann- formatCommands commands = hardline <> foldr h emptyDoc commands-- h :: Commands -> Doc ann -> Doc ann- h (Command longname description _) acc =- let- l = pretty longname- d = fromRope description- in- fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc- h _ acc = acc--buildVersion :: Version -> Doc ann-buildVersion version =- pretty (projectNameFrom version)- <+> "v"- <> pretty (versionNumberFrom version)- <> hardline-
− lib/Core/Program/Context.hs
@@ -1,346 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_HADDOCK hide #-}---- This is an Internal module, hidden from Haddock-module Core.Program.Context- (- Context(..)- , None(..)- , isNone- , configure- , Message(..)- , Verbosity(..)- , Program(..)- , unProgram- , getContext- , subProgram- , getConsoleWidth- ) where--import Prelude hiding (log)-import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds)-import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar)-import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO)-import Control.Exception.Safe (displayException)-import qualified Control.Exception.Safe as Safe (throw, catch)-import Control.Monad.Catch (MonadThrow(throwM), MonadCatch(catch))-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Reader.Class (MonadReader(..))-import Control.Monad.Trans.Reader (ReaderT(..))-import Data.Foldable (foldrM)-import Data.Text.Prettyprint.Doc (layoutPretty, LayoutOptions(..), PageWidth(..))-import Data.Text.Prettyprint.Doc.Render.Text (renderIO)-import qualified System.Console.Terminal.Size as Terminal (Window(..), size)-import System.Environment (getArgs, getProgName, lookupEnv)-import System.Exit (ExitCode(..), exitWith)--import Core.Data.Structures-import Core.System.Base hiding (throw, catch)-import Core.Text.Rope-import Core.Program.Arguments-import Core.Program.Metadata--{-|-Internal context for a running program. You access this via actions in the-'Program' monad. The principal item here is the user-supplied top-level-application data of type @τ@ which can be retrieved with-'Core.Program.Execute.getApplicationState' and updated with-'Core.Program.Execute.setApplicationState'.--}------ The fieldNameFrom idiom is an experiment. Looks very strange,--- certainly, here in the record type definition and when setting--- fields, but for the common case of getting a value out of the--- record, a call like------ fieldNameFrom context------ isn't bad at all, and no worse than the leading underscore--- convention.------ _fieldName context------ (I would argue better, since _ is already so overloaded as the--- wildcard symbol in Haskell). Either way, the point is to avoid a--- bare fieldName because so often you have want to be able to use--- that field name as a local variable name.----data Context τ = Context {- programNameFrom :: MVar Rope- , versionFrom :: Version- , commandLineFrom :: Parameters- , exitSemaphoreFrom :: MVar ExitCode- , startTimeFrom :: TimeStamp- , terminalWidthFrom :: Int- , verbosityLevelFrom :: MVar Verbosity- , outputChannelFrom :: TQueue Rope- , loggerChannelFrom :: TQueue Message- , applicationDataFrom :: MVar τ-}--{-|-A 'Program' with no user-supplied state to be threaded throughout the-computation.--The "Core.Program.Execute" framework makes your top-level application state-available at the outer level of your process. While this is a feature that-most substantial programs rely on, it is /not/ needed for many simple-tasks or when first starting out what will become a larger project.--This is effectively the unit type, but this alias is here to clearly signal-a user-data type is not a part of the program semantics.---}--- Bids are open for a better name for this-data None = None- deriving (Show, Eq)--isNone :: None -> Bool-isNone _ = True---data Message = Message TimeStamp Verbosity Rope (Maybe Rope)--data Verbosity = Output | Event | Debug- deriving Show--{-|-The type of a top-level program.--You would use this by writing:--@-module Main where--import "Core.Program"--main :: 'IO' ()-main = 'Core.Program.Execute.execute' program-@--and defining a program that is the top level of your application:--@-program :: 'Program' 'None' ()-@--Such actions are combinable; you can sequence them (using bind in-do-notation) or run them in parallel, but basically you should need one-such object at the top of your application.--/Type variables/--A 'Program' has a user-supplied application state and a return type.--The first type variable, @τ@, is your application's state. This is an-object that will be threaded through the computation and made available to-your code in the 'Program' monad. While this is a common requirement of the-outer code layer in large programs, it is often /not/ necessary in small-programs or when starting new projects. You can mark that there is no-top-level application state required using 'None' and easily change it-later if your needs evolve.--The return type, @α@, is usually unit as this effectively being called-directly from @main@ and Haskell programs have type @'IO' ()@. That is,-they don't return anything; I/O having already happened as side effects.--/Programs in separate modules/--One of the quirks of Haskell is that it is difficult to refer to code in-the Main module when you've got a number of programs kicking around in a-project each with a @main@ function. So you're best off putting your-top-level 'Program' actions in a separate modules so you can refer to them-from test suites and example snippets.--}-newtype Program τ α = Program (ReaderT (Context τ) IO α)- deriving (Functor, Applicative, Monad, MonadIO, MonadReader (Context τ))--unProgram :: Program τ α -> ReaderT (Context τ) IO α-unProgram (Program r) = r--{-|-Get the internal @Context@ of the running @Program@. There is ordinarily no-reason to use this; to access your top-level application data @τ@ within-the @Context@ use 'Core.Program.Execute.getApplicationState'.--}-getContext :: Program τ (Context τ)-getContext = do- context <- ask- return context--{-|-Run a subprogram from within a lifted @IO@ block.--}-subProgram :: Context τ -> Program τ α -> IO α-subProgram context (Program r) = do- runReaderT r context------- This is complicated. The **safe-exceptions** library exports a--- `throwM` which is not the `throwM` class method from MonadThrow.--- See https://github.com/fpco/safe-exceptions/issues/31 for--- discussion. In any event, the re-exports flow back to--- Control.Monad.Catch from **exceptions** and Control.Exceptions in--- **base**. In the execute actions, we need to catch everything (including--- asynchronous exceptions); elsewhere we will use and wrap/export--- **safe-exceptions**'s variants of the functions.----instance MonadThrow (Program τ) where- throwM = liftIO . Safe.throw--unHandler :: (ε -> Program τ α) -> (ε -> ReaderT (Context τ) IO α)-unHandler = fmap unProgram--instance MonadCatch (Program τ) where- catch :: Exception ε => (Program τ) α -> (ε -> (Program τ) α) -> (Program τ) α- catch program handler =- let- r = unProgram program- h = unHandler handler- in do- context <- ask- liftIO $ do- Safe.catch- (runReaderT r context)- (\e -> runReaderT (h e) context)--{-|-Initialize the programs's execution context. This takes care of various-administrative actions, including setting up output channels, parsing-command-line arguments (according to the supplied configuration), and-putting in place various semaphores for internal program communication.-See "Core.Program.Arguments" for details.--This is also where you specify the initial {blank, empty, default) value-for the top-level user-defined application state, if you have one. Specify-'None' if you aren't using this feature.--}-configure :: Version -> τ -> Config -> IO (Context τ)-configure version t config = do- start <- getCurrentTimeNanoseconds-- arg0 <- getProgName- n <- newMVar (intoRope arg0)- p <- handleCommandLine version config- q <- newEmptyMVar- columns <- getConsoleWidth- out <- newTQueueIO- log <- newTQueueIO- u <- newMVar t-- l <- handleVerbosityLevel p-- return $! Context {- programNameFrom = n- , versionFrom = version- , commandLineFrom = p- , exitSemaphoreFrom = q- , startTimeFrom = start- , terminalWidthFrom = columns- , verbosityLevelFrom = l- , outputChannelFrom = out- , loggerChannelFrom = log- , applicationDataFrom = u- }------- | Probe the width of the terminal, in characters. If it fails to retrieve,--- for whatever reason, return a default of 80 characters wide.----getConsoleWidth :: IO (Int)-getConsoleWidth = do- window <- Terminal.size- let columns = case window of- Just (Terminal.Window _ w) -> w- Nothing -> 80- return columns------- | Process the command line options and arguments. If an invalid--- option is encountered or a [mandatory] argument is missing, then--- the program will terminate here.----{-- We came back here with the error case so we can pass config in to- buildUsage (otherwise we could have done it all in displayException and- called that in Core.Program.Arguments). And, returning here lets us set- up the layout width to match (one off the) actual width of console.--}-handleCommandLine :: Version -> Config -> IO Parameters-handleCommandLine version config = do- argv <- getArgs- let result = parseCommandLine config argv- case result of- Right parameters -> do- pairs <- lookupEnvironmentVariables config parameters- return parameters { environmentValuesFrom = pairs }- Left e -> case e of- HelpRequest mode -> do- render (buildUsage config mode)- exitWith (ExitFailure 1)- VersionRequest -> do- render (buildVersion version)- exitWith (ExitFailure 1)- _ -> do- putStr "error: "- putStrLn (displayException e)- hFlush stdout- exitWith (ExitFailure 1)- where- render message = do- columns <- getConsoleWidth- let options = LayoutOptions (AvailablePerLine (columns - 1) 1.0)- renderIO stdout (layoutPretty options message)- hFlush stdout---lookupEnvironmentVariables :: Config -> Parameters -> IO (Map LongName ParameterValue)-lookupEnvironmentVariables config params = do- let mode = commandNameFrom params- let valids = extractValidEnvironments mode config-- result <- foldrM f emptyMap valids- return result- where- f :: LongName -> (Map LongName ParameterValue) -> IO (Map LongName ParameterValue)- f name@(LongName var) acc = do- result <- lookupEnv var- return $ case result of- Just value -> insertKeyValue name (Value value) acc- Nothing -> acc---handleVerbosityLevel :: Parameters -> IO (MVar Verbosity)-handleVerbosityLevel params = do- let result = queryVerbosityLevel params- case result of- Right level -> do- newMVar level- Left exit -> do- putStrLn "error: To set logging level use --verbose or --debug; neither take values."- hFlush stdout- exitWith exit--queryVerbosityLevel :: Parameters -> Either ExitCode Verbosity-queryVerbosityLevel params =- let- debug = lookupKeyValue "debug" (parameterValuesFrom params)- verbose = lookupKeyValue "verbose" (parameterValuesFrom params)- in- case debug of- Just value -> case value of- Empty -> Right Debug- Value _ -> Left (ExitFailure 2)- Nothing -> case verbose of- Just value -> case value of- Empty -> Right Event- Value _ -> Left (ExitFailure 2)- Nothing -> Right Output
− lib/Core/Program/Execute.hs
@@ -1,536 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_HADDOCK prune #-}--{-|-Embelish a Haskell command-line program with useful behaviours.--/Runtime/--Sets number of capabilities (heavy-weight operating system threads used by-the GHC runtime to run Haskell green threads) to the number of CPU cores-available (for some reason the default is 1 capability only, which is a bit-silly on a multicore system).--Install signal handlers to properly terminate the program performing-cleanup as necessary.--/Logging and output/--The 'Program' monad provides functions for both normal output and debug-logging. A common annoyance when building command line tools and daemons is-getting program output to @stdout@ and debug messages interleaved, made-even worse when error messages written to @stderr@ land in the same-console. To avoid this, when all output is sent through a single channel.-This includes both normal output and log messages.--/Exceptions/--Ideally your code should handle (and not leak) exceptions, as is good-practice anywhere in the Haskell ecosystem. As a measure of last resort-however, if an exception is thrown (and not caught) by your program it will-be caught at the outer 'execute' entrypoint, logged for debugging, and then-your program will exit.--/Customizing the execution context/--The 'execute' function will run your 'Program' in a basic 'Context'-initialized with appropriate defaults. Most settings can be changed at-runtime, but to specify the allowed command-line options and expected-arguments you can initialize your program using 'configure' and then run-with 'executeWith'.--}-module Core.Program.Execute- ( Program ()- {-* Running programs -}- , configure- , execute- , executeWith- {-* Exiting a program -}- , terminate- {-* Accessing program context -}- , getCommandLine- , lookupOptionFlag- , lookupOptionValue- , lookupArgument- , getProgramName- , setProgramName- , getVerbosityLevel- , setVerbosityLevel- , getApplicationState- , setApplicationState- , retrieve- , update- {-* Useful actions -}- , output- , input- {-* Concurrency -}- , Thread- , fork- , sleep- {-* Internals -}- , Context- , None(..)- , isNone- , unProgram- , unThread- , invalid- ) where--import Prelude hiding (log)-import Control.Concurrent (threadDelay)-import Control.Concurrent.Async (Async, async, link, cancel- , ExceptionInLinkedThread(..), AsyncCancelled, race_)-import Control.Concurrent.MVar (readMVar, putMVar, modifyMVar_)-import Control.Concurrent.STM (atomically, check)-import Control.Concurrent.STM.TQueue (TQueue, readTQueue, isEmptyTQueue)-import qualified Control.Exception as Base (throwIO)-import Control.Exception.Safe (SomeException, Exception(displayException))-import qualified Control.Exception.Safe as Safe (throw, catchesAsync)-import Control.Monad (when, forever)-import Control.Monad.Catch (Handler(..))-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Reader.Class (MonadReader(ask))-import qualified Data.ByteString as B (hPut)-import qualified Data.ByteString.Char8 as C (singleton)-import GHC.Conc (numCapabilities, getNumProcessors, setNumCapabilities)-import GHC.IO.Encoding (setLocaleEncoding, utf8)-import System.Exit (ExitCode(..))-import qualified System.Posix.Process as Posix (exitImmediately)--import Core.Data.Structures-import Core.Text.Bytes-import Core.Text.Rope-import Core.System.Base-import Core.Program.Context-import Core.Program.Logging-import Core.Program.Signal-import Core.Program.Arguments---- execute actual "main"-executeAction :: Context τ -> Program τ α -> IO ()-executeAction context program =- let- quit = exitSemaphoreFrom context- in do- _ <- subProgram context program- putMVar quit ExitSuccess------- If an exception escapes, we'll catch it here. The displayException--- value for some exceptions is really quit unhelpful, so we pattern--- match the wrapping gumpf away for cases as we encounter them. The--- final entry is the catch-all; the first is what we get from the--- terminate action.----escapeHandlers :: Context c -> [Handler IO ()]-escapeHandlers context = [- Handler (\ (exit :: ExitCode) -> done exit)- , Handler (\ (_ :: AsyncCancelled) -> pass)- , Handler (\ (ExceptionInLinkedThread _ e) -> bail e)- , Handler (\ (e :: SomeException) -> bail e)- ]- where- quit = exitSemaphoreFrom context-- pass :: IO ()- pass = return ()-- done :: ExitCode -> IO ()- done exit = do- putMVar quit exit-- bail :: Exception e => e -> IO ()- bail e =- let- text = intoRope (displayException e)- in do- subProgram context (event text)- putMVar quit (ExitFailure 127)------- If an exception occurs in one of the output handlers, its failure causes--- a subsequent race condition when the program tries to clean up and drain--- the queues. So we use `exitImmediately` (which we normally avoid, as it--- unhelpfully destroys the parent process if you're in ghci) because we--- really need the process to go down and we're in an inconsistent state--- where debug or console output is no longer possible.----collapseHandlers :: [Handler IO ()]-collapseHandlers =- [ Handler (\ (e :: AsyncCancelled) -> do- Base.throwIO e)- , Handler (\ (e :: SomeException) -> do- putStrLn "error: Output handler collapsed"- print e- Posix.exitImmediately (ExitFailure 99))- ]--{-|-Embelish a program with useful behaviours. See module header-"Core.Program.Execute" for a detailed description. Internally this function-calls 'configure' with an appropriate default when initializing.--}-execute :: Program None α -> IO ()-execute program = do- context <- configure "" None (simple [])- executeWith context program--{-|-Embelish a program with useful behaviours, supplying a configuration-for command-line options & argument parsing and an initial value for-the top-level application state, if appropriate.--}-executeWith :: Context τ -> Program τ α -> IO ()-executeWith context program = do- -- command line +RTS -Nn -RTS value- when (numCapabilities == 1) (getNumProcessors >>= setNumCapabilities)-- -- force UTF-8 working around bad VMs- setLocaleEncoding utf8-- let quit = exitSemaphoreFrom context- level = verbosityLevelFrom context- out = outputChannelFrom context- log = loggerChannelFrom context-- -- set up standard output- o <- async $ do- Safe.catchesAsync- (processStandardOutput out)- (collapseHandlers)-- -- set up debug logger- l <- async $ do- Safe.catchesAsync- (processDebugMessages log)- (collapseHandlers)-- -- set up signal handlers- _ <- async $ do- setupSignalHandlers quit level-- -- run actual program, ensuring to trap uncaught exceptions- m <- async $ do- Safe.catchesAsync- (executeAction context program)- (escapeHandlers context)-- code <- readMVar quit- cancel m-- -- drain message queues. Allow 0.1 seconds, then timeout, in case- -- something has gone wrong and queues don't empty.- race_- (do- atomically $ do- done2 <- isEmptyTQueue log- check done2-- done1 <- isEmptyTQueue out- check done1)- (do- threadDelay 100000- putStrLn "error: Timeout")-- threadDelay 100 -- instead of yield- hFlush stdout-- cancel l- cancel o-- -- exiting this way avoids "Exception: ExitSuccess" noise in GHCi- if code == ExitSuccess- then return ()- else (Base.throwIO code)---processStandardOutput :: TQueue Rope -> IO ()-processStandardOutput out = do- forever $ do- text <- atomically (readTQueue out)-- hWrite stdout text- B.hPut stdout (C.singleton '\n')--processDebugMessages :: TQueue Message -> IO ()-processDebugMessages log = do- forever $ do- -- TODO do sactually do something with log messages- -- Message now severity text potentialValue <- ...- _ <- atomically (readTQueue log)-- return ()--{-|-Safely exit the program with the supplied exit code. Current output and-debug queues will be flushed, and then the process will terminate.--}--- putting to the quit MVar initiates the cleanup and exit sequence,--- but throwing the exception also aborts execution and starts unwinding--- back up the stack.-terminate :: Int -> Program τ α-terminate code =- let- exit = case code of- 0 -> ExitSuccess- _ -> ExitFailure code- in do- context <- ask- let quit = exitSemaphoreFrom context- liftIO $ do- putMVar quit exit- Safe.throw exit---- undocumented-getVerbosityLevel :: Program τ Verbosity-getVerbosityLevel = do- context <- ask- liftIO $ do- level <- readMVar (verbosityLevelFrom context)- return level--{-|-Change the verbosity level of the program's logging output. This changes-whether 'event' and the 'debug' family of functions emit to the logging-stream; they do /not/ affect 'write'ing to the terminal on the standard-output stream.--}-setVerbosityLevel :: Verbosity -> Program τ ()-setVerbosityLevel level = do- context <- ask- liftIO $ do- let v = verbosityLevelFrom context- modifyMVar_ v (\_ -> pure level)---{-|-Override the program name used for logging, etc. At least, that was the-idea. Nothing makes use of this at the moment. @:/@--}-setProgramName :: Rope -> Program τ ()-setProgramName name = do- context <- ask- liftIO $ do- let v = programNameFrom context- modifyMVar_ v (\_ -> pure name)--{-|-Get the program name as invoked from the command-line (or as overridden by-'setProgramName').--}-getProgramName :: Program τ Rope-getProgramName = do- context <- ask- liftIO $ do- let v = programNameFrom context- readMVar v--{-|-Get the user supplied application state as originally supplied to-'configure' and modified subsequntly by replacement with-'setApplicationState'.--@- state <- getApplicationState-@--}-getApplicationState :: Program τ τ-getApplicationState = do- context <- ask- liftIO $ do- let v = applicationDataFrom context- readMVar v--{-|-Update the user supplied top-level application state.--@- let state' = state { answer = 42 }- setApplicationState state'-@--}-setApplicationState :: τ -> Program τ ()-setApplicationState user = do- context <- ask- liftIO $ do- let v = applicationDataFrom context- modifyMVar_ v (\_ -> pure user)--{-|-Alias for 'getApplicationState'.--}-retrieve :: Program τ τ-retrieve = getApplicationState--{-|-Alias for 'setApplicationState'.--}-update :: τ -> Program τ ()-update = setApplicationState--{-|-Write the supplied @Bytes@ to the given @Handle@. Note that in contrast to-'write' we don't output a trailing newline.--@- 'output' h b-@--Do /not/ use this to output to @stdout@ as that would bypass the mechanism-used by the 'write'*, 'event', and 'debug'* functions to sequence output-correctly. If you wish to write to the terminal use:--@- 'write' ('intoRope' b)-@--(which is not /unsafe/, but will lead to unexpected results if the binary-blob you pass in is other than UTF-8 text).--}-output :: Handle -> Bytes -> Program τ ()-output handle contents = liftIO (hOutput handle contents)--{-|-Read the (entire) contents of the specified @Handle@.--}-input :: Handle -> Program τ Bytes-input handle = liftIO (hInput handle)--{-|-A thread for concurrent computation. Haskell uses green threads: small-lines of work that are scheduled down onto actual execution contexts, set-by default by this library to be one per core. They are incredibly-lightweight, and you are encouraged to use them freely. Haskell provides a-rich ecosystem of tools to do work concurrently and to communicate safely-between threads--(this wraps __async__'s 'Async')--}-newtype Thread α = Thread (Async α)--unThread :: Thread α -> Async α-unThread (Thread a) = a--{-|-Fork a thread. The child thread will run in the same @Context@ as the-calling @Program@, including sharing the user-defined application state-type.--(this wraps __async__'s 'async' which in turn wraps __base__'s 'Control.Concurrent.forkIO')--}-fork :: Program τ α -> Program τ (Thread α)-fork program = do- context <- ask- liftIO $ do- a <- async $ do- subProgram context program- link a- return (Thread a)--{-|-Pause the current thread for the given number of seconds. For-example, to delay a second and a half, do:--@- 'sleep' 1.5-@--(this wraps __base__'s 'threadDelay')--}------ FIXME is this the right type, given we want to avoid type default warnings?----sleep :: Rational -> Program τ ()-sleep seconds =- let- us = floor (toRational (seconds * 1e6))- in- liftIO $ threadDelay us--{-|-Retrieve the values of parameters parsed from options and arguments-supplied by the user on the command-line.--The command-line parameters are returned in a 'Map', mapping from from the-option or argument name to the supplied value. You can query this map-directly:--@-program = do- params <- 'getCommandLine'- let result = 'lookupKeyValue' \"silence\" (paramterValuesFrom params)- case result of- 'Nothing' -> 'return' ()- 'Just' quiet = case quiet of- 'Value' _ -> 'throw' NotQuiteRight -- complain that flag doesn't take value- 'Empty' -> 'write' \"You should be quiet now\" -- much better- ...-@--which is pattern matching to answer "was this option specified by the-user?" or "what was the value of this [mandatory] argument?", and then "if-so, did the parameter have a value?"--This is available should you need to differentiate between a @Value@ and an-@Empty@ 'ParameterValue', but for many cases as a convenience you can use-the 'lookupOptionFlag', 'lookupOptionValue', and 'lookupArgument' functions-below (which are just wrappers around a code block like the example shown-here).--}-getCommandLine :: Program τ (Parameters)-getCommandLine = do- context <- ask- return (commandLineFrom context)--{-|-Arguments are mandatory, so by the time your program is running a value-has already been identified. This returns the value for that parameter.--}--- this is Maybe because you can inadvertently ask for an unconfigured name--- this could be fixed with a much stronger Config type, potentially.-lookupArgument :: LongName -> Parameters -> Maybe String-lookupArgument name params =- case lookupKeyValue name (parameterValuesFrom params) of- Nothing -> Nothing- Just argument -> case argument of- Empty -> error "Invalid State"- Value value -> Just value--{-|-Look to see if the user supplied a valued option and if so, what its value-was.--}--- Should this be more severe if it encounters Empty?-lookupOptionValue :: LongName -> Parameters -> Maybe String-lookupOptionValue name params =- case lookupKeyValue name (parameterValuesFrom params) of- Nothing -> Nothing- Just argument -> case argument of- Empty -> Nothing- Value value -> Just value--{-|-Returns @Just True@ if the option is present, and @Nothing@ if it is not.--}--- The type is boolean to support a possible future extension of negated--- arguments.-lookupOptionFlag :: LongName -> Parameters -> Maybe Bool-lookupOptionFlag name params =- case lookupKeyValue name (parameterValuesFrom params) of- Nothing -> Nothing- Just argument -> case argument of- _ -> Just True -- nom, nom---{-|-Illegal internal state resulting from what should be unreachable code-or otherwise a programmer error.--}-invalid :: Program τ α-invalid = error "Invalid State"
− lib/Core/Program/Logging.hs
@@ -1,358 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_HADDOCK prune #-}--{-|-Output and Logging from your program.--Broadly speaking, there are two kinds of program: console tools invoked for-a single purpose, and long-running daemons that effectively run forever.--Tools tend to be run to either have an effect (in which case they tend not-to a say much of anything) or to report a result. This tends to be written-to \"standard output\"—traditionally abbreviated in code as @stdout@—which-is usually printed to your terminal.--Daemons, on the other hand, don't write their output to file descriptor 1;-rather they tend to respond to requests by writing to files, replying over-network sockets, or sending up smoke signals (@ECPUTOOHOT@, in case you're-curious). What daemons /do/ output, however, is log messages.--While there are many sophisticated logging services around that you can-interact with directly, from the point of view of an individual /program/-these tend to have faded away and have become more an aspect of the-Infrastructure- or Platform-as-a-Service you're running on. Over the past-few years containerization mechanisms like __docker__, then more recently-container orchestration layers like __kubernetes__, have generally simply-captured programs' standard output /as if it were the program's log output/-and then sent that down external logging channels to whatever log analysis-system is available. Even programs running locally under __systemd__ or-similar tend to follow the same pattern; services write to @stdout@ and-that output, as "logs", ends up being fed to the system journal.--So with that in mind, in your program you will either be outputting results-to @stdout@ or not writing there at all, and you will either be describing-extensively what your application is up to, or not at all. --There is also a \"standard error\" file descriptor available. We recommend-not using it. At best it is unclear what is written to @stderr@ and what-isn't; at worse it is lost as many environments in the wild discard-@stderr@ entirely. To avoid this most of the time people just combine them-in the invoking shell with @2>&1@, which inevitably results in @stderr@-text appearing in the middle of normal @stdout@ lines corrupting them.--The original idea of standard error was to provde a way to report adverse-conditions without interrupting normal text output, but as we have just-observed if it happens without context or out of order there isn't much-point. Instead this library offers a mechanism which caters for the-different /kinds/ of output in a unified, safe manner.--== Three kinds of output/logging messages--/Standard output/--Your program's normal output to the terminal. This library provides the-'write' (and 'writeS' and 'writeR') functions to send output to @stdout@.--/Events/--When running a tool, you sometimes need to know /what it is doing/ as it is-carrying out its steps. The 'event' function allows you to emit descriptive-messages to the log channel tracing the activities of your program.--Ideally you would never need to turn this on in a command-line tool, but-sometimes a user or operations engineer needs to see what an application is-up to. These should be human readable status messages to convey a sense of-progress.--In the case of long-running daemons, 'event' can be used to describe-high-level lifecycle events, to document individual requests, or even-describing individual transitions in a request handler's state machine, all-depending on the nature of your program.--/Debugging/--Programmers, on the other hand, often need to see the internal state of-the program when /debugging/.--You almost always you want to know the value of some variable or parameter,-so the 'debug' (and 'debugS' and 'debugR') utility functions here send-messages to the log channel prefixed with a label that is, by convention,-the name of the value you are examining.--The important distinction here is that such internal values are almost-never useful for someone other than the person or team who wrote the code-emitting it. Operations engineers might be asked by developers to turn on-@--debug@ing and report back the results; but a user of your program is not-going to do that in and of themselves to solve a problem.--== Single output channel--It is the easy to make the mistake of having multiple subsystems attempting-to write to @stdout@ and these outputs corrupting each other, especially in-a multithreaded language like Haskell. The output actions described here-send all output to terminal down a single thread-safe channel. Output will-be written in the order it was executed, and (so long as you don't use the-@stdout@ Handle directly yourself) your terminal output will be sound.--Passing @--verbose@ on the command-line of your program will cause 'event'-to write its tracing messages to the terminal. This shares the same output-channel as the 'write'@*@ functions and will /not/ cause corruption of your-program's normal output.--Passing @--debug@ on the command-line of your program will cause the-'debug'@*@ actions to write their debug-level messages to the terminal.-This shares the same output channel as above and again will not cause-corruption of your program's normal output.--== Logging channel--/Event and debug messages are internally also sent to a "logging channel",/-/as distinct from the "output" one. This would allow us to send them/-/directly to a file, syslog, or network logging service, but this is/-/as-yet unimplemented./--}-module Core.Program.Logging- (- putMessage- , Verbosity(..)- {-* Normal output -}- , write- , writeS- , writeR- {-* Event tracing -}- , event- {-* Debugging -}- , debug- , debugS- , debugR- ) where--import Chrono.TimeStamp (TimeStamp(..), getCurrentTimeNanoseconds)-import Control.Concurrent.MVar (readMVar)-import Control.Concurrent.STM (atomically)-import Control.Concurrent.STM.TQueue (writeTQueue)-import Control.Exception (evaluate)-import Control.Monad (when)-import Control.Monad.Reader.Class (MonadReader(ask))-import Data.Fixed-import Data.Hourglass (timePrint, TimeFormatElem(..))-import qualified Data.Text.Short as S (replicate)--import Core.Text.Rope-import Core.Text.Utilities-import Core.System.Base-import Core.Program.Context--{--class Monad m => MonadLog a m where- logMessage :: Monoid a => Severity -> a -> m () --}--putMessage :: Context τ -> Message -> IO ()-putMessage context message@(Message now _ text potentialValue) = do- let start = startTimeFrom context- let output = outputChannelFrom context- let logger = loggerChannelFrom context-- let display = case potentialValue of- Just value ->- if containsCharacter '\n' value- then text <> " =\n" <> value- else text <> " = " <> value- Nothing -> text-- let result = formatLogMessage start now display-- atomically $ do- writeTQueue output result- writeTQueue logger message---formatLogMessage :: TimeStamp -> TimeStamp -> Rope -> Rope-formatLogMessage start now message =- let- start' = unTimeStamp start- now' = unTimeStamp now- stampZ = timePrint- [ Format_Hour- , Format_Text ':'- , Format_Minute- , Format_Text ':'- , Format_Second- , Format_Text 'Z'- ] now-- -- I hate doing math in Haskell- elapsed = fromRational (toRational (now' - start') / 1e9) :: Fixed E3- in- mconcat- [ intoRope stampZ- , " ("- , padWithZeros 9 (show elapsed)- , ") "- , message- ]------- | Utility function to prepend \'0\' characters to a string representing a--- number.----{-- Cloned from **locators** package Data.Locators.Hashes, BSD3 licence--}-padWithZeros :: Int -> String -> Rope-padWithZeros digits str =- intoRope pad <> intoRope str- where- pad = S.replicate len "0"- len = digits - length str--{-|-Write the supplied text to @stdout@.--This is for normal program output.--@- 'write' "Beginning now"-@--}-write :: Rope -> Program τ ()-write text = do- context <- ask- liftIO $ do- let out = outputChannelFrom context-- !text' <- evaluate text- atomically (writeTQueue out text')--{-|-Call 'show' on the supplied argument and write the resultant text to-@stdout@.--(This is the equivalent of 'print' from __base__)--}-writeS :: Show α => α -> Program τ ()-writeS = write . intoRope . show--{-|-Pretty print the supplied argument and write the resultant text to-@stdout@. This will pass the detected terminal width to the 'render'-function, resulting in appopriate line wrapping when rendering your value.--}-writeR :: Render α => α -> Program τ ()-writeR thing = do- context <- ask- liftIO $ do- let out = outputChannelFrom context- let columns = terminalWidthFrom context-- let text = render columns thing- !text' <- evaluate text- atomically (writeTQueue out text')--{-|-Note a significant event, state transition, status, or debugging-message. This:--@- 'event' "Starting..."-@--will result in--> 13:05:55Z (0000.001) Starting...--appearing on stdout /and/ the message being sent down the logging-channel. The output string is current time in UTC, and time elapsed-since startup shown to the nearest millisecond (our timestamps are to-nanosecond precision, but you don't need that kind of resolution in-in ordinary debugging).--Messages sent to syslog will be logged at @Info@ level severity.--}-event :: Rope -> Program τ ()-event text = do- context <- ask- liftIO $ do- level <- readMVar (verbosityLevelFrom context)- when (isEvent level) $ do- now <- getCurrentTimeNanoseconds- putMessage context (Message now Event text Nothing)--isEvent :: Verbosity -> Bool-isEvent level = case level of- Output -> False- Event -> True- Debug -> True--isDebug :: Verbosity -> Bool-isDebug level = case level of- Output -> False- Event -> False- Debug -> True--{-|-Output a debugging message formed from a label and a value. This is like-'event' above but for the (rather common) case of needing to inspect or-record the value of a variable when debugging code. This:--@- 'setProgramName' \"hello\"- name <- 'getProgramName'- 'debug' \"programName\" name-@--will result in--> 13:05:58Z (0003.141) programName = hello--appearing on stdout /and/ the message being sent down the logging channel,-assuming these actions executed about three seconds after program start.--Messages sent to syslog will be logged at @Debug@ level severity.--}-debug :: Rope -> Rope -> Program τ ()-debug label value = do- context <- ask- liftIO $ do- level <- readMVar (verbosityLevelFrom context)- when (isDebug level) $ do- now <- getCurrentTimeNanoseconds- !value' <- evaluate value- putMessage context (Message now Debug label (Just value'))--{-|-Convenience for the common case of needing to inspect the value-of a general variable which has a 'Show' instance--}-debugS :: Show α => Rope -> α -> Program τ ()-debugS label value = debug label (intoRope (show value))--{-|-Convenience for the common case of needing to inspect the value of a-general variable for which there is a 'Render' instance and so can pretty-print the supplied argument to the log. This will pass the detected-terminal width to the 'render' function, resulting in appopriate line-wrapping when rendering your value (if logging to something other than-console the default width of @80@ will be applied).--}-debugR :: Render α => Rope -> α -> Program τ ()-debugR label thing = do- context <- ask- liftIO $ do- level <- readMVar (verbosityLevelFrom context)- when (isDebug level) $ do- now <- getCurrentTimeNanoseconds-- let columns = terminalWidthFrom context-- -- TODO take into account 22 width already consumed by timestamp- -- TODO move render to putMessage? putMessageR?- let value = render columns thing- !value' <- evaluate value- putMessage context (Message now Debug label (Just value'))-
− lib/Core/Program/Metadata.hs
@@ -1,171 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE OverloadedStrings #-}--{-|-Dig metadata out of the description of your project.--This uses the evil /Template Haskell/ to run code at compile time that-parses the /.cabal/ file for your Haskell project and extracts various-meaningful fields.--}-module Core.Program.Metadata-(- Version- {-* Splice -}- , fromPackage- {-* Internals -}- , versionNumberFrom- , projectNameFrom- , projectSynopsisFrom-)-where--import Core.Data-import Core.Text-import Core.System (withFile, IOMode(..))-import Data.List (intersperse)-import qualified Data.List as List (isSuffixOf, find)-import Data.Maybe (fromMaybe)-import Data.String-import Language.Haskell.TH (Q, runIO)-import Language.Haskell.TH.Syntax (Lift, Exp(..))-import System.Directory (listDirectory)--{-|-Information about the version number of this piece of software and other-related metadata related to the project it was built from. This is supplied-to your program when you call 'Core.Program.Execute.configure'. This value-is used if the user requests it by specifying the @--version@ option on the-command-line.--Simply providing an overloaded string literal such as version @\"1.0\"@-will give you a 'Version' with that value:--@-\{\-\# LANGUAGE OverloadedStrings \#\-\}--main :: 'IO' ()-main = do- context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('Core.Program.Arguments.simple' ...-@---For more complex usage you can populate a 'Version' object using the-'fromPackage' splice below. You can then call various accessors like-'versionNumberFrom' to access individual fields.--}-data Version = Version {- projectNameFrom :: String- , projectSynopsisFrom :: String- , versionNumberFrom :: String-} deriving (Show, Lift)--emptyVersion :: Version-emptyVersion = Version "" "" "0"--instance IsString Version where- fromString x = emptyVersion { versionNumberFrom = x }--{-|-This is a splice which includes key built-time metadata, including the-number from the version field from your project's /.cabal/ file (as written-by hand or generated from /package.yaml/).--While we generally discourage the use of Template Haskell by beginners-(there are more important things to learn first) it is a way to execute-code at compile time and that is what what we need in order to have the-version number extracted from the /.cabal/ file rather than requiring the-user to specify (and synchronize) it in multiple places.--To use this, enable the Template Haskell language extension in your-/Main.hs/ file. Then use the special @$( ... )@ \"insert splice here\"-syntax that extension provides to get a 'Version' object with the desired-metadata about your project:--@-\{\-\# LANGUAGE TemplateHaskell \#\-\}--version :: 'Version'-version = $('fromPackage')--main :: 'IO' ()-main = do- context <- 'Core.Program.Execute.configure' version 'Core.Program.Execute.None' ('Core.Program.Arguments.simple' ...-@--(Using Template Haskell slows down compilation of this file, but the upside-of this technique is that it avoids linking the Haskell build machinery-into your executable, saving you about 10 MB in the size of the resultant-binary)--}-fromPackage :: Q Exp-fromPackage = do- pairs <- readCabalFile-- let name = fromMaybe "" . lookupKeyValue "name" $ pairs- let synopsis = fromMaybe "" . lookupKeyValue "synopsis" $ pairs- let version = fromMaybe "" . lookupKeyValue "version" $ pairs-- let result = Version- { projectNameFrom = fromRope name- , projectSynopsisFrom = fromRope synopsis- , versionNumberFrom = fromRope version- }---- I would have preferred------ let e = AppE (VarE ...--- return e------ but that's not happening. So more voodoo TH nonsense instead.-- [e|result|]---{--Locate the .cabal file in the present working directory (assumed to be the-build root) and use the **Cabal** library to parse the few bits we need out-of it.--}--findCabalFile :: IO FilePath-findCabalFile = do- files <- listDirectory "."- let found = List.find (List.isSuffixOf ".cabal") files- case found of- Just file -> return file- Nothing -> error "No .cabal file found"--readCabalFile :: Q (Map Rope Rope)-readCabalFile = runIO $ do- -- Find .cabal file- file <- findCabalFile-- -- Parse .cabal file- contents <- withFile file ReadMode hInput- let pairs = parseCabalFile contents- -- pass to calling program- return pairs--parseCabalFile :: Bytes -> Map Rope Rope-parseCabalFile contents =- let- breakup = intoMap . fmap (breakRope (== ':')) . breakLines . fromBytes- in- breakup contents---- this should probably be a function in Core.Text.Rope-breakRope :: (Char -> Bool) -> Rope -> (Rope,Rope)-breakRope predicate text =- let- pieces = take 2 (breakPieces predicate text)- in- case pieces of- [] -> ("","")- [one] -> (one,"")- (one:two:_) -> (one, trimRope two)---- knock off the whitespace in "name: hello"-trimRope :: Rope -> Rope-trimRope = mconcat . intersperse " " . breakWords
− lib/Core/Program/Signal.hs
@@ -1,63 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}--module Core.Program.Signal-(- setupSignalHandlers-)-where--import Control.Concurrent.MVar (MVar, putMVar, modifyMVar_)-import Foreign.C.Types (CInt)-import System.Exit (ExitCode(..))-import System.IO (hPutStrLn, hFlush, stdout)-import System.Posix.Signals (Handler(Catch), installHandler,- sigINT, sigTERM, sigUSR1)--import Core.Program.Context------- | Make a non-zero exit code which is 0b1000000 + the number of the--- signal. Probably never need this (especaially given our attempt to--- write out a human readable name for the signal caught) but it's a--- convention we're happy to observe.----code :: CInt -> ExitCode-code signal = ExitFailure (128 + fromIntegral signal)--{-- Technique to have a blocking MVar and signal handlers to set it- adapted from code in vaultaire-common package's Vaultaire.Program,- BSD3 licenced.--}--interruptHandler :: MVar ExitCode -> Handler-interruptHandler quit = Catch $ do- hPutStrLn stdout "\nInterrupt"- hFlush stdout- putMVar quit (code sigINT)--terminateHandler :: MVar ExitCode -> Handler-terminateHandler quit = Catch $ do- hPutStrLn stdout "Terminating"- hFlush stdout- putMVar quit (code sigTERM)--logLevelHandler :: MVar Verbosity -> Handler-logLevelHandler v = Catch $ do- hPutStrLn stdout "Signal"- hFlush stdout- modifyMVar_ v (\level -> case level of- Output -> pure Debug- Event -> pure Debug- Debug -> pure Output)------- | Install signal handlers for SIGINT and SIGTERM that set the exit--- semaphore so that a Program's [minimal] cleanup can occur.----setupSignalHandlers :: MVar ExitCode -> MVar Verbosity -> IO ()-setupSignalHandlers quit level = do- installHandler sigINT (interruptHandler quit) Nothing- installHandler sigTERM (terminateHandler quit) Nothing- installHandler sigUSR1 (logLevelHandler level) Nothing- return ()
− lib/Core/Program/Unlift.hs
@@ -1,160 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# OPTIONS_HADDOCK prune #-}--{-|-The 'Program' monad is an instance of 'MonadIO', which makes sense; it's-just a wrapper around doing 'IO' and you call it using-'execute' from the top-level @main@ action that is the-entrypoint to any program. So when you need to actually do some I/O or-interact with other major libraries in the Haskell ecosystem, you need to-get back to 'IO' and you use 'liftIO' to do it:--@-main :: 'IO' ()-main = 'execute' $ do- -- now in the Program monad- 'write' "Hello there"-- 'liftIO' $ do- -- now something in IO- source <- readFile "hello.c"- compileSourceCode source-- -- back in Program monad- 'write' \"Finished\"-@--and this is a perfectly reasonable pattern.--Sometimes, however, you want to get to the 'Program' monad from /there/,-and that's tricky; you can't just 'execute' a new-program (and don't try: we've already initialized output and logging-channels, signal handlers, your application context, etc).--@-main :: 'IO' ()-main = 'execute' $ do- -- now in the Program monad- 'write' "Hello there"-- 'liftIO' $ do- -- now something in IO- source <- readFile "hello.c"- -- log that we're starting compile ... FIXME how???- result <- compileSourceCode source- case result of- Right object -> linkObjectCode object- Left err -> -- debug the error ... FIXME how???-- -- back in Program monad- 'write' \"Finished\"-@--We have a problem, because we'd like to do is use, say, 'debug' to log the-compiler error, but we have no way to unlift back out of 'IO' to get to the-'Program' monad.--To workaround this, we offer 'withContext'. It gives you a function that-you can then use within your lifted 'IO' to run a (sub)'Program' action:--@-main :: 'IO' ()-main = 'execute' $ do- -- now in the Program monad- 'write' "Hello there"-- 'withContext' $ \\runProgram -> do- -- now lifted to IO- source <- readFile "hello.c"-- runProgram $ do- -- now \"unlifted\" back to Program monad!- 'event' \"Starting compile...\"- 'event' \"Nah. Changed our minds\"- 'event' \"Ok, fine, compile the thing\"-- -- more IO- result <- compileSourceCode source- case result of- 'Right' object -> linkObjectCode object- 'Left' err -> runProgram ('debugS' err)-- -- back in Program monad- 'write' \"Finished\"-@--Sometimes Haskell type inference can give you trouble because it tends to-assume you mean what you say with the last statement of do-notation block.-If you've got the type wrong you'll get an error, but in an odd place,-probably at the top where you have the lambda. This can be confusing. If-you're having trouble with the types try putting @return ()@ at the end of-your subprogram.--}-module Core.Program.Unlift- (- {-* Unlifting -}- withContext- {-* Internals -}- , getContext- , subProgram- ) where--import Core.Program.Context-import Core.Program.Execute-import Core.Program.Logging-import Core.System.Base--{-|-This gives you a function that you can use within your lifted 'IO' actions-to return to the 'Program' monad.--The type signature of this function is a bit involved, but the example below-shows that the lambda gives you a /function/ as its argument (we recommend-you name it @__runProgram__@ for consistency) which gives you a way to run a-subprogram, be that a single action like writing to terminal or logging, or-a larger action in a do-notation block:--@-main :: IO ()-main = 'execute' $ do- 'withContext' $ \\runProgram -> do- -- in IO monad, lifted- -- (just as if you had used liftIO)-- ...-- runProgram $ do- -- now unlifted, back to Program monad-- ...-@--Think of this as 'liftIO' with an escape hatch.--This function is named 'withContext' because it is a convenience around the-following pattern:--@- context <- 'getContext'- liftIO $ do- ...- 'subProgram' context $ do- -- now in Program monad- ...-@--}--- I think I just discovered the same pattern as **unliftio**? Certainly--- the signature is similar. I'm not sure if there is any benefit to--- restating this as a `withRunInIO` action; we're deliberately trying to--- constrain the types.-withContext- :: ((forall β. Program τ β -> IO β) -> IO α)- -> Program τ α-withContext action = do- context <- getContext- let runThing = subProgram context- liftIO (action runThing)-
− lib/Core/System.hs
@@ -1,40 +0,0 @@-{-# OPTIONS_HADDOCK not-home #-}--{-|-Common elements from the rest of the Haskell ecosystem. This is mostly-about re-exports. There are numerous types and functions that are more or-less assumed to be in scope when you're doing much of anything in Haskell;-this module is a convenience to pull in the ones we rely on for the rest of-this library.--You can just import this directly:--@-import "Core.System"-@--as there's no particular benefit to cherry-picking the various sub-modules.---}-module Core.System- (- {-* Base libraries -}-{-|-Re-exports from foundational libraries supplied by the compiler runtime,-or from re-implementations of those areas.--}- module Core.System.Base-- {-* External dependencies -}-{-|-Dependencies from libraries outside the traditional ecosystem of Haskell.-These are typically special cases or custom re-implementations of things-which are maintained either by ourselves or people we are in regular-contact with.--}- , module Core.System.External- ) where--import Core.System.Base-import Core.System.External-
− lib/Core/System/Base.hs
@@ -1,39 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-}-{-# OPTIONS_HADDOCK not-home #-}------- | Re-exports of Haskell base and GHC system libraries.----module Core.System.Base- ( {-* Input/Output -}- {-** from Control.Monad.IO.Class -}- {-| Re-exported from "Control.Monad.IO.Class" in __base__: -}- liftIO- , MonadIO- {-** from System.IO -}- {-| Re-exported from "System.IO" in __base__: -}- , Handle- , IOMode(..)- , withFile- , stdin, stdout, stderr- , hFlush- , unsafePerformIO- {-* Exception handling -}- {-** from Control.Exception.Safe -}- {-| Re-exported from "Control.Exception.Safe" in the __safe-exceptions__ package: -}- , Exception(..)- , SomeException- , throw- , impureThrow- , bracket- , catch- , finally- ) where--import Control.Exception.Safe (Exception(..), SomeException, throw- , bracket, catch, finally, impureThrow)-import Control.Monad.IO.Class (MonadIO, liftIO)-import System.IO (Handle, IOMode(..), withFile, stdin, stdout, stderr, hFlush)-import System.IO.Unsafe (unsafePerformIO)-
− lib/Core/System/External.hs
@@ -1,15 +0,0 @@-{-# OPTIONS_HADDOCK not-home #-}------- | Re-exports of dependencies from various external libraries.----module Core.System.External- ( {-* Time -}- {-** from Chrono.TimeStamp -}- {-| Re-exported from "Chrono.TimeStamp" in __chronologique__: -}- TimeStamp(..)- , getCurrentTimeNanoseconds- ) where--import Chrono.TimeStamp (TimeStamp(..), getCurrentTimeNanoseconds)-
− lib/Core/Text.hs
@@ -1,36 +0,0 @@-{-# OPTIONS_HADDOCK not-home #-}--{-|-A unified Text type providing interoperability between various text-back-ends present in the Haskell ecosystem.--This is intended to be used directly:--@-import "Core.Text"-@--as this module re-exports all of the various components making up this-library's text handling subsystem.--}-module Core.Text- (- {-* Internal representation -}-{-|-Exposes 'Bytes', a wrapper around different types of binary data, and 'Rope',-a finger-tree over buffers containing text.--}- module Core.Text.Bytes- , module Core.Text.Rope-- {-* Useful utilities -}-{-|-Useful functions for common use cases.--}- , module Core.Text.Utilities- ) where--import Core.Text.Bytes-import Core.Text.Rope-import Core.Text.Utilities-
− lib/Core/Text/Breaking.hs
@@ -1,147 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_HADDOCK hide #-}---- This is an Internal module, hidden from Haddock-module Core.Text.Breaking- ( breakWords- , breakLines- , breakPieces- , intoPieces- , intoChunks- )-where--import Data.Char (isSpace)-import Data.Foldable (foldr)-import Data.List (uncons)-import qualified Data.Text.Short as S (ShortText, null, break, uncons,empty)--import Core.Text.Rope--{-|-Split a passage of text into a list of words. A line is broken wherever-there is one or more whitespace characters, as defined by "Data.Char"'s-'Data.Char.isSpace'.--Examples:--@-λ> __breakWords \"This is a test\"__-[\"This\",\"is\",\"a\",\"test\"]-λ> __breakWords (\"St\" <> \"op and \" <> \"go left\")__-[\"Stop\",\"and\",\"go\",\"left\"]-λ> __breakWords emptyRope__-[]-@--}-breakWords :: Rope -> [Rope]-breakWords = filter (not . nullRope) . breakPieces isSpace--{-|-Split a paragraph of text into a list of its individual lines. The-paragraph will be broken wherever there is a @'\n'@ character.--Blank lines will be preserved. Note that as a special case you do /not/ get-a blank entry at the end of the a list of newline terminated strings.--@-λ> __breakLines \"Hello\\n\\nWorld\\n\"__-[\"Hello\",\"\",\"World\"]-@--}-breakLines :: Rope -> [Rope]-breakLines text =- let- result = breakPieces isNewline text- n = length result - 1- (fore,aft) = splitAt n result- in case result of- [] -> []- [p] -> [p]- _ -> if aft == [""]- then fore- else result--isNewline :: Char -> Bool-isNewline c = c == '\n'--{-|-Break a Rope into pieces whereever the given predicate function returns-@True@. If found, that character will not be included on either side. Empty-runs, however, *will* be preserved.--}-breakPieces :: (Char -> Bool) -> Rope -> [Rope]-breakPieces predicate text =- let- x = unRope text- (final,result) = foldr (intoPieces predicate) (Nothing,[]) x- in- case final of- Nothing -> result- Just piece -> intoRope piece : result--{--Was the previous piece a match, or are we in the middle of a run of-characters? If we were, then join the previous run to the current piece-before processing into chunks.--}--- now for right fold-intoPieces :: (Char -> Bool) -> S.ShortText -> (Maybe S.ShortText,[Rope]) -> (Maybe S.ShortText,[Rope])-intoPieces predicate piece (stream,list) =- let- piece' = case stream of- Nothing -> piece- Just previous -> piece <> previous -- more rope, less text?-- pieces = intoChunks predicate piece'- in- case uncons pieces of- Nothing -> (Nothing,list)- Just (text,remainder) -> (Just (fromRope text),remainder ++ list)------- λ> S.break isSpace "a d"--- ("a"," d")------ λ> S.break isSpace " and"--- (""," and")------ λ> S.break isSpace "and "--- ("and"," ")------ λ> S.break isSpace ""--- ("","")------ λ> S.break isSpace " "--- (""," ")-----{--This was more easily expressed as -- let- remainder' = S.drop 1 remainder- in- if remainder == " "--for the case when we were breaking on spaces. But generalized to a predicate-we have to strip off the leading character and test that its the only character;-this is cheaper than S.length etc.--}-intoChunks :: (Char -> Bool) -> S.ShortText -> [Rope]-intoChunks _ piece | S.null piece = []-intoChunks predicate piece =- let- (chunk,remainder) = S.break predicate piece-- -- Handle the special case that a trailing " " (generalized to predicate)- -- is the only character left.- (trailing,remainder') = case S.uncons remainder of- Nothing -> (False,S.empty)- Just (c,remaining) -> if S.null remaining- then (predicate c,S.empty)- else (False,remaining)- in- if trailing- then intoRope chunk : emptyRope : []- else intoRope chunk : intoChunks predicate remainder'
− lib/Core/Text/Bytes.hs
@@ -1,202 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- FIXME-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- FIXME-{-# OPTIONS_HADDOCK prune #-}--{-|-Binary (as opposed to textual) data is encountered in weird corners of the-Haskell ecosystem. We tend to forget (for example) that the content-recieved from a web server is /not/ text until we convert it from UTF-8 (if-that's what it is); and of course that glosses over the fact that something-of content-type @image/jpeg@ is not text in any way, shape, or form.--Bytes also show up when working with crypto algorithms, taking hashes, and-when doing serialization to external binary formats. Although we frequently-display these in terminals (and in URLs!) as text, but we take for granted-that we have actually deserialized the data or rendered the it in-hexidecimal or base64 or...--This module presents a simple wrapper around various representations of-binary data to make it easier to interoperate with libraries supplying-or consuming bytes.--}-module Core.Text.Bytes- ( Bytes- , Binary(fromBytes, intoBytes)- , hOutput- , hInput- , chunk- ) where--import Data.Bits (Bits (..))-import Data.Char (intToDigit)-import qualified Data.ByteString as B (ByteString, foldl', splitAt- , pack, unpack, length, hPut, hGetContents)-import Data.ByteString.Internal (c2w, w2c)-import qualified Data.ByteString.Lazy as L (ByteString, fromStrict, toStrict)-import Data.Hashable (Hashable)-import qualified Data.List as List-import Data.Word (Word8)-import GHC.Generics (Generic)-import Data.Text.Prettyprint.Doc- ( Doc, emptyDoc, pretty, annotate, (<+>), hsep, vcat- , space, punctuate, hcat, group, flatAlt, sep, fillSep- , line, line', softline, softline', hardline- )-import Data.Text.Prettyprint.Doc.Render.Terminal (- color, colorDull, bold, Color(..))-import System.IO (Handle)--import Core.Text.Rope-import Core.Text.Utilities--{-|-A block of data in binary form.--}-data Bytes- = StrictBytes B.ByteString- deriving (Show, Eq, Ord, Generic)--instance Hashable Bytes--{-|-Conversion to and from various types containing binary data into our-convenience Bytes type.--As often as not these conversions are /expensive/; these methods are-here just to wrap calling the relevant functions in a uniform interface.--}-class Binary α where- fromBytes :: Bytes -> α- intoBytes :: α -> Bytes--instance Binary Bytes where- fromBytes = id- intoBytes = id--{-| from "Data.ByteString" Strict -}-instance Binary B.ByteString where- fromBytes (StrictBytes b') = b'- intoBytes b' = StrictBytes b'--{-| from "Data.ByteString.Lazy" -}-instance Binary L.ByteString where- fromBytes (StrictBytes b') = L.fromStrict b'- intoBytes b' = StrictBytes (L.toStrict b') -- expensive--{-| from "Data.Word" -}-instance Binary [Word8] where- fromBytes (StrictBytes b') = B.unpack b'- intoBytes = StrictBytes . B.pack--instance Binary Rope where- fromBytes (StrictBytes b') = intoRope b'- intoBytes = StrictBytes . fromRope--{-|-Output the content of the 'Bytes' to the specified 'Handle'.--@- hOutput h b-@--'Core.Program.Execute.output' provides a convenient way to write a @Bytes@-to a file or socket handle from within the 'Core.Program.Execute.Program'-monad.--Don't use this function to write to @stdout@ if you are using any of the-other output or logging facililities of this libarary as you will corrupt-the ordering of output on the user's terminal. Instead do:--@- 'Core.Program.Execute.write' ('intoRope' b)-@--on the assumption that the bytes in question are UTF-8 (or plain ASCII)-encoded.--}-hOutput :: Handle -> Bytes -> IO ()-hOutput handle (StrictBytes b') = B.hPut handle b'--{-|-Read the (entire) contents of a handle into a Bytes object.--If you want to read the entire contents of a file, you can do:--@- contents <- 'Core.System.Base.withFile' name 'Core.System.Base.ReadMode' 'hInput'-@--At any kind of scale, Streaming I/O is almost always for better, but for-small files you need to pick apart this is fine.--}-hInput :: Handle -> IO Bytes-hInput handle = do- contents <- B.hGetContents handle- return (StrictBytes contents)---- (), aka Unit, aka **1**, aka something with only one inhabitant--instance Render Bytes where- type Token Bytes = ()- colourize = const (color Green)- intoDocA = prettyBytes- -prettyBytes :: Bytes -> Doc ()-prettyBytes (StrictBytes b') = annotate () . vcat . twoWords- . fmap wordToHex . chunk $ b'--twoWords :: [Doc ann] -> [Doc ann]-twoWords ds = go ds- where- go [] = []- go [x] = [softline' <> x]- go xs =- let- (one:two:[], remainder) = List.splitAt 2 xs- in- group (one <> spacer <> two) : go remainder-- spacer = flatAlt softline' " "---chunk :: B.ByteString -> [B.ByteString]-chunk = reverse . go []- where- go acc blob =- let- (eight, remainder) = B.splitAt 8 blob- in- if B.length remainder == 0- then eight : acc- else go (eight : acc) remainder---- Take an [up to] 8 byte (64 bit) word-wordToHex :: B.ByteString -> Doc ann-wordToHex eight =- let- ws = B.unpack eight- ds = fmap byteToHex ws- in- hsep ds--byteToHex :: Word8 -> Doc ann-byteToHex c = pretty hi <> pretty low- where- !low = byteToDigit $ c .&. 0xf- !hi = byteToDigit $ (c .&. 0xf0) `shiftR` 4-- byteToDigit :: Word8 -> Char- byteToDigit = intToDigit . fromIntegral--{--instance Show Bytes where- show x = case x of- StrictBytes b' -> --}
− lib/Core/Text/Rope.hs
@@ -1,482 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StrictData #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--{-|-If you're accustomed to working with text in almost any other programming-language, you'd be aware that a \"string\" typically refers to an in-memory-/array/ of characters. Traditionally this was a single ASCII byte per-character; more recently UTF-8 variable byte encodings which dramatically-complicates finding offsets but which gives efficient support for the-entire Unicode character space. In Haskell, the original text type,-'String', is implemented as a list of 'Char' which, because a Haskell list-is implemented as a /linked-list of boxed values/, is wildly inefficient at-any kind of scale.--In modern Haskell there are two primary ways to represent text.--First is via the [rather poorly named] @ByteString@ from the __bytestring__-package (which is an array of bytes in pinned memory). The-"Data.ByteString.Char8" submodule gives you ways to manipulate those arrays-as if they were ASCII characters. Confusingly there are both strict-(@Data.ByteString@) and lazy (@Data.ByteString.Lazy@) variants which are-often hard to tell the difference between when reading function signatures-or haddock documentation. The performance problem an immutable array backed-data type runs into is that appending a character (that is, ASCII byte) or-concatonating a string (that is, another array of ASCII bytes) is very-expensive and requires allocating a new larger array and copying the whole-thing into it. This led to the development of \"builders\" which amortize-this reallocation cost over time, but it can be cumbersome to switch-between @Builder@, the lazy @ByteString@ that results, and then having to-inevitably convert to a strict @ByteString@ because that's what the next-function in your sequence requires.--The second way is through the opaque @Text@ type of "Data.Text" from the-__text__ package, which is well tuned and high-performing but suffers from-the same design; it is likewise backed by arrays. Rather surprisingly, the-storage backing Text objects are encoded in UTF-16, meaning every time you-want to work with unicode characters that came in from /anywhere/ else and-which inevitably are UTF-8 encoded you have to convert to UTF-16 and copy-into a new array, wasting time and memory.--In this package we introduce 'Rope', a text type backed by the 2-3-'Data.FingerTree.FingerTree' data structure from the __fingertree__-package. This is not an uncommon solution in many languages as finger trees-support exceptionally efficient appending to either end and good-performance inserting anywhere else (you often find them as the backing-data type underneath text editors for this reason). Rather than 'Char' the-pieces of the rope are 'Data.Text.Short.ShortText' from the __text-short__-package, which are UTF-8 encoded and in normal memory managed by the-Haskell runtime. Conversion from other Haskell text types is not /O(1)/-(UTF-8 validity must be checked, or UTF-16 decoded, or...), but in our-benchmarking the performance has been comparable to the established types-and you may find the resultant interface for combining chunks is comparable-to using a Builder, without being forced to use a Builder.--'Rope' is used as the text type throughout this library. If you use the-functions within this package (rather than converting to other text types)-operations are quite efficient. When you do need to convert to another type-you can use 'fromRope' or 'intoRope' from the 'Textual' typeclass.--Note that we haven't tried to cover the entire gamut of operations or-customary convenience functions you would find in the other libraries; so-far 'Rope' is concentrated on aiding interoperation, being good at-appending (lots of) small pieces, and then efficiently taking the resultant-text object out to a file handle, be that the terminal console, a file, or-a network socket.---}-module Core.Text.Rope- ( {-* Rope type -}- Rope- , emptyRope- , widthRope- , splitRope- , insertRope- , containsCharacter- {-* Interoperation and Output -}- , Textual(fromRope, intoRope, appendRope)- , hWrite- {-* Internals -}- , unRope- , nullRope- , unsafeIntoRope- , Width(..)- ) where--import Control.DeepSeq (NFData(..))-import qualified Data.ByteString as B (ByteString)-import qualified Data.ByteString.Builder as B (toLazyByteString- , hPutBuilder)-import qualified Data.ByteString.Lazy as L (ByteString, toStrict- , foldrChunks)-import qualified Data.FingerTree as F (FingerTree, Measured(..), empty- , singleton, (><), (<|), (|>), search, SearchResult(..), null- , viewl, ViewL(..))-import Data.Foldable (foldr, foldr', foldMap, toList, any)-import Data.Hashable (Hashable, hashWithSalt)-import Data.String (IsString(..))-import qualified Data.Text as T (Text)-import qualified Data.Text.Lazy as U (Text, fromChunks, foldrChunks- , toStrict)-import qualified Data.Text.Lazy.Builder as U (Builder, toLazyText- , fromText)-import Data.Text.Prettyprint.Doc (Pretty(..), emptyDoc)-import qualified Data.Text.Short as S (ShortText, length, any, null- , fromText, toText, fromByteString, pack, unpack- , append, empty, toBuilder, splitAt)-import qualified Data.Text.Short.Unsafe as S (fromByteStringUnsafe)-import GHC.Generics (Generic)-import System.IO (Handle)--{-|-A type for textual data. A rope is text backed by a tree data structure,-rather than a single large continguous array, as is the case for strings.--There are three use cases:--/Referencing externally sourced data/--Often we interpret large blocks of data sourced from external systems as-text. Ideally we would hold onto this without copying the memory, but (as-in the case of @ByteString@ which is the most common source of data) before-we can treat it as text we have to validate the UTF-8 content. Safety-first. We also copy it out of pinned memory, allowing the Haskell runtime-to manage the storage.--/Interoperating with other libraries/--The only constant of the Haskell universe is that you won't have the right-combination of {strict, lazy} × {@Text@, @ByteString@, @String@, @[Word8]@,-etc} you need for the next function call. The 'Textual' typeclass provides-for moving between different text representations. To convert between-@Rope@ and something else use 'fromRope'; to construct a @Rope@ from-textual content in another type use 'intoRope'.--You can get at the underlying finger tree with the 'unRope' function.--/Assembling text to go out/--This involves considerable appending of data, very very occaisionally-inserting it. Often the pieces are tiny. To add text to a @Rope@ use the-'appendRope' method as below or the ('Data.Semigroup.<>') operator from-"Data.Monoid" (like you would have with a @Builder@).--Output to a @Handle@ can be done efficiently with 'hWrite'.--}-data Rope- = Rope (F.FingerTree Width S.ShortText)- deriving Generic--instance NFData Rope where- rnf (Rope x) = foldMap (\piece -> rnf piece) x--instance Show Rope where- show text = "\"" ++ fromRope text ++ "\""--instance Eq Rope where- (==) (Rope x1) (Rope x2) = (==) (stream x1) (stream x2)- where- stream x = foldMap S.unpack x--instance Ord Rope where- compare (Rope x1) (Rope x2) = compare x1 x2--instance Pretty Rope where- pretty (Rope x) = foldr ((<>) . pretty . S.toText) emptyDoc x --{-|-Access the finger tree underlying the @Rope@. You'll want the following-imports:--@-import qualified "Data.FingerTree" as F -- from the __fingertree__ package-import qualified "Data.Text.Short" as S -- from the __text-short__ package-@--}-unRope :: Rope -> F.FingerTree Width S.ShortText-unRope (Rope x) = x-{-# INLINE unRope #-}---{-|-The length of the @Rope@, in characters. This is the monoid used to-structure the finger tree underlying the @Rope@.--}-newtype Width = Width Int- deriving (Eq, Ord, Show, Num, Generic)--instance F.Measured Width S.ShortText where- measure :: S.ShortText -> Width- measure piece = Width (S.length piece)--instance Semigroup Width where- (<>) (Width w1) (Width w2) = Width (w1 + w2)--instance Monoid Width where- mempty = Width 0- mappend = (<>)---- here Maybe we just need type Strand = ShortText and then Rope is--- FingerTree Strand or Builder (Strand)--instance IsString Rope where- fromString "" = emptyRope- fromString xs = Rope . F.singleton . S.pack $ xs--instance Semigroup Rope where- (<>) text1@(Rope x1) text2@(Rope x2) =- if F.null x2- then text1- else if F.null x1- then text2- else Rope ((F.><) x1 x2) -- god I hate these operators--instance Monoid Rope where- mempty = emptyRope- mappend = (<>)--{-|-An zero-length 'Rope'. You can also use @\"\"@ presuming the-__@OverloadedStrings@__ language extension is turned on in your source-file.--}-emptyRope :: Rope-emptyRope = Rope F.empty-{-# INLINABLE emptyRope #-}--{-|-Get the length of this text, in characters.--}-widthRope :: Rope -> Int-widthRope = foldr' f 0 . unRope- where- f piece count = S.length piece + count--nullRope :: Rope -> Bool-nullRope (Rope x) = case F.viewl x of- F.EmptyL -> True- (F.:<) piece _ -> S.null piece--{-|-Break the text into two pieces at the specified offset.--Examples:--@-λ> __splitRope 0 \"abcdef\"__-(\"\", \"abcdef\")-λ> __splitRope 3 \"abcdef\"__-(\"abc\", \"def\")-λ> __splitRope 6 \"abcdef\"__-(\"abcdef\",\"\")-@--Going off either end behaves sensibly:--@-λ> __splitRope 7 \"abcdef\"__-(\"abcdef\",\"\")-λ> __splitRope (-1) \"abcdef\"__-(\"\", \"abcdef\")-@--}-splitRope :: Int -> Rope -> (Rope,Rope)-splitRope i text@(Rope x) =- let- pos = Width i- result = F.search (\w1 _ -> w1 >= pos) x- in- case result of- F.Position before piece after ->- let- (Width w) = F.measure before- (one,two) = S.splitAt (i - w) piece- in- (Rope ((F.|>) before one),Rope ((F.<|) two after))- F.OnLeft -> (Rope F.empty, text)- F.OnRight -> (text, Rope F.empty)- F.Nowhere -> error "Position not found in split. Probable cause: predicate function given not monotonic. This is supposed to be unreachable"--{-|-Insert a new piece of text into an existing @Rope@ at the specified offset.--Examples:--@-λ> __insertRope 3 \"Con\" \"Def 1\"__-"DefCon 1"-λ> __insertRope 0 \"United \" \"Nations\"__-"United Nations"-@--}-insertRope :: Int -> Rope -> Rope -> Rope-insertRope 0 (Rope new) (Rope x) = Rope ((F.><) new x)-insertRope i (Rope new) text =- let- (Rope before,Rope after) = splitRope i text- in- Rope (mconcat [before, new, after])------- Manual instance to get around the fact that FingerTree doesn't have a--- Hashable instance. If this were ever to become a hotspot we could--- potentially use the Hashed caching type in the finger tree as------ FingerTree Width (Hashed S.ShortText)------ at the cost of endless unwrapping.----instance Hashable Rope where- hashWithSalt salt (Rope x) = foldr f salt x- where- f :: S.ShortText -> Int -> Int- f piece num = hashWithSalt num piece--{-|-Machinery to interpret a type as containing valid Unicode that can be-represented as a @Rope@ object.--/Implementation notes/--Given that @Rope@ is backed by a finger tree, 'append' is relatively-inexpensive, plus whatever the cost of conversion is. There is a subtle-trap, however: if adding small fragments of that were obtained by slicing-(for example) a large ByteString we would end up holding on to a reference-to the entire underlying block of memory. This module is optimized to-reduce heap fragmentation by letting the Haskell runtime and garbage-collector manage the memory, so instances are expected to /copy/ these-substrings out of pinned memory.--The @ByteString@ instance requires that its content be valid UTF-8. If not-an empty @Rope@ will be returned.--Several of the 'fromRope' implementations are expensive and involve a lot-of intermediate allocation and copying. If you're ultimately writing to a-handle prefer 'hWrite' which will write directly to the output buffer.--}-class Textual α where- {-|-Convert a @Rope@ into another text-like type.- -}- fromRope :: Rope -> α- {-|-Take another text-like type and convert it to a @Rope@.- -}- intoRope :: α -> Rope- {-|-Append some text to this @Rope@. The default implementation is basically a-convenience wrapper around calling 'intoRope' and 'mappend'ing it to your-text (which will work just fine, but for some types more efficient-implementations are possible).- -}- appendRope :: α -> Rope -> Rope- appendRope thing text = text <> intoRope thing--instance Textual (F.FingerTree Width S.ShortText) where- fromRope = unRope- intoRope = Rope--instance Textual Rope where- fromRope = id- intoRope = id- appendRope (Rope x2) (Rope x1) = Rope ((F.><) x1 x2)--{-| from "Data.Text.Short" -}-instance Textual S.ShortText where- fromRope = foldr S.append S.empty . unRope- intoRope = Rope . F.singleton- appendRope piece (Rope x) = Rope ((F.|>) x piece)--{-| from "Data.Text" Strict -}-instance Textual T.Text where- fromRope = U.toStrict . U.toLazyText . foldr f mempty . unRope- where- f :: S.ShortText -> U.Builder -> U.Builder- f piece built = (<>) (U.fromText (S.toText piece)) built-- intoRope t = Rope (F.singleton (S.fromText t))- appendRope chunk (Rope x) = Rope ((F.|>) x (S.fromText chunk))--{-| from "Data.Text.Lazy" -}-instance Textual U.Text where- fromRope (Rope x) = U.fromChunks . fmap S.toText . toList $ x- intoRope t = Rope (U.foldrChunks ((F.<|) . S.fromText) F.empty t)--{-| from "Data.ByteString" Strict -}-instance Textual B.ByteString where- fromRope = L.toStrict . B.toLazyByteString . foldr g mempty . unRope- where- g piece built = (<>) (S.toBuilder piece) built-- -- If the input ByteString does not contain valid UTF-8 then an empty- -- Rope will be returned. That's not ideal.- intoRope b' = case S.fromByteString b' of- Just piece -> Rope (F.singleton piece)- Nothing -> Rope F.empty -- bad-- -- ditto- appendRope b' (Rope x) = case S.fromByteString b' of- Just piece -> Rope ((F.|>) x piece)- Nothing -> (Rope x) -- bad--{-| from "Data.ByteString.Lazy" -}-instance Textual L.ByteString where- fromRope = B.toLazyByteString . foldr g mempty . unRope- where- g piece built = (<>) (S.toBuilder piece) built-- intoRope b' = Rope (L.foldrChunks ((F.<|) . check) F.empty b')- where- check chunk = case S.fromByteString chunk of- Just piece -> piece- Nothing -> S.empty -- very bad--{-|-If you /know/ the input bytes are valid UTF-8 encoded characters, then-you can use this function to convert to a piece of @Rope@.--}-unsafeIntoRope :: B.ByteString -> Rope-unsafeIntoRope = Rope . F.singleton . S.fromByteStringUnsafe--{-| from "Data.String" -}-instance Textual [Char] where- fromRope (Rope x) = foldr h [] x- where- h piece string = (S.unpack piece) ++ string -- ugh- intoRope = Rope . F.singleton . S.pack--{-|-Write the 'Rope' to the given 'Handle'.--@-import "Core.Text"-import "Core.System" -- re-exports stdout--main :: IO ()-main =- let- text :: 'Rope'- text = "Hello World"- in- 'hWrite' 'System.IO.stdout' text-@-because it's tradition.--Uses 'Data.ByteString.Builder.hPutBuilder' internally which saves all kinds-of intermediate allocation and copying because we can go from the-'Data.Text.Short.ShortText's in the finger tree to-'Data.ByteString.Short.ShortByteString' to-'Data.ByteString.Builder.Builder' to the 'System.IO.Handle''s output buffer-in one go.--If you're working in the 'Core.Program.Execute.Program' monad, then-'Core.Program.Execute.write' provides an efficient way to write a @Rope@ to-@stdout@.--}-hWrite :: Handle -> Rope -> IO ()-hWrite handle (Rope x) = B.hPutBuilder handle (foldr j mempty x)- where- j piece built = (<>) (S.toBuilder piece) built--{-|-Does the text contain this character?--We've used it to ask whether there are newlines present in a @Rope@, for-example:--@- if 'containsCharacter' \'\n\' text- then handleComplexCase- else keepItSimple-@--}-containsCharacter :: Char -> Rope -> Bool-containsCharacter q (Rope x) = any j x- where- j piece = S.any (\c -> c == q) piece
− lib/Core/Text/Utilities.hs
@@ -1,271 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_HADDOCK prune #-}--{-|-Useful tools for working with 'Rope's. Support for pretty printing,-multi-line strings, and...--}-module Core.Text.Utilities (- {-* Pretty printing -}- Render(..)- , render- {-* Helpers -}- , indefinite- , breakWords- , breakLines- , breakPieces- , wrap- , underline- {-* Multi-line strings -}- , quote-- -- for testing- , intoPieces- , intoChunks-) where--import qualified Data.FingerTree as F ((<|), ViewL(..), viewl)-import qualified Data.List as List (foldl', dropWhileEnd)-import Data.Monoid ((<>))-import qualified Data.Text as T-import qualified Data.Text.Short as S (ShortText, uncons, toText)-import Data.Text.Prettyprint.Doc (Doc, layoutPretty , reAnnotateS- , pretty, emptyDoc- , LayoutOptions(LayoutOptions)- , PageWidth(AvailablePerLine))-import Data.Text.Prettyprint.Doc.Render.Terminal (renderLazy, AnsiStyle)-import Language.Haskell.TH (litE, stringL)-import Language.Haskell.TH.Quote (QuasiQuoter(QuasiQuoter))--import Core.Text.Rope-import Core.Text.Breaking---- change AnsiStyle to a custom token type, perhaps Ansi, which--- has the escape codes already converted to Rope.--{-|-Types which can be rendered "prettily", that is, formatted by a pretty-printer and embossed with beautiful ANSI colours when printed to the-terminal.--Use 'render' to build text object for later use or "Core.Program.Execute"'s-'Core.Program.Execute.writeR' if you're writing directly to console now.--}--class Render α where- {-|-Which type are the annotations of your Doc going to be expressed in?- -}- type Token α :: *- {-|-Convert semantic tokens to specific ANSI escape tokens- -}- colourize :: Token α -> AnsiStyle- {-|-Arrange your type as a 'Doc' @ann@, annotated with your semantic-tokens.- -}- intoDocA :: α -> Doc (Token α)--instance Render Rope where- type Token Rope = ()- colourize = const mempty- intoDocA = foldr f emptyDoc . unRope- where- f :: S.ShortText -> Doc () -> Doc ()- f piece built = (<>) (pretty (S.toText piece)) built--instance Render Char where- type Token Char = ()- colourize = const mempty- intoDocA c = pretty c--instance (Render a) => Render [a] where- type Token [a] = Token a- colourize = const mempty- intoDocA = mconcat . fmap intoDocA--instance Render T.Text where- type Token T.Text = ()- colourize = const mempty- intoDocA t = pretty t--{-|-Given an object of a type with a 'Render' instance, transform it into a-Rope saturated with ANSI escape codes representing syntax highlighting or-similar colouring, wrapping at the specified @width@.--The obvious expectation is that the next thing you're going to do is send-the Rope to console with:--@- 'Core.Program.Execute.write' ('render' 80 thing)-@--However, the /better/ thing to do is to instead use:--@- 'Core.Program.Execute.writeR' thing-@--which is able to pretty print the document text respecting the available-width of the terminal.--}--- the annotation (_ :: α) of the parameter is to bring type a into scope--- at term level so that it can be used by TypedApplications. Which then--- needed AllowAmbiguousTypes, but with all that finally it works:--- colourize no longer needs a in its type signature.-render :: Render α => Int -> α -> Rope-render columns (thing :: α) =- let- options = LayoutOptions (AvailablePerLine (columns - 1) 1.0)- in- intoRope . renderLazy . reAnnotateS (colourize @α)- . layoutPretty options . intoDocA $ thing------- | Render "a" or "an" in front of a word depending on English's idea of--- whether it's a vowel or not.----indefinite :: Rope -> Rope-indefinite text =- let- x = unRope text- in- case F.viewl x of- F.EmptyL -> text- piece F.:< _ -> case S.uncons piece of- Nothing -> text- Just (c,_) -> if c `elem` ['A','E','I','O','U','a','e','i','o','u']- then intoRope ("an " F.<| x)- else intoRope ("a " F.<| x)--{-|-Often the input text represents a paragraph, but does not have any internal-newlines (representing word wrapping). This function takes a line of text-and inserts newlines to simulate such folding, keeping the line under-the supplied maximum width.--A single word that is excessively long will be included as-is on its own-line (that line will exceed the desired maxium width).--Any trailing newlines will be removed.--}-wrap :: Int -> Rope -> Rope-wrap margin text =- let- built = wrapHelper margin (breakWords text)- in- built--wrapHelper :: Int -> [Rope] -> Rope-wrapHelper _ [] = ""-wrapHelper _ [x] = x-wrapHelper margin (x:xs) =- snd $ List.foldl' (wrapLine margin) (widthRope x, x) xs--wrapLine :: Int -> (Int, Rope) -> Rope -> (Int, Rope)-wrapLine margin (pos,builder) word =- let- wide = widthRope word- wide' = pos + wide + 1- in- if wide' > margin- then (wide , builder <> "\n" <> word)- else (wide', builder <> " " <> word)---underline :: Char -> Rope -> Rope-underline level text =- let- title = fromRope text- line = T.map (\_ -> level) title- in- intoRope line--{-|-Multi-line string literals.--To use these you need to enable the @QuasiQuotes@ language extension-in your source file:--@-\{\-\# LANGUAGE OverloadedStrings \#\-\}-\{\-\# LANGUAGE QuasiQuotes \#\-\}-@--you are then able to easily write a string stretching over several lines.--How best to formatting multi-line string literal within your source code is-an aesthetic judgement. Sometimes you don't care about the whitespace-leading a passage (8 spaces in this example):--@- let message = ['quote'|- This is a test of the Emergency Broadcast System. Do not be- alarmed. If this were a real emergency, someone would have tweeted- about it by now.- |]-@--because you are feeding it into a 'Data.Text.Prettyprint.Doc.Doc' for-pretty printing and know the renderer will convert the whole text into a-single line and then re-flow it. Other times you will want to have the-string as is, literally:--@- let poem = ['quote'|-If the sun- rises- in the- west-you drank- too much- last week.- |]-@--Leading whitespace from the first line and trailing whitespace from the-last line will be trimmed, so this:--@- let value = ['quote'|-Hello- |]-@--is translated to:--@- let value = 'Data.String.fromString' \"Hello\\n\"-@--without the leading newline or trailing four spaces. Note that as string-literals they are presented to your code with 'Data.String.fromString' @::-String -> α@ so any type with an 'Data.String.IsString' instance (as 'Rope'-has) can be constructed from a multi-line @['quote'| ... |]@ literal.---}--- I thought this was going to be more complicated.-quote :: QuasiQuoter-quote = QuasiQuoter- (litE . stringL . trim) -- in an expression- (error "Cannot use [quote| ... |] in a pattern")- (error "Cannot use [quote| ... |] as a type")- (error "Cannot use [quote| ... |] for a declaration")- where- trim :: String -> String- trim = bot . top-- top [] = []- top ('\n':cs) = cs- top str = str-- bot = List.dropWhileEnd (== ' ')-
tests/CheckBytesBehaviour.hs view
@@ -8,6 +8,7 @@ import Test.Hspec import Core.Text.Bytes+import Core.Text.Utilities (byteChunk) checkBytesBehaviour :: Spec checkBytesBehaviour = do@@ -20,4 +21,4 @@ , C.pack "d Bye." ] in do- chunk (C.pack "Hello World! Good Bye.") `shouldBe` expected+ byteChunk (C.pack "Hello World! Good Bye.") `shouldBe` expected
unbeliever.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 name: unbeliever-version: 0.9.3.2+version: 0.10.0.0 license: BSD3 license-file: LICENCE copyright: © 2018-2019 Operational Dynamics Consulting Pty Ltd, and Others maintainer: Andrew Cowie <andrew@operationaldynamics.com> author: Andrew Cowie <andrew@operationaldynamics.com> stability: experimental-tested-with: ghc ==8.6.4+tested-with: ghc ==8.6.5 homepage: https://github.com/oprdyn/unbeliever#readme bug-reports: https://github.com/oprdyn/unbeliever/issues synopsis: Opinionated Haskell Interoperability@@ -20,6 +20,15 @@ <https://github.com/oprdyn/unbeliever/blob/master/README.markdown README> on GitHub. .+ An ancillary aim of this library is to facilitate interoperability. A+ single batteries-included package would make this easier, but the resulting+ dependency footprint would be considerable. The code is thus spread across+ several packages:+ .+ * __core-text__+ * __core-data__+ * __core-program__+ . Useful starting points in the documentation are "Core.Program.Execute" and "Core.Text.Rope". category: System@@ -29,60 +38,6 @@ type: git location: https://github.com/oprdyn/unbeliever -library- exposed-modules:- Core.Data- Core.Data.Structures- Core.Encoding- Core.Encoding.Json- Core.Program- Core.Program.Arguments- Core.Program.Execute- Core.Program.Logging- Core.Program.Metadata- Core.Program.Unlift- Core.Text- Core.Text.Bytes- Core.Text.Rope- Core.Text.Utilities- Core.System- Core.System.Base- Core.System.External- hs-source-dirs: lib- other-modules:- Core.Text.Breaking- Core.Program.Context- Core.Program.Signal- default-language: Haskell2010- ghc-options: -Wall -Wwarn -fwarn-tabs- build-depends:- aeson >=1.4.2.0 && <1.5,- async >=2.2.1 && <2.3,- base >=4.11 && <5,- bytestring >=0.10.8.2 && <0.11,- chronologique >=0.3.1.1 && <0.4,- containers >=0.6.0.1 && <0.7,- deepseq >=1.4.4.0 && <1.5,- directory >=1.3.3.0 && <1.4,- exceptions >=0.10.0 && <0.11,- fingertree >=0.1.4.2 && <0.2,- hashable >=1.2.7.0 && <1.3,- hourglass >=0.2.12 && <0.3,- mtl >=2.2.2 && <2.3,- prettyprinter >=1.2.1 && <1.3,- prettyprinter-ansi-terminal >=1.1.1.2 && <1.2,- safe-exceptions >=0.1.7.0 && <0.2,- scientific >=0.3.6.2 && <0.4,- stm >=2.5.0.0 && <2.6,- template-haskell >=2.14.0.0 && <2.15,- terminal-size >=0.3.2.1 && <0.4,- text >=1.2.3.1 && <1.3,- text-short >=0.1.2 && <0.2,- transformers >=0.5.6.2 && <0.6,- unix >=2.7.2.2 && <2.8,- unordered-containers >=0.2.9.0 && <0.3,- vector >=0.12.0.2 && <0.13- test-suite check type: exitcode-stdio-1.0 main-is: TestSuite.hs@@ -97,34 +52,16 @@ default-language: Haskell2010 ghc-options: -Wall -Wwarn -fwarn-tabs -threaded build-depends:- aeson >=1.4.2.0 && <1.5,- async >=2.2.1 && <2.3, base >=4.11 && <5, bytestring >=0.10.8.2 && <0.11,- chronologique >=0.3.1.1 && <0.4,- containers >=0.6.0.1 && <0.7,- deepseq >=1.4.4.0 && <1.5,- directory >=1.3.3.0 && <1.4,- exceptions >=0.10.0 && <0.11,+ core-data ==0.2.*,+ core-program ==0.2.*,+ core-text ==0.2.*, fingertree >=0.1.4.2 && <0.2,- hashable >=1.2.7.0 && <1.3,- hourglass >=0.2.12 && <0.3, hspec >=2.6.1 && <2.7,- mtl >=2.2.2 && <2.3,- prettyprinter >=1.2.1 && <1.3,- prettyprinter-ansi-terminal >=1.1.1.2 && <1.2, safe-exceptions >=0.1.7.0 && <0.2,- scientific >=0.3.6.2 && <0.4,- stm >=2.5.0.0 && <2.6,- template-haskell >=2.14.0.0 && <2.15,- terminal-size >=0.3.2.1 && <0.4, text >=1.2.3.1 && <1.3,- text-short >=0.1.2 && <0.2,- transformers >=0.5.6.2 && <0.6,- unbeliever -any,- unix >=2.7.2.2 && <2.8,- unordered-containers >=0.2.9.0 && <0.3,- vector >=0.12.0.2 && <0.13+ text-short >=0.1.2 && <0.2 benchmark performance type: exitcode-stdio-1.0@@ -133,31 +70,10 @@ default-language: Haskell2010 ghc-options: -Wall -Wwarn -fwarn-tabs -threaded build-depends:- aeson >=1.4.2.0 && <1.5,- async >=2.2.1 && <2.3, base >=4.11 && <5, bytestring >=0.10.8.2 && <0.11,- chronologique >=0.3.1.1 && <0.4,- containers >=0.6.0.1 && <0.7,- deepseq >=1.4.4.0 && <1.5,- directory >=1.3.3.0 && <1.4,- exceptions >=0.10.0 && <0.11,- fingertree >=0.1.4.2 && <0.2,+ core-data ==0.2.*,+ core-program ==0.2.*,+ core-text ==0.2.*, gauge >=0.2.4 && <0.3,- hashable >=1.2.7.0 && <1.3,- hourglass >=0.2.12 && <0.3,- mtl >=2.2.2 && <2.3,- prettyprinter >=1.2.1 && <1.3,- prettyprinter-ansi-terminal >=1.1.1.2 && <1.2,- safe-exceptions >=0.1.7.0 && <0.2,- scientific >=0.3.6.2 && <0.4,- stm >=2.5.0.0 && <2.6,- template-haskell >=2.14.0.0 && <2.15,- terminal-size >=0.3.2.1 && <0.4,- text >=1.2.3.1 && <1.3,- text-short >=0.1.2 && <0.2,- transformers >=0.5.6.2 && <0.6,- unbeliever -any,- unix >=2.7.2.2 && <2.8,- unordered-containers >=0.2.9.0 && <0.3,- vector >=0.12.0.2 && <0.13+ text >=1.2.3.1 && <1.3