diff --git a/lib/Core/Data.hs b/lib/Core/Data.hs deleted file mode 100644 --- a/lib/Core/Data.hs +++ /dev/null @@ -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 - diff --git a/lib/Core/Data/Structures.hs b/lib/Core/Data/Structures.hs deleted file mode 100644 --- a/lib/Core/Data/Structures.hs +++ /dev/null @@ -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) diff --git a/lib/Core/Encoding.hs b/lib/Core/Encoding.hs deleted file mode 100644 --- a/lib/Core/Encoding.hs +++ /dev/null @@ -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 - diff --git a/lib/Core/Encoding/Json.hs b/lib/Core/Encoding/Json.hs deleted file mode 100644 --- a/lib/Core/Encoding/Json.hs +++ /dev/null @@ -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 #-} - diff --git a/lib/Core/Program.hs b/lib/Core/Program.hs deleted file mode 100644 --- a/lib/Core/Program.hs +++ /dev/null @@ -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 - diff --git a/lib/Core/Program/Arguments.hs b/lib/Core/Program/Arguments.hs deleted file mode 100644 --- a/lib/Core/Program/Arguments.hs +++ /dev/null @@ -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 - diff --git a/lib/Core/Program/Context.hs b/lib/Core/Program/Context.hs deleted file mode 100644 --- a/lib/Core/Program/Context.hs +++ /dev/null @@ -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 diff --git a/lib/Core/Program/Execute.hs b/lib/Core/Program/Execute.hs deleted file mode 100644 --- a/lib/Core/Program/Execute.hs +++ /dev/null @@ -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" diff --git a/lib/Core/Program/Logging.hs b/lib/Core/Program/Logging.hs deleted file mode 100644 --- a/lib/Core/Program/Logging.hs +++ /dev/null @@ -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')) - diff --git a/lib/Core/Program/Metadata.hs b/lib/Core/Program/Metadata.hs deleted file mode 100644 --- a/lib/Core/Program/Metadata.hs +++ /dev/null @@ -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 diff --git a/lib/Core/Program/Signal.hs b/lib/Core/Program/Signal.hs deleted file mode 100644 --- a/lib/Core/Program/Signal.hs +++ /dev/null @@ -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 () diff --git a/lib/Core/Program/Unlift.hs b/lib/Core/Program/Unlift.hs deleted file mode 100644 --- a/lib/Core/Program/Unlift.hs +++ /dev/null @@ -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) - diff --git a/lib/Core/System.hs b/lib/Core/System.hs deleted file mode 100644 --- a/lib/Core/System.hs +++ /dev/null @@ -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 - diff --git a/lib/Core/System/Base.hs b/lib/Core/System/Base.hs deleted file mode 100644 --- a/lib/Core/System/Base.hs +++ /dev/null @@ -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) - diff --git a/lib/Core/System/External.hs b/lib/Core/System/External.hs deleted file mode 100644 --- a/lib/Core/System/External.hs +++ /dev/null @@ -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) - diff --git a/lib/Core/Text.hs b/lib/Core/Text.hs deleted file mode 100644 --- a/lib/Core/Text.hs +++ /dev/null @@ -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 - diff --git a/lib/Core/Text/Breaking.hs b/lib/Core/Text/Breaking.hs deleted file mode 100644 --- a/lib/Core/Text/Breaking.hs +++ /dev/null @@ -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' diff --git a/lib/Core/Text/Bytes.hs b/lib/Core/Text/Bytes.hs deleted file mode 100644 --- a/lib/Core/Text/Bytes.hs +++ /dev/null @@ -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' -> --} diff --git a/lib/Core/Text/Rope.hs b/lib/Core/Text/Rope.hs deleted file mode 100644 --- a/lib/Core/Text/Rope.hs +++ /dev/null @@ -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 diff --git a/lib/Core/Text/Utilities.hs b/lib/Core/Text/Utilities.hs deleted file mode 100644 --- a/lib/Core/Text/Utilities.hs +++ /dev/null @@ -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 (== ' ') - diff --git a/tests/CheckBytesBehaviour.hs b/tests/CheckBytesBehaviour.hs --- a/tests/CheckBytesBehaviour.hs +++ b/tests/CheckBytesBehaviour.hs @@ -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 diff --git a/unbeliever.cabal b/unbeliever.cabal --- a/unbeliever.cabal +++ b/unbeliever.cabal @@ -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 author: Andrew Cowie 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 @@ 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