packages feed

unbeliever (empty) → 0.7.3.0

raw patch · 31 files changed

+5139/−0 lines, 31 filesdep +Cabaldep +aesondep +async

Dependencies added: Cabal, aeson, async, base, bytestring, chronologique, containers, deepseq, directory, exceptions, fingertree, gauge, hashable, hourglass, hspec, mtl, prettyprinter, prettyprinter-ansi-terminal, safe-exceptions, scientific, stm, template-haskell, terminal-size, text, text-short, transformers, unbeliever, unix, unordered-containers, vector

Files

+ LICENCE view
@@ -0,0 +1,32 @@+Opinionated Haskell Interoperability++Copyright © 2018 Operational Dynamics Consulting, Pty Ltd and Others+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++    1. Redistributions of source code must retain the above copyright+       notice, this list of conditions and the following disclaimer.++    2. Redistributions in binary form must reproduce the above+       copyright notice, this list of conditions and the following+       disclaimer in the documentation and/or other materials provided+       with the distribution.+      +    3. Neither the name of the project nor the names of its contributors+       may be used to endorse or promote products derived from this +       software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ bench/GeneralPerformance.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS -fno-warn-unused-do-bind #-}++import Gauge.Main+import GHC.Conc++import qualified Data.ByteString as B+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import qualified Data.Text.Lazy as U+import qualified Data.Text.Lazy.Builder as U+import System.IO++import Core.Text.Rope++main :: IO ()+main = do+    b' <- B.readFile "LICENCE"+    let bodyText = T.decodeUtf8 b'+    let bodyRope = intoRope b'++    GHC.Conc.setNumCapabilities 4+    defaultMain+        [ bgroup "to-file"+            [ bench "data-text" (nfIO (runTextToFile (httpResponseText bodyText)))+            , bench "core-rope" (nfIO (runRopeToFile (httpResponseRope bodyRope)))+            ]+        , bgroup "convert-to-rope"+            [ bench "original" (nf (complexMess intoRope) b')+            , bench "experiment" (nf (complexMess unsafeIntoRope) b')+            ]+        ]+    putStrLn "Complete."++----++runTextToFile :: U.Builder -> IO ()+runTextToFile build = do +    withFile "/tmp/garbage-text.txt" WriteMode $ \handle -> do+        T.hPutStr handle (U.toStrict (U.toLazyText build))++runRopeToFile :: Rope -> IO ()+runRopeToFile text = do +    withFile "/tmp/garbage-rope.txt" WriteMode $ \handle -> do+        hWrite handle text++----++httpResponseText :: T.Text -> U.Builder+httpResponseText body =+    "HTTP/1.1" <> " " <> "200 OK" <> "\r\n" <>+    "Cache-Control" <> ": " <> "no-cache, must-revalidate" <> "\r\n" <>+    "Connection" <> ": " <> "keep-alive" <> "\r\n" <>+    "Content-Length" <> ": " <> "1609" <> "\r\n" <>+    "Content-Type" <> ": " <> "text/plain; charset=utf-8" <> "\r\n" <>+    "Date" <> ": " <> "Sun, 23 Sep 2018 09:16:05 GMT" <> "\r\n" <>+    "Expires" <> ": " <> "Thu, 01 Jan 1970 05:05:05 GMT" <> "\r\n" <>+    "Server" <> ": " <> "nginx/1.9.15" <> "\r\n" <>+    "Vary" <> ": " <> "Accept, Accept-Language" <> "\r\n" <>+    "\r\n" <>+    U.fromText body++httpResponseRope :: Rope -> Rope+httpResponseRope body =+    "HTTP/1.1" <> " " <> "200 OK" <> "\r\n" <>+    "Cache-Control" <> ": " <> "no-cache, must-revalidate" <> "\r\n" <>+    "Connection" <> ": " <> "keep-alive" <> "\r\n" <>+    "Content-Length" <> ": " <> "1609" <> "\r\n" <>+    "Content-Type" <> ": " <> "text/plain; charset=utf-8" <> "\r\n" <>+    "Date" <> ": " <> "Sun, 23 Sep 2018 09:16:05 GMT" <> "\r\n" <>+    "Expires" <> ": " <> "Thu, 01 Jan 1970 05:05:05 GMT" <> "\r\n" <>+    "Server" <> ": " <> "nginx/1.9.15" <> "\r\n" <>+    "Vary" <> ": " <> "Accept, Accept-Language" <> "\r\n" <>+    "\r\n" <>+    body++complexMess :: (B.ByteString -> Rope) -> B.ByteString -> Rope+complexMess f body =+    "HTTP/1.1" <> " " <> "200 OK" <> "\n" <>+    "Cache-Control" <> ": " <> "no-cache, must-revalidate" <> "\n" <>+    "Connection" <> ": " <> "keep-alive" <> "\n" <>+    "Content-Length" <> ": " <> "1609" <> "\n" <>+    "Content-Type" <> ": " <> "text/plain; charset=utf-8" <> "\n" <>+    "Date" <> ": " <> "Sun, 23 Sep 2018 09:16:05 GMT" <> "\n" <>+    "Expires" <> ": " <> "Thu, 01 Jan 1970 05:05:05 GMT" <> "\n" <>+    "Server" <> ": " <> "nginx/1.9.15" <> "\n" <>+    "Vary" <> ": " <> "Accept, Accept-Language" <> "\n" <>+    "\n" <>+    f body
+ lib/Core/Data.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_HADDOCK not-home #-}++{-|+Wrappers and adaptors for various data structures common in the Haskell+ecosystem.++This is intended to be used directly:++@+import "Core.Data"+@++as this module re-exports all of its various components.+-}+module Core.Data+    (+        {-* Wrappers -}+{-|+Exposes 'Map', a wrapper around a dictionary type, and 'Set', for+collections of elements.+-}+        module Core.Data.Structures+    ) where++import Core.Data.Structures+
+ lib/Core/Data/Structures.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-|+Convenience wrappers around dictionary and collection types and tools+facilitating conversion between them and various map and set types in+common use in the Haskell ecosystem.+-}+module Core.Data.Structures+(+      {-* Map type -}+      Map+    , emptyMap+    , singletonMap+    , insertKeyValue+    , containsKey+    , lookupKeyValue++      {-* Conversions -}+    , Dictionary(K, V, fromMap, intoMap)++      {-* Set type -}+    , Set+    , emptySet+    , singletonSet+    , insertElement+    , containsElement++      {-* Conversions -}+    , Collection(E, fromSet, intoSet)++      {-* Internals -}+    , Key+    , unMap+    , unSet+)+where++import Data.Foldable (Foldable(..))+import Data.Hashable (Hashable)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.HashSet as HashSet+import qualified Data.Map.Strict as OrdMap+import qualified Data.Set as OrdSet+import qualified Data.Text as T (Text)+import qualified Data.Text.Lazy as U (Text)+import qualified GHC.Exts as Exts (IsList(..))++import Core.Text.Rope (Rope)+import Core.Text.Bytes (Bytes)++-- Naming convention used throughout this file is (Thing u) where u is the+-- underlying structure [from unordered-containers] wrapped in the Thing+-- newtype. Leaves p for our Map and s for our Set in tests.++{-|+A mapping from keys to values.++The keys in a map needs to be an instance of the 'Key' typeclass.+Instances are already provided for many common element types.++'Map' implements 'Foldable', 'Monoid', etc so many common operations such+as 'foldr' to reduce the structure with a right fold, 'length' to get the+number of key/value pairs in the dictionary, 'null' to test whether the+map is empty, and ('<>') to join two maps together are available.++To convert to other dictionary types see 'fromMap' below.++(this is a thin wrapper around __unordered-containers__'s+'Data.HashMap.Strict.HashMap', but if you use the conversion functions to+extract the key/value pairs in a list the list will be ordered according to+the keys' 'Ord' instance)+-}+newtype Map κ ν = Map (HashMap.HashMap κ ν)+    deriving (Show, Eq)++unMap :: Map κ ν -> HashMap.HashMap κ ν+unMap (Map u) = u+{-# INLINE unMap #-}++{-|+Types that can be used as keys in dictionaries or elements in collections.++To be an instance of 'Key' a type must implement both 'Hashable' and 'Ord'.+This requirement means we can subsequently offer easy conversion+between different the dictionary and collection types you might encounter+when interacting with other libraries.++Instances for this library's 'Rope' and 'Bytes' are provided here, along+with many other common types.+-}+class (Hashable κ, Ord κ) => Key κ++instance Key String+instance Key Rope+instance Key Bytes+instance Key T.Text+instance Key U.Text+instance Key Char+instance Key Int++instance Foldable (Map κ) where+    foldr f start (Map u) = HashMap.foldr f start u+    null (Map u) = HashMap.null u+    length (Map u) = HashMap.size u++{-|+A dictionary with no key/value mappings.+-}+emptyMap :: Map κ ν+emptyMap = Map (HashMap.empty)++{-|+Construct a dictionary with only a single key/value pair.+-}+singletonMap :: Key κ => κ -> ν -> Map κ ν+singletonMap k v = Map (HashMap.singleton k v)++{-|+Insert a key/value pair into the dictionary. If the key is already present+in the dictionary, the old value will be discarded and replaced with the+value supplied here.+-}+insertKeyValue :: Key κ => κ -> ν -> Map κ ν -> Map κ ν+insertKeyValue k v (Map u) = Map (HashMap.insert k v u)++{-|+If the dictionary contains the specified key, return the value associated+with that key.+-}+lookupKeyValue :: Key κ => κ -> Map κ ν -> Maybe ν+lookupKeyValue k (Map u) = HashMap.lookup k u++{-|+Does the dictionary contain the specified key?+-}+containsKey :: Key κ => κ -> Map κ ν -> Bool+containsKey k (Map u) = HashMap.member k u++{-|+-}+instance Key κ => Semigroup (Map κ ν) where+    (<>) (Map u1) (Map u2) = Map (HashMap.union u1 u2)++instance Key κ => Monoid (Map κ ν) where+    mempty = emptyMap+    mappend = (<>)++instance Key κ => Exts.IsList (Map κ ν) where+    type Item (Map κ ν) = (κ, ν)+    fromList pairs = Map (HashMap.fromList pairs)+    toList (Map u) = HashMap.toList u++{-|+Types that represent key/value pairs that can be converted to 'Map's.+Haskell's ecosystem has several such. This typeclass provides an adaptor to+get between them. It also allows you to serialize out to an association+list.++For example, to convert a 'Map' to an \"association list\" of key/value+pairs, use 'fromMap':++@+    answers :: 'Map' 'Rope' 'Int'+    answers = 'singletonMap' \"Life, The Universe, and Everything\" 42++    list :: [('Rope','Int')]+    list = 'fromMap' answers+@++Instances are provided for __containers__'s 'Data.Map.Strict.Map' and+__unordered-containers__'s 'Data.HashMap.Strict.HashMap' in addition to the+instance for @[(κ,ν)]@ lists shown above.+-}+--+-- Getting an instance for [(κ,ν)] was very difficult. The approach+-- implemented below was suggested by Xia Li-yao, @Lysxia was to use+-- type families.+--+-- >   "Maybe you can change your type class to be indexed by the fully+-- >   applied dictionary type, instead of a type constructor * -> * -> *"+--+-- https://stackoverflow.com/questions/53554687/list-instances-for-higher-kinded-types/53556313+--+-- Many thanks for an elegant solution to the problem.+--+class Dictionary α where+    type K α :: *+    type V α :: *+    fromMap :: Map (K α) (V α) -> α+    intoMap :: α -> Map (K α) (V α)++instance Key κ => Dictionary (Map κ ν) where+    type K (Map κ ν) = κ+    type V (Map κ ν) = ν+    fromMap = id+    intoMap = id++{-| from "Data.HashMap.Strict" (and .Lazy) -}+instance Key κ => Dictionary (HashMap.HashMap κ ν) where+    type K (HashMap.HashMap κ ν) = κ+    type V (HashMap.HashMap κ ν) = ν+    fromMap (Map u) = u+    intoMap u = Map u++{-| from "Data.Map.Strict" (and .Lazy) -}+instance Key κ => Dictionary (OrdMap.Map κ ν) where+    type K (OrdMap.Map κ ν) = κ+    type V (OrdMap.Map κ ν) = ν+    fromMap (Map u) = HashMap.foldrWithKey OrdMap.insert OrdMap.empty u+    intoMap o = Map (OrdMap.foldrWithKey HashMap.insert HashMap.empty o)++instance Key κ => Dictionary [(κ,ν)] where+    type K [(κ,ν)] = κ+    type V [(κ,ν)] = ν+    fromMap (Map u) = OrdMap.toList (HashMap.foldrWithKey OrdMap.insert OrdMap.empty u)+    intoMap kvs = Map (HashMap.fromList kvs)++{-|+A set of unique elements.++The element type needs to be an instance of the same 'Key' typeclass that+is used for keys in the 'Map' type above. Instances are already provided+for many common element types.++'Set' implements 'Foldable', 'Monoid', etc so many common operations such+as 'foldr' to walk the elements and reduce them, 'length' to return the+size of the collection, 'null' to test whether is empty, and ('<>') to take+the union of two sets are available.++To convert to other collection types see 'fromSet' below.++(this is a thin wrapper around __unordered-containers__'s+'Data.HashSet.HashSet', but if you use the conversion functions to extract+a list the list will be ordered according to the elements' 'Ord' instance)+-}+newtype Set ε = Set (HashSet.HashSet ε)+    deriving (Show, Eq)++unSet :: Set ε -> HashSet.HashSet ε+unSet (Set u) = u+{-# INLINE unSet #-}++instance Foldable Set where+    foldr f start (Set u) = HashSet.foldr f start u+    null (Set u) = HashSet.null u+    length (Set u) = HashSet.size u++instance Key ε => Semigroup (Set ε) where+    (<>) (Set u1) (Set u2) = Set (HashSet.union u1 u2)++instance Key ε => Monoid (Set ε) where+    mempty = emptySet+    mappend = (<>)++{-|+An empty collection. This is used for example as an inital value when+building up a 'Set' using a fold.+-}+emptySet :: Key ε => Set ε+emptySet = Set (HashSet.empty)++{-|+Construct a collection comprising only the supplied element.+-}+singletonSet :: Key ε => ε -> Set ε+singletonSet e = Set (HashSet.singleton e)++{-|+Insert a new element into the collection. Since the 'Set' type does not+allow duplicates, inserting an element already in the collection has no+effect.+-}+insertElement :: Key ε => ε -> Set ε -> Set ε+insertElement e (Set u) = Set (HashSet.insert e u)++{-|+Does the collection contain the specified element?+-}+containsElement :: Key ε => ε -> Set ε -> Bool+containsElement e (Set u) = HashSet.member e u++{-|+Types that represent collections of elements that can be converted to+'Set's.  Haskell's ecosystem has several such. This typeclass provides an+adaptor to convert between them.++This typeclass also provides a mechanism to serialize a 'Set' out to a+Haskell list. The list will be ordered according to the 'Ord' instance of+the element type.++Instances are provided for __containers__'s 'Data.Set.Set' and+__unordered-containers__'s 'Data.HashSet.HashSet' in addition to the+instance for @[ε]@ lists described above.+-}+class Collection α where+    type E α :: *+    fromSet :: Set (E α) -> α+    intoSet :: α -> Set (E α)++instance Key ε => Collection (Set ε) where+    type E (Set ε) = ε+    fromSet = id+    intoSet = id++{-| from "Data.HashSet" -}+instance Key ε => Collection (HashSet.HashSet ε) where+    type E (HashSet.HashSet ε) = ε+    fromSet (Set u) = u+    intoSet u = Set u++{-| from "Data.Set" -}+instance Key ε => Collection (OrdSet.Set ε) where+    type E (OrdSet.Set ε) = ε+    fromSet (Set u) = HashSet.foldr OrdSet.insert OrdSet.empty u+    intoSet u = Set (OrdSet.foldr HashSet.insert HashSet.empty u)++instance Key ε => Collection [ε] where+    type E [ε] = ε+    fromSet (Set u) = OrdSet.toList (HashSet.foldr OrdSet.insert OrdSet.empty u)+    intoSet es = Set (HashSet.fromList es)
+ lib/Core/Encoding.hs view
@@ -0,0 +1,26 @@+{-# OPTIONS_HADDOCK not-home #-}++{-|+Various formats used for serialization, data transfer, and configuration.++This can be used by simply importing the top level module:++@+import "Core.Encoding"+@++although the individual formats are quite usable indepedently.++Each of these encodings are backed by a popular and well tuned library in+wide use across the Haskell community; these modules are here as wrappers+providing for ease of use and interoperability across the various tools in+this package.++-}+module Core.Encoding+    (+        module Core.Encoding.Json+    ) where++import Core.Encoding.Json+
+ lib/Core/Encoding/Json.hs view
@@ -0,0 +1,353 @@+{-# 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.++To use this module, you may find the following imports helpful:++@+\{\-\# LANGUAGE OverloadedStrings \#\-\}+\{\-\# LANGUAGE OverloadedLists \#\-\}++import "Data.HashMap.Strict" ('HashMap')+import qualified "Data.HashMap.Strict" as 'HashMap'  -- from the __unordered-containers__ package.+import "Data.Scientific" ('Scientific')              -- from the __scientific__ package+import "Core.Encoding.Json"+@++Often you'll be working with literals directly in your code. While you can+write:++@+    j = JsonObject (HashMap.fromList [(JsonKey "answer", JsonNumber 42)])+@++and it would be correct, enabling @OverloadedStrings@ and @OverloadedLists@+allows you to write:++@+    j = JsonObject [("answer", 42)]+@++which you is somewhat less cumbersome. You're certainly welcome to use the+constructors if you find it makes for more readable code or if you need+the type annotations.++-}+--+-- As currently implemented this module, in conjunction with+-- Core.Text, is the opposite of efficient. The idea right now is to+-- experiment with the surface API. If it stabilizes, then the fact+-- that our string objects are already in UTF-8 will make for a very+-- efficient emitter.+--+module Core.Encoding.Json+      ( {-* Encoding and Decoding -}+        encodeToUTF8+      , decodeFromUTF8+      , JsonValue(..)+      , JsonKey(..)+        {-* Syntax highlighting -}+{-|+Support for pretty-printing JSON values with syntax highlighting using the+__prettyprinter__ library. To output a JSON structure to terminal+colourized with ANSI escape codes you can use the 'Render' instance:++@+    debug "j" (render j)+@++will get you:++@+23:46:04Z (00000.007) j =+{+    "answer": 42.0+}+@++-}+      , JsonToken(..)+      , colourizeJson+      , prettyKey+      , prettyValue+    ) where++import qualified Data.Aeson as Aeson+import Data.Coerce+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Hashable (Hashable)+import Data.Text.Prettyprint.Doc+    ( Doc, Pretty(..), viaShow, dquote, comma, punctuate, lbracket+    , rbracket, vsep, (<+>), indent, lbrace, rbrace+    , line, sep, hcat, annotate+    , unAnnotate, line', group, nest+    )+import Data.Text.Prettyprint.Doc.Render.Terminal+    ( color, colorDull, Color(..)+    )+import Data.Text.Prettyprint.Doc.Render.Terminal (AnsiStyle)+import Data.Scientific (Scientific)+import Data.String (IsString(..))+import qualified Data.Text as T+import qualified Data.Vector as V+import GHC.Generics++import Core.Data.Structures (Map, Key, fromMap, intoMap)+import Core.Text.Bytes (Bytes, intoBytes, fromBytes)+import Core.Text.Rope (Rope, Textual, intoRope, fromRope)+import Core.Text.Utilities (Render(..))++{-|+Given a JSON value, encode it to UTF-8 bytes++I know we're not /supposed/ to rely on types to document functions, but+really, this one does what it says on the tin.+-}+encodeToUTF8 :: JsonValue -> Bytes+encodeToUTF8 = intoBytes . Aeson.encode . intoAeson++{-|+Given an array of bytes, attempt to decode it as a JSON value.+-}+decodeFromUTF8 :: Bytes -> Maybe JsonValue+decodeFromUTF8 b =+  let+    x :: Maybe Aeson.Value+    x = Aeson.decodeStrict' (fromBytes b)+  in+    fmap fromAeson x++{-|+A JSON value.+-}+data JsonValue+    = JsonObject (Map JsonKey JsonValue)+    | JsonArray [JsonValue]+    | JsonString Rope+    | JsonNumber Scientific+    | JsonBool Bool+    | JsonNull+    deriving (Eq, Show, Generic)++--+-- Overloads so that Haskell code literals can be interpreted as JSON+-- values. Obviously these are a lot on the partial side, but what else are+-- you supposed to do? This is all Haskell gives us for getting at+-- literals.+--+instance IsString JsonValue where+    fromString :: String -> JsonValue+    fromString = JsonString . intoRope++instance Num JsonValue where+    fromInteger = JsonNumber . fromInteger+    (+) = error "Sorry, you can't add JsonValues"+    (-) = error "Sorry, you can't negate JsonValues"+    (*) = error "Sorry, you can't multiply JsonValues"+    abs = error "Sorry, not applicable for JsonValues"+    signum = error "Sorry, not applicable for JsonValues"++instance Fractional JsonValue where+    fromRational :: Rational -> JsonValue+    fromRational = JsonNumber . fromRational+    (/) = error "Sorry, you can't do division on JsonValues"+++intoAeson :: JsonValue -> Aeson.Value+intoAeson value = case value of+    JsonObject xm ->+        let+            kvs = fromMap xm+            tvs = fmap (\(k, v) -> (fromRope (coerce k), intoAeson v)) kvs+            tvm :: HashMap T.Text Aeson.Value+            tvm = HashMap.fromList tvs+        in+            Aeson.Object tvm++    JsonArray xs ->+        let+            vs = fmap intoAeson xs+        in+            Aeson.Array (V.fromList vs)++    JsonString x -> Aeson.String (fromRope x)+    JsonNumber x -> Aeson.Number x+    JsonBool x -> Aeson.Bool x+    JsonNull -> Aeson.Null++{-|+    Keys in a JSON object.+-}+newtype JsonKey+    = JsonKey Rope+    deriving (Eq, Show, Generic, IsString, Ord)++instance Hashable JsonKey+instance Key JsonKey+++-- FIXME what is this instance?+instance Aeson.ToJSON Rope where+    toJSON text = Aeson.toJSON (fromRope text :: T.Text) -- BAD++instance Textual JsonKey where+    fromRope t = coerce t+    intoRope x = coerce x+++fromAeson :: Aeson.Value -> JsonValue+fromAeson value = case value of+    Aeson.Object o ->+        let+            tvs = HashMap.toList o+            kvs = fmap (\(k, v) -> (JsonKey (intoRope k), fromAeson v)) tvs++            kvm :: Map JsonKey JsonValue+            kvm = intoMap kvs+        in+            JsonObject kvm++    Aeson.Array v -> JsonArray (fmap fromAeson (V.toList v))+    Aeson.String t -> JsonString (intoRope t)+    Aeson.Number n -> JsonNumber n+    Aeson.Bool x -> JsonBool x+    Aeson.Null -> JsonNull++--+-- Pretty printing+--++data JsonToken+    = SymbolToken+    | QuoteToken+    | KeyToken+    | StringToken+    | EscapeToken+    | NumberToken+    | BooleanToken+    | LiteralToken++instance Render JsonValue where+    type Token JsonValue = JsonToken+    colourize = colourizeJson+    intoDocA = prettyValue++instance Render JsonKey where+    type Token JsonKey = JsonToken+    colourize = colourizeJson+    intoDocA = prettyKey++instance Render Aeson.Value where+    type Token Aeson.Value = JsonToken+    colourize = colourizeJson+    intoDocA = prettyValue . fromAeson++--+--  Ugh. If you want to experiment with narrower output, then:+--+--            . layoutPretty (LayoutOptions {layoutPageWidth = AvailablePerLine 15 1.0}) . prettyValue+--+{-|+Used by the 'Render' instance to turn symbolic annotations into ANSI colours annotations.+If you're curious, the render pipeline looks like:++@+    render = 'intoText' . 'renderStrict' . 'reAnnotateS' 'colourize'+                . 'layoutPretty' 'defaultLayoutOptions' . 'prettyValue'+@+-}+colourizeJson :: JsonToken -> AnsiStyle+colourizeJson token = case token of+    SymbolToken -> color Black+    QuoteToken -> color Black+    KeyToken -> color Blue+    StringToken -> colorDull Cyan+    EscapeToken -> colorDull Yellow+    NumberToken -> colorDull Green+    BooleanToken -> color Magenta+    LiteralToken -> colorDull Blue+++instance Pretty JsonKey where+    pretty = unAnnotate . prettyKey++prettyKey :: JsonKey -> Doc JsonToken+prettyKey (JsonKey t) =+    annotate QuoteToken dquote <>+    annotate KeyToken (pretty (fromRope t :: T.Text)) <>+    annotate QuoteToken dquote++instance Pretty JsonValue where+    pretty = unAnnotate . prettyValue++prettyValue :: JsonValue -> Doc JsonToken+prettyValue value = case value of+    JsonObject xm ->+        let+            pairs = fromMap xm+            entries = fmap (\(k, v) -> (prettyKey k) <> annotate SymbolToken ":" <+> clear v (prettyValue v)) pairs++            clear v doc = case v of+                (JsonObject _)  -> line <> doc+                (JsonArray _)   -> group doc+                _               -> doc+        in+            if length entries == 0+                then annotate SymbolToken (lbrace <> rbrace)+                else annotate SymbolToken lbrace <> line <> indent 4 (vsep (punctuate (annotate SymbolToken comma) entries)) <> line <> annotate SymbolToken rbrace++    JsonArray xs ->+        let+            entries = fmap prettyValue xs+        in+            line' <>+            nest 4 (+                annotate SymbolToken lbracket <>    -- first line not indented+                line' <>+                sep (punctuate (annotate SymbolToken comma) entries)+            ) <>+            line' <>+            annotate SymbolToken rbracket++    JsonString x ->+            annotate QuoteToken dquote <>+            annotate StringToken (escapeText x) <>+            annotate QuoteToken dquote++    JsonNumber x -> annotate NumberToken (viaShow x)++    JsonBool x -> case x of+        True -> annotate BooleanToken "true"+        False -> annotate BooleanToken "false"++    JsonNull -> annotate LiteralToken "null"+{-# INLINEABLE prettyValue #-}++escapeText :: Rope -> Doc JsonToken+escapeText text =+  let+    t = fromRope text :: T.Text+    ts = T.split (== '"') t+    ds = fmap pretty ts+  in+    hcat (punctuate (annotate EscapeToken "\\\"") ds)+{-# INLINEABLE escapeText #-}+
+ lib/Core/Program.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_HADDOCK not-home #-}++{-|+Support for building command-line programs, ranging from simple tools to+long-running daemons.++This is intended to be used directly:++@+import "Core.Program"+@++the submodules are mostly there to group documentation.+-}+-- actually, they're there to group implementation too, but hey.+module Core.Program+    (+        {-* Executing a program -}+{-|+A top-level Program type giving you unified access to logging, concurrency,+and more.+-}+        module Core.Program.Execute+      , module Core.Program.Unlift+      , module Core.Program.Metadata++        {-* Command-line argument parsing -}+{-|+Including declaring what options your program accepts, generating help, and+for more complex cases [sub]commands, mandatory arguments, and environment+variable handling.+-}+      , module Core.Program.Arguments+        {-* Logging facilities -}+{-|+Facilities for noting events through your program and doing debugging.+-}+      , module Core.Program.Logging+    ) where++import Core.Program.Arguments+import Core.Program.Execute+import Core.Program.Logging+import Core.Program.Metadata+import Core.Program.Unlift+
+ lib/Core/Program/Arguments.hs view
@@ -0,0 +1,841 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StrictData #-}+{-# OPTIONS_HADDOCK prune #-}++{-|+Invoking a command-line program (be it tool or daemon) consists of listing+the name of its binary, optionally supplying various options to adjust the+behaviour of the program, and then supplying mandatory arguments, if any+are specified.++On startup, we parse any arguments passed in from the shell into+@name,value@ pairs and incorporated into the resultant configuration stored+in the program's Context.++Additionally, this module allows you to specify environment variables that,+if present, will be incorporated into the stored configuration.+-}+module Core.Program.Arguments+    ( +        {-* Setup -}+        Config+      , blank+      , simple+      , complex+      , baselineOptions+      , Parameters(..)+      , ParameterValue(..)+        {-* Options and Arguments -}+      , LongName(..)+      , ShortName+      , Description+      , Options(..)+        {-* Programs with Commands -}+      , Commands(..)+        {-* Internals -}+      , parseCommandLine+      , extractValidEnvironments+      , InvalidCommandLine(..)+      , buildUsage+      , buildVersion+    ) where++import Control.Exception.Safe (Exception(displayException))+import Data.Hashable (Hashable)+import qualified Data.List as List+import Data.Maybe (fromMaybe)+import Data.Text.Prettyprint.Doc (Doc, Pretty(..), nest, fillCat+    , emptyDoc, hardline, softline, fillBreak, align, (<+>), fillSep, indent)+import Data.Text.Prettyprint.Doc.Util (reflow)+import Data.String+import System.Environment (getProgName)++import Core.Data.Structures+import Core.System.Base+import Core.Text.Rope+import Core.Text.Utilities+import Core.Program.Metadata++{-|+Single letter "short" options (omitting the "@-@" prefix, obviously).+-}+type ShortName = Char++{-|+The description of an option, command, or environment variable (for use+when rendering usage information in response to @--help@ on the+command-line).+-}+type Description = Rope++{-|+The name of an option, command, or agument (omitting the "@--@" prefix in+the case of options). This identifier will be used to generate usage text+in response to @--help@ and by you later when retreiving the values of the+supplied parameters after the program has initialized.++Turn on __@OverloadedStrings@__ when specifying configurations, obviously.+-}+newtype LongName = LongName String+    deriving (Show, IsString, Eq, Hashable, Ord)++instance Key LongName++instance Pretty LongName where+    pretty (LongName name) = pretty name++{-|+The setup for parsing the command-line arguments of your program. You build+a @Config@ with 'simple' or 'complex', and pass it to+'Core.Program.Context.configure'.+-}+data Config+    = Blank+    | Simple [Options]+    | Complex [Commands]++--+-- Those constructors are not exposed [and functions wrapping them are] partly+-- for documentation convenience, partly for aesthetics (after a point too many+-- constructors got a bit hard to differentiate betwen), and mostly so that if+-- configure's argument turns into a monad like RequestBuilder we have+-- somewhere to make that change.+--++{-|+A completely empty configuration, without the default debugging and logging+options. Your program won't process any command-line options or arguments,+which would be weird in most cases. Prefer 'simple'.+-}+blank :: Config+blank = Blank++{-|+Declare a simple (as in normal) configuration for a program with any number+of optional parameters and mandatory arguments. For example:++@+main :: 'IO' ()+main = do+    context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('simple'+        [ 'Option' "host" ('Just' \'h\') 'Empty' ['quote'|+            Specify an alternate host to connect to when performing the+            frobnication. The default is \"localhost\".+          |]+        , 'Option' "port" ('Just' \'p\') 'Empty' ['quote'|+            Specify an alternate port to connect to when frobnicating.+          |]+        , 'Option' "dry-run" 'Nothing' ('Value' \"TIME\") ['quote'|+            Perform a trial run at the specified time but don't actually+            do anything.+          |]+        , 'Option' "quiet" ('Just' \'q\') 'Empty' ['quote'|+            Supress normal output.+          |]+        , 'Argument' "filename" ['quote'|+            The file you want to frobnicate.+          |]+        ])++    'Core.Program.Execute.executeWith' context program+@++which, if you build that into an executable called @snippet@ and invoke it+with @--help@, would result in:++@+$ __./snippet --help__+Usage:++    snippet [OPTIONS] filename++Available options:++  -h, --host     Specify an alternate host to connect to when performing the+                 frobnication. The default is \"localhost\".+  -p, --port     Specify an alternate port to connect to when frobnicating.+      --dry-run=TIME+                 Perform a trial run at the specified time but don't+                 actually do anything.+  -q, --quiet    Supress normal output.+  -v, --verbose  Turn on event tracing. By default the logging stream will go+                 to standard output on your terminal.+      --debug    Turn on debug level logging. Implies --verbose.++Required arguments:++  filename       The file you want to frobnicate.+$ __|__+@++For information on how to use the multi-line string literals shown here,+see 'quote' in "Core.Text.Utilities".+-}+simple :: [Options] -> Config+simple options = Simple (options ++ baselineOptions)++{-|+Declare a complex configuration (implying a larger tool with various+"[sub]commands" or "modes"} for a program. You can specify global options+applicable to all commands, a list of commands, and environment variables+that will be honoured by the program. Each command can have a list of local+options and arguments as needed. For example:++@+program :: 'Core.Program.Execute.Program' MusicAppStatus ()+program = ...++main :: 'IO' ()+main = do+    context <- 'Core.Program.Execute.configure' ('Core.Program.Execute.fromPackage' version) 'mempty' ('complex'+        [ 'Global'+            [ 'Option' "station-name" 'Nothing' ('Value' \"NAME\") ['quote'|+                Specify an alternate radio station to connect to when performing+                actions. The default is \"BBC Radio 1\".+              |]+            , 'Variable' \"PLAYER_FORCE_HEADPHONES\" ['quote'|+                If set to @1@, override the audio subsystem to force output+                to go to the user's headphone jack.+              |]+            ]+        , 'Command' \"play\" \"Play the music.\"+            [ 'Option' "repeat" 'Nothing' 'Empty' ['quote'|+                Request that they play the same song over and over and over+                again, simulating the effect of listening to a Top 40 radio+                station.+              |]+            ]+        , 'Command' \"rate\" \"Vote on whether you like the song or not.\"+            [ 'Option' "academic" 'Nothing' 'Empty' ['quote'|+                The rating you wish to apply, from A+ to F. This is the+                default, so there is no reason whatsoever to specify this.+                But some people are obsessive, compulsive, and have time on+                their hands.+              |]+            , 'Option' "numeric" 'Nothing' 'Empty' ['quote'|+                Specify a score as a number from 0 to 100 instead of an+                academic style letter grade. Note that negative values are+                not valid scores, despite how vicerally satisfying that+                would be for music produced in the 1970s.+              |]+            , 'Option' "unicode" ('Just' \'c\') 'Empty' ['quote'|+                Instead of a score, indicate your rating with a single+                character.  This allows you to use emoji, so that you can+                rate a piece \'💩\', as so many songs deserve.+              |]+            , 'Argument' "score" ['quote'|+                The rating you wish to apply.+              |]+            ]+        ])++    'Core.Program.Execute.executeWith' context program+@++is a program with one global option (in addition to the default ones) [and+an environment variable] and two commands: @play@, with one option; and+@rate@, with two options and a required argument. It also is set up to+carry its top-level application state around in a type called+@MusicAppStatus@ (implementing 'Monoid' and so initialized here with+'mempty'. This is a good pattern to use given we are so early in the+program's lifetime).++The resultant program could be invoked as in these examples:++@+$ __./player --station-name=\"KBBL-FM 102.5\" play__+$+@++@+$ __./player -v rate --numeric 76__+$+@++For information on how to use the multi-line string literals shown here,+see 'quote' in "Core.Text.Utilities".+-}+complex :: [Commands] -> Config+complex commands = Complex (commands ++ [Global baselineOptions])++{-|+Description of the command-line structure of a program which has+\"commands\" (sometimes referred to as \"subcommands\") representing+different modes of operation. This is familiar from tools like /git/+and /docker/.+-}+data Commands +    = Global [Options]+    | Command LongName Description [Options]++{-|+Declaration of an optional switch or mandatory argument expected by a+program.++'Option' takes a long name for the option, a short single character+abbreviation if offered for convenience, whether or not the option takes a+value (and what label to show in help output) and a description for use+when displaying usage via @--help@.++'Argument' indicates a mandatory argument and takes the long name used+to identify the parsed value from the command-line, and likewise a+description for @--help@ output.++By convention option and argument names are both /lower case/. If the+identifier is two or more words they are joined with a hyphen. Examples:++@+        [ 'Option' \"quiet\" ('Just' \'q'\) 'Empty' \"Keep the noise to a minimum.\"+        , 'Option' \"dry-run\" 'Nothing' ('Value' \"TIME\") \"Run a simulation of what would happen at the specified time.\"+        , 'Argument' \"username\" \"The user to delete from the system.\"+        ]+@++By convention a /description/ is one or more complete sentences each of+which ends with a full stop. For options that take values, use /upper case/+when specifying the label to be used in help output.++'Variable' declares an /environment variable/ that, if present, will be+read by the program and stored in its runtime context. By convention these+are /upper case/. If the identifier is two or more words they are joined+with an underscore:++@+        [ ...+        , 'Variable' \"CRAZY_MODE\" "Specify how many crazies to activate."+        , ...+        ]+@+-}+data Options+    = Option LongName (Maybe ShortName) ParameterValue Description+    | Argument LongName Description+    | Variable LongName Description+++{-|+Individual parameters read in off the command-line can either have a value+(in the case of arguments and options taking a value) or be empty (in the+case of options that are just flags).+-}+data ParameterValue+    = Value String+    | Empty+    deriving (Show, Eq)++instance IsString ParameterValue where+    fromString x = Value x++{-|+Result of having processed the command-line and the environment. You get at+the parsed command-line options and arguments by calling+'Core.Program.Execute.getCommandLine' within a+'Core.Program.Execute.Program' block.++Each option and mandatory argument parsed from the command-line is either+standalone (in the case of switches and flags, such as @--quiet@) or has an+associated value. In the case of options the key is the name of the option,+and for arguments it is the implicit name specified when setting up the+program. For example, in:++@+$ ./submit --username=gbmh GraceHopper_Resume.pdf+@++the option has parameter name \"@username@\" and value \"@gmbh@\"; the+argument has parameter name \"filename\" (assuming that is what was+declared in the 'Argument' entry) and a value being the Admiral's CV. This+would be returned as:++@+'Parameters' 'Nothing' [("username","gbmh"), ("filename","GraceHopper_Resume.pdf")] []+@++The case of a complex command such as /git/ or /stack/, you get the specific+mode chosen by the user returned in the first position:++@+$ missiles launch --all+@++would be parsed as:++@+'Parameters' ('Just' \"launch\") [("all",Empty)] []+@++-}+data Parameters+    = Parameters {+          commandNameFrom :: Maybe LongName+        , parameterValuesFrom :: Map LongName ParameterValue+        , environmentValuesFrom :: Map LongName ParameterValue+    } deriving (Show, Eq)+++baselineOptions :: [Options]+baselineOptions =+    [ Option "verbose" (Just 'v') Empty [quote|+        Turn on event tracing. By default the logging stream will go to+        standard output on your terminal.+    |]+    , Option "debug" Nothing Empty [quote|+        Turn on debug level logging. Implies --verbose.+    |]+    ]++{-|+Different ways parsing a simple or complex command-line can fail.+-}+data InvalidCommandLine+    = InvalidOption String  {-^ Something was wrong with the way the user specified [usually a short] option. -}+    | UnknownOption String  {-^ User specified an option that doesn't match any in the supplied configuration. -}+    | MissingArgument LongName+                            {-^ Arguments are mandatory, and this one is missing. -}+    | UnexpectedArguments [String]+                            {-^ Arguments are present we weren't expecting. -}+    | UnknownCommand String {-^ In a complex configuration, user specified a command that doesn't match any in the configuration. -}+    | NoCommandFound        {-^ In a complex configuration, user didn't specify a command. -}+    | HelpRequest (Maybe LongName)+                            {-^ In a complex configuration, usage information was requested with @--help@, either globally or for the supplied command. -}+    | VersionRequest+                            {-^ Display of the program version requested with @--version@. -}+    deriving (Show, Eq)++instance Exception InvalidCommandLine where+    displayException e = case e of+        InvalidOption arg ->+          let+            one = "Option '" ++ arg ++ "' illegal.\n\n"+            two = [quote|+Options must either be long form with a double dash, for example:++    --verbose++or, when available with a short version, a single dash and a single+character. They need to be listed individually:++    -v -a++When an option takes a value it has to be in long form and the value+indicated with an equals sign, for example:++    --tempdir=/tmp++with complex values escaped according to the rules of your shell:++    --username="Ada Lovelace"++For options valid in this program, please see --help.+        |]+          in+            one ++ two+        UnknownOption name -> "Sorry, option '" ++ name ++ "' not recognized."+        MissingArgument (LongName name) -> "Mandatory argument '" ++ name ++ "' missing."+        UnexpectedArguments args ->+          let+            quoted = List.intercalate "', '" args+          in [quote|+Unexpected trailing arguments:++|] ++ quoted ++ [quote|++For arguments expected by this program, please see --help.+|]+        UnknownCommand first -> "Hm. Command '" ++ first ++ "' not recognized."+        NoCommandFound -> [quote|+No command specified.+Usage is of the form:++    |] ++ programName ++ [quote| [GLOBAL OPTIONS] COMMAND [LOCAL OPTIONS] [ARGUMENTS]++See --help for details.+|]+        -- handled by parent module calling back into here buildUsage+        HelpRequest _ -> ""++        -- handled by parent module calling back into here buildVersion+        VersionRequest -> ""++programName :: String+programName = unsafePerformIO getProgName++{-|+Given a program configuration schema and the command-line arguments,+process them into key/value pairs in a Parameters object.++This results in 'InvalidCommandLine' on the left side if one of the passed+in options is unrecognized or if there is some other problem handling+options or arguments (because at that point, we want to rabbit right back+to the top and bail out; there's no recovering).++This isn't something you'll ever need to call directly; it's exposed for+testing convenience. This function is invoked when you call+'Core.Program.Context.configure' or 'Core.Program.Execute.execute' (which+calls 'configure' with a default @Config@ when initializing).+-}+parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters+parseCommandLine config argv = case config of+    Blank -> return (Parameters Nothing emptyMap emptyMap)++    Simple options -> do+        params <- extractor Nothing options argv+        return (Parameters Nothing params emptyMap)++    Complex commands ->+      let+        globalOptions = extractGlobalOptions commands+        modes = extractValidModes commands+      in do+        (possibles,first,remainingArgs) <- splitCommandLine argv+        params1 <- extractor Nothing globalOptions possibles+        (mode,localOptions) <- parseIndicatedCommand modes first+        params2 <- extractor (Just mode) localOptions remainingArgs+        return (Parameters (Just mode) ((<>) params1 params2) emptyMap)+  where++    extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine (Map LongName ParameterValue)+    extractor mode options args =+      let+        (possibles,arguments) = List.partition isOption args+        valids = extractValidNames options+        shorts = extractShortNames options+        needed = extractRequiredArguments options+      in do+        list1 <- parsePossibleOptions mode valids shorts possibles+        list2 <- parseRequiredArguments needed arguments+        return ((<>) (intoMap list1) (intoMap list2))++isOption :: String -> Bool+isOption arg = case arg of+    ('-':_) -> True+    _ -> False++parsePossibleOptions+    :: Maybe LongName+    -> Set LongName+    -> Map ShortName LongName+    -> [String]+    -> Either InvalidCommandLine [(LongName,ParameterValue)]+parsePossibleOptions mode valids shorts args = mapM f args+  where+    f arg = case arg of+        "--help" -> Left (HelpRequest mode)+        "-?"     -> Left (HelpRequest mode)+        "--version" -> Left VersionRequest+        ('-':'-':name) -> considerLongOption name+        ('-':c:[]) -> considerShortOption c+        _ -> Left (InvalidOption arg)++    considerLongOption :: String -> Either InvalidCommandLine (LongName,ParameterValue)+    considerLongOption arg =+      let+        (name,value) = List.span (/= '=') arg +        candidate = LongName name+        -- lose the '='+        value' = case List.uncons value of+            Just (_,remainder) -> Value remainder+            Nothing -> Empty+      in+        if containsElement candidate valids+            then Right (candidate,value')+            else Left (UnknownOption ("--" ++ name))++    considerShortOption :: Char -> Either InvalidCommandLine (LongName,ParameterValue)+    considerShortOption c =+        case lookupKeyValue c shorts of+            Just name -> Right (name,Empty)+            Nothing -> Left (UnknownOption ['-',c])++parseRequiredArguments+    :: [LongName]+    -> [String]+    -> Either InvalidCommandLine [(LongName,ParameterValue)]+parseRequiredArguments needed argv = iter needed argv+  where+    iter :: [LongName] -> [String] -> Either InvalidCommandLine [(LongName,ParameterValue)]++    iter [] [] = Right []+    -- more arguments supplied than expected+    iter [] args = Left (UnexpectedArguments args)+    -- more arguments required, not satisfied+    iter (name:_) [] = Left (MissingArgument name)+    iter (name:names) (arg:args) =+        let+            deeper = iter names args+        in case deeper of+            Left e -> Left e+            Right list -> Right ((name,Value arg):list)++parseIndicatedCommand+    :: Map LongName [Options]+    -> String+    -> Either InvalidCommandLine (LongName,[Options])+parseIndicatedCommand modes first =+  let+    candidate = LongName first+  in+    case lookupKeyValue candidate modes of+        Just options -> Right (candidate,options)+        Nothing -> Left (UnknownCommand first)++--+-- Ok, the f,g,h,... was silly. But hey :)+--++extractValidNames :: [Options] -> Set LongName+extractValidNames options =+    foldr f emptySet options+  where+    f :: Options -> Set LongName -> Set LongName+    f (Option longname _ _ _) valids = insertElement longname valids+    f _ valids = valids++extractShortNames :: [Options] -> Map ShortName LongName+extractShortNames options =+    foldr g emptyMap options+  where+    g :: Options -> Map ShortName LongName -> Map ShortName LongName+    g (Option longname shortname _ _) shorts = case shortname of+        Just shortchar -> insertKeyValue shortchar longname shorts+        Nothing -> shorts+    g _ shorts = shorts++extractRequiredArguments :: [Options] -> [LongName]+extractRequiredArguments arguments =+    foldr h [] arguments+  where+    h :: Options -> [LongName] -> [LongName]+    h (Argument longname _) needed = longname:needed+    h _ needed = needed++extractGlobalOptions :: [Commands] -> [Options]+extractGlobalOptions commands =+    foldr j [] commands+  where+    j :: Commands -> [Options] -> [Options]+    j (Global options) valids = options ++ valids+    j _ valids = valids++extractValidModes :: [Commands] -> Map LongName [Options]+extractValidModes commands =+    foldr k emptyMap commands+  where+    k :: Commands -> Map LongName [Options] -> Map LongName [Options]+    k (Command longname _ options) modes = insertKeyValue longname options modes+    k _ modes = modes++splitCommandLine :: [String] -> Either InvalidCommandLine ([String], String, [String])+splitCommandLine args =+  let+    (possibles,remainder) = List.span isOption args+    x = List.uncons remainder+  in+    case x of+        Just (mode,remainingArgs) -> Right (possibles,mode,remainingArgs)+        Nothing -> if (List.elem "--help" possibles)+            then Left (HelpRequest Nothing)+            else Left NoCommandFound++--+-- Environment variable handling+--++extractValidEnvironments :: Maybe LongName -> Config -> Set LongName+extractValidEnvironments mode config = case config of+    Blank -> emptySet++    Simple options -> extractVariableNames options++    Complex commands ->+      let+        globals = extractGlobalOptions commands+        variables1 = extractVariableNames globals++        locals = extractLocalVariables commands (fromMaybe "" mode)+        variables2 = extractVariableNames locals+      in+        variables1 <> variables2++extractLocalVariables :: [Commands] -> LongName -> [Options]+extractLocalVariables commands mode =+    foldr k [] commands+  where+    k :: Commands -> [Options] -> [Options]+    k (Command name _ options) acc = if name == mode then options else acc+    k _ acc = acc+++extractVariableNames :: [Options] -> Set LongName+extractVariableNames options =+    foldr f emptySet options+  where+    f :: Options -> Set LongName -> Set LongName+    f (Variable longname _) valids = insertElement longname valids+    f _ valids = valids++++--+-- The code from here on is formatting code. It's fairly repetative+-- and crafted to achieve a specific aesthetic output. Rather messy.+-- I'm sure it could be done "better" but no matter; this is on the+-- path to an exit and return to user's command line.+--++buildUsage :: Config -> Maybe LongName -> Doc ann+buildUsage config mode = case config of+    Blank -> emptyDoc++    Simple options ->+      let+        (o,a) = partitionParameters options+      in+        "Usage:" <> hardline <> hardline+            <> indent 4 (nest 4 (fillCat+                [ pretty programName+                , optionsSummary o+                , argumentsSummary a+                ])) <> hardline+            <> optionsHeading o+            <> formatParameters o+            <> argumentsHeading a+            <> formatParameters a++    Complex commands ->+      let+        globalOptions = extractGlobalOptions commands+        modes = extractValidModes commands++        (oG,_) = partitionParameters globalOptions+      in+        "Usage:" <> hardline <> hardline <> case mode of+            Nothing ->+                indent 2 (nest 4 (fillCat+                    [ pretty programName+                    , globalSummary oG+                    , commandSummary modes+                    ])) <> hardline+                <> globalHeading oG+                <> formatParameters oG+                <> commandHeading modes+                <> formatCommands commands++            Just longname ->+              let+                (oL,aL) = case lookupKeyValue longname modes of+                    Just localOptions -> partitionParameters localOptions+                    Nothing -> error "Illegal State"+              in+                indent 2 (nest 4 (fillCat+                    [ pretty programName+                    , globalSummary oG+                    , commandSummary modes+                    , localSummary oL+                    , argumentsSummary aL+                    ])) <> hardline+                <> localHeading oL+                <> formatParameters oL+                <> argumentsHeading aL+                <> formatParameters aL++  where+    partitionParameters :: [Options] -> ([Options],[Options])+    partitionParameters options = foldr f ([],[]) options++    optionsSummary :: [Options] -> Doc ann+    optionsSummary os = if length os > 0 then softline <> "[OPTIONS]" else emptyDoc++    optionsHeading os = if length os > 0 then hardline <> "Available options:" <> hardline else emptyDoc++    globalSummary os = if length os > 0 then softline <> "[GLOBAL OPTIONS]" else emptyDoc+    globalHeading os = if length os > 0+        then hardline <> "Global options:" <> hardline+        else emptyDoc++    localSummary os = if length os > 0 then softline <> "[LOCAL OPTIONS]" else emptyDoc+    localHeading os = if length os > 0+        then hardline <> "Options to the '" <> commandName <> "' command:" <> hardline+        else emptyDoc++    commandName :: Doc ann+    commandName = case mode of+        Just (LongName name) -> pretty name+        Nothing -> "COMMAND..."++    argumentsSummary :: [Options] -> Doc ann+    argumentsSummary as = " " <> fillSep (fmap pretty (extractRequiredArguments as))++    argumentsHeading as = if length as > 0 then hardline <> "Required arguments:" <> hardline else emptyDoc++    -- there is a corner case of complex config with no commands+    commandSummary modes = if length modes > 0 then softline <> commandName else emptyDoc+    commandHeading modes = if length modes > 0 then hardline <> "Available commands:" <> hardline else emptyDoc++    f :: Options -> ([Options],[Options]) -> ([Options],[Options])+    f o@(Option _ _ _ _) (opts,args) = (o:opts,args)+    f a@(Argument _ _) (opts,args) = (opts,a:args)+    f (Variable _ _) (opts,args) = (opts,args)++    formatParameters :: [Options] -> Doc ann+    formatParameters [] = emptyDoc+    formatParameters options = hardline <> foldr g emptyDoc options++--+-- 16 characters width for short option, long option, and two spaces. If the+-- long option's name is wider than this the description will be moved to+-- the next line.+--+-- Arguments are aligned to the character of the short option; looks+-- pretty good and better than waiting until column 8.+--++    g :: Options -> Doc ann -> Doc ann+    g (Option longname shortname valued description) acc =+      let+        s = case shortname of+                Just shortchar -> "  -" <> pretty shortchar <> ", --"+                Nothing -> "      --"+        l = pretty longname+        d = fromRope description+      in case valued of+        Empty ->+            fillBreak 16 (s <> l <> " ") <+> align (reflow d) <> hardline <> acc+        Value label ->+            fillBreak 16 (s <> l <> "=" <> pretty label <> " ") <+> align (reflow d) <> hardline <> acc++    g (Argument longname description) acc =+      let+        l = pretty longname+        d = fromRope description+      in+        fillBreak 16 ("  " <> l <> " ") <+> align (reflow d) <> hardline <> acc+    g (Variable longname description) acc =+      let+        l = pretty longname+        d = fromRope description+      in+        fillBreak 16 ("  " <> l <> " ") <+> align (reflow d) <> hardline <> acc++    formatCommands :: [Commands] -> Doc ann+    formatCommands commands = hardline <> foldr h emptyDoc commands++    h :: Commands -> Doc ann -> Doc ann+    h (Command longname description _) acc =+      let+        l = pretty longname+        d = fromRope description+      in+        fillBreak 16 ("  " <> l <> " ") <+> align (reflow d) <> hardline <> acc+    h _ acc = acc++buildVersion :: Version -> Doc ann+buildVersion version =+    pretty (projectNameFrom version)+    <+> "v"+    <> pretty (versionNumberFrom version)+    <> hardline+
+ lib/Core/Program/Context.hs view
@@ -0,0 +1,346 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK hide #-}++-- This is an Internal module, hidden from Haddock+module Core.Program.Context+    (+        Context(..)+      , None(..)+      , isNone+      , configure+      , Message(..)+      , Verbosity(..)+      , Program(..)+      , unProgram+      , getContext+      , subProgram+      , getConsoleWidth+    ) where++import Prelude hiding (log)+import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds)+import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar)+import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO)+import Control.Exception.Safe (displayException)+import qualified Control.Exception.Safe as Safe (throw, catch)+import Control.Monad.Catch (MonadThrow(throwM), MonadCatch(catch))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.Trans.Reader (ReaderT(..))+import Data.Foldable (foldrM)+import Data.Text.Prettyprint.Doc (layoutPretty, LayoutOptions(..), PageWidth(..))+import Data.Text.Prettyprint.Doc.Render.Text (renderIO)+import qualified System.Console.Terminal.Size as Terminal (Window(..), size)+import System.Environment (getArgs, getProgName, lookupEnv)+import System.Exit (ExitCode(..), exitWith)++import Core.Data.Structures+import Core.System.Base hiding (throw, catch)+import Core.Text.Rope+import Core.Program.Arguments+import Core.Program.Metadata++{-|+Internal context for a running program. You access this via actions in the+'Program' monad. The principal item here is the user-supplied top-level+application data of type @τ@ which can be retrieved with+'Core.Program.Execute.getApplicationState' and updated with+'Core.Program.Execute.setApplicationState'.+-}+--+-- The fieldNameFrom idiom is an experiment. Looks very strange,+-- certainly, here in the record type definition and when setting+-- fields, but for the common case of getting a value out of the+-- record, a call like+--+--     fieldNameFrom context+--+-- isn't bad at all, and no worse than the leading underscore+-- convention.+--+--     _fieldName context+--+-- (I would argue better, since _ is already so overloaded as the+-- wildcard symbol in Haskell). Either way, the point is to avoid a+-- bare fieldName because so often you have want to be able to use+-- that field name as a local variable name.+--+data Context τ = Context {+      programNameFrom :: MVar Rope+    , versionFrom :: Version+    , commandLineFrom :: Parameters+    , exitSemaphoreFrom :: MVar ExitCode+    , startTimeFrom :: TimeStamp+    , terminalWidthFrom :: Int+    , verbosityLevelFrom :: MVar Verbosity+    , outputChannelFrom :: TQueue Rope+    , loggerChannelFrom :: TQueue Message+    , applicationDataFrom :: MVar τ+}++{-|+A 'Program' with no user-supplied state to be threaded throughout the+computation.++The "Core.Program.Execute" framework makes your top-level application state+available at the outer level of your process. While this is a feature that+most substantial programs rely on, it is /not/ needed for many simple+tasks or when first starting out what will become a larger project.++This is effectively the unit type, but this alias is here to clearly signal+a user-data type is not a part of the program semantics.++-}+-- Bids are open for a better name for this+data None = None+    deriving (Show, Eq)++isNone :: None -> Bool+isNone _ = True+++data Message = Message TimeStamp Verbosity Rope (Maybe Rope)++data Verbosity = Output | Event | Debug+    deriving Show++{-|+The type of a top-level program.++You would use this by writing:++@+module Main where++import "Core.Program"++main :: 'IO' ()+main = 'Core.Program.Execute.execute' program+@++and defining a program that is the top level of your application:++@+program :: 'Program' 'None' ()+@++Such actions are combinable; you can sequence them (using bind in+do-notation) or run them in parallel, but basically you should need one+such object at the top of your application.++/Type variables/++A 'Program' has a user-supplied application state and a return type.++The first type variable, @τ@, is your application's state. This is an+object that will be threaded through the computation and made available to+your code in the 'Program' monad. While this is a common requirement of the+outer code layer in large programs, it is often /not/ necessary in small+programs or when starting new projects. You can mark that there is no+top-level application state required using 'None' and easily change it+later if your needs evolve.++The return type, @α@, is usually unit as this effectively being called+directly from @main@ and Haskell programs have type @'IO' ()@. That is,+they don't return anything; I/O having already happened as side effects.++/Programs in separate modules/++One of the quirks of Haskell is that it is difficult to refer to code in+the Main module when you've got a number of programs kicking around in a+project each with a @main@ function. So you're best off putting your+top-level 'Program' actions in a separate modules so you can refer to them+from test suites and example snippets.+-}+newtype Program τ α = Program (ReaderT (Context τ) IO α)+    deriving (Functor, Applicative, Monad, MonadIO, MonadReader (Context τ))++unProgram :: Program τ α -> ReaderT (Context τ) IO α+unProgram (Program r) = r++{-|+Get the internal @Context@ of the running @Program@. There is ordinarily no+reason to use this; to access your top-level application data @τ@ within+the @Context@ use 'Core.Program.Execute.getApplicationState'.+-}+getContext :: Program τ (Context τ)+getContext = do+    context <- ask+    return context++{-|+Run a subprogram from within a lifted @IO@ block.+-}+subProgram :: Context τ -> Program τ α -> IO α+subProgram context (Program r) = do+    runReaderT r context++--+-- This is complicated. The **safe-exceptions** library exports a+-- `throwM` which is not the `throwM` class method from MonadThrow.+-- See https://github.com/fpco/safe-exceptions/issues/31 for+-- discussion. In any event, the re-exports flow back to+-- Control.Monad.Catch from **exceptions** and Control.Exceptions in+-- **base**. In the execute actions, we need to catch everything (including+-- asynchronous exceptions); elsewhere we will use and wrap/export+-- **safe-exceptions**'s variants of the functions.+--+instance MonadThrow (Program τ) where+    throwM = liftIO . Safe.throw++unHandler :: (ε -> Program τ α) -> (ε -> ReaderT (Context τ) IO α)+unHandler = fmap unProgram++instance MonadCatch (Program τ) where+    catch :: Exception ε => (Program τ) α -> (ε -> (Program τ) α) -> (Program τ) α+    catch program handler =+      let+        r = unProgram program+        h = unHandler handler+      in do+        context <- ask+        liftIO $ do+            Safe.catch+                (runReaderT r context)+                (\e -> runReaderT (h e) context)++{-|+Initialize the programs's execution context. This takes care of various+administrative actions, including setting up output channels, parsing+command-line arguments (according to the supplied configuration), and+putting in place various semaphores for internal program communication.+See "Core.Program.Arguments" for details.++This is also where you specify the initial {blank, empty, default) value+for the top-level user-defined application state, if you have one. Specify+'None' if you aren't using this feature.+-}+configure :: Version -> τ -> Config -> IO (Context τ)+configure version t config = do+    start <- getCurrentTimeNanoseconds++    arg0 <- getProgName+    n <- newMVar (intoRope arg0)+    p <- handleCommandLine version config+    q <- newEmptyMVar+    columns <- getConsoleWidth+    out <- newTQueueIO+    log <- newTQueueIO+    u <- newMVar t++    l <- handleVerbosityLevel p++    return $! Context {+          programNameFrom = n+        , versionFrom = version+        , commandLineFrom = p+        , exitSemaphoreFrom = q+        , startTimeFrom = start+        , terminalWidthFrom = columns+        , verbosityLevelFrom = l+        , outputChannelFrom = out+        , loggerChannelFrom = log+        , applicationDataFrom = u+    }++--+-- | Probe the width of the terminal, in characters. If it fails to retrieve,+-- for whatever reason, return a default of 80 characters wide.+--+getConsoleWidth :: IO (Int)+getConsoleWidth = do+    window <- Terminal.size+    let columns =  case window of+            Just (Terminal.Window _ w) -> w+            Nothing -> 80+    return columns++--+-- | Process the command line options and arguments. If an invalid+-- option is encountered or a [mandatory] argument is missing, then+-- the program will terminate here.+--+{-+    We came back here with the error case so we can pass config in to+    buildUsage (otherwise we could have done it all in displayException and+    called that in Core.Program.Arguments). And, returning here lets us set+    up the layout width to match (one off the) actual width of console.+-}+handleCommandLine :: Version -> Config -> IO Parameters+handleCommandLine version config = do+    argv <- getArgs+    let result = parseCommandLine config argv+    case result of+        Right parameters -> do+            pairs <- lookupEnvironmentVariables config parameters+            return parameters { environmentValuesFrom = pairs }+        Left e -> case e of+            HelpRequest mode -> do+                render (buildUsage config mode)+                exitWith (ExitFailure 1)+            VersionRequest -> do+                render (buildVersion version)+                exitWith (ExitFailure 1)+            _ -> do+                putStr "error: "+                putStrLn (displayException e)+                hFlush stdout+                exitWith (ExitFailure 1)+  where+    render message = do+        columns <- getConsoleWidth+        let options = LayoutOptions (AvailablePerLine (columns - 1) 1.0)+        renderIO stdout (layoutPretty options message)+        hFlush stdout+++lookupEnvironmentVariables :: Config -> Parameters -> IO (Map LongName ParameterValue)+lookupEnvironmentVariables config params = do+    let mode = commandNameFrom params+    let valids = extractValidEnvironments mode config++    result <- foldrM f emptyMap valids+    return result+  where+    f :: LongName -> (Map LongName ParameterValue) -> IO (Map LongName ParameterValue)+    f name@(LongName var) acc = do+        result <- lookupEnv var+        return $ case result of+            Just value  -> insertKeyValue name (Value value) acc+            Nothing     -> acc+++handleVerbosityLevel :: Parameters -> IO (MVar Verbosity)+handleVerbosityLevel params = do+    let result = queryVerbosityLevel params+    case result of+        Right level -> do+            newMVar level+        Left exit -> do+            putStrLn "error: To set logging level use --verbose or --debug; neither take values."+            hFlush stdout+            exitWith exit++queryVerbosityLevel :: Parameters -> Either ExitCode Verbosity+queryVerbosityLevel params =+  let+    debug = lookupKeyValue "debug" (parameterValuesFrom params)+    verbose = lookupKeyValue "verbose" (parameterValuesFrom params)+  in+    case debug of+        Just value -> case value of+            Empty   -> Right Debug+            Value _ -> Left (ExitFailure 2)+        Nothing -> case verbose of+            Just value -> case value of+                Empty   -> Right Event+                Value _ -> Left (ExitFailure 2)+            Nothing -> Right Output
+ lib/Core/Program/Execute.hs view
@@ -0,0 +1,577 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# 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 -}+      , write+      , writeS+      , writeR+      , output+        {-* 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+    , writeTQueue, isEmptyTQueue)+import qualified Control.Exception as Base (throwIO, evaluate)+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 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.Text.Utilities+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)++    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 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' <- Base.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' <- Base.evaluate text+        atomically (writeTQueue out text')++{-|+Write the supplied @Bytes@ to the given @Handle@. Note that in contrast to+'write' we don't output a trailing newline.++@+    output h b+@++Do not use this to output to @stdout@ as that would bypass the mechanism+used by the @write*@ 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 not UTF-8 text).+-}+output :: Handle -> Bytes -> Program τ ()+output h b = liftIO $ do+        B.hPut h (fromBytes b)++{-|+A thread for concurrent computation. Haskell uses green threads: small+lines of work that are scheduled down onto actual execution contexts, set+by default by this library to be one per core. They are incredibly+lightweight, and you are encouraged to use them freely. Haskell provides a+rich ecosystem of tools to do work concurrently and to communicate safely+between threads++(this wraps __async__'s 'Async')+-}+newtype Thread α = Thread (Async α)++unThread :: Thread α -> Async α+unThread (Thread a) = a++{-|+Fork a thread. The child thread will run in the same @Context@ as the+calling @Program@, including sharing the user-defined application state+type.++(this wraps __async__'s 'async' which in turn wraps __base__'s 'Control.Concurrent.forkIO')+-}+fork :: Program τ α -> Program τ (Thread α)+fork program = do+    context <- ask+    liftIO $ do+        a <- async $ do+            subProgram context program+        link a+        return (Thread a)++{-|+Pause the current thread for the given number of seconds. For+example, to delay a second and a half, do:++@+    'sleep' 1.5+@++(this wraps __base__'s 'threadDelay')+-}+--+-- FIXME is this the right type, given we want to avoid type default warnings?+--+sleep :: Rational -> Program τ ()+sleep seconds =+  let+    us = floor (toRational (seconds * 1e6))+  in+    liftIO $ threadDelay us++{-|+Retrieve the values of parameters parsed from options and arguments+supplied by the user on the command-line.++The command-line parameters are returned in a 'Map', mapping from from the+option or argument name to the supplied value. You can query this map+directly:++@+program = do+    params <- 'getCommandLine'+    let result = 'lookupKeyValue' \"silence\" (paramterValuesFrom params)+    case result of+        'Nothing' -> 'return' ()+        'Just' quiet = case quiet of+            'Value' _ -> 'throw' NotQuiteRight               -- complain that flag doesn't take value+            'Empty'   -> 'write' \"You should be quiet now\"   -- much better+    ...+@++which is pattern matching to answer "was this option specified by the+user?" or "what was the value of this [mandatory] argument?", and then "if+so, did the parameter have a value?"++This is available should you need to differentiate between a @Value@ and an+@Empty@ 'ParameterValue', but for many cases as a convenience you can use+the 'lookupOptionFlag', 'lookupOptionValue', and 'lookupArgument' functions+below (which are just wrappers around a code block like the example shown+here).+-}+getCommandLine :: Program τ (Parameters)+getCommandLine = do+    context <- ask+    return (commandLineFrom context)++{-|+Arguments are mandatory, so by the time your program is running a value+has already been identified. This returns the value for that parameter.+-}+-- this is Maybe because you can inadvertently ask for an unconfigured name+-- this could be fixed with a much stronger Config type, potentially.+lookupArgument :: LongName -> Parameters -> Maybe String+lookupArgument name params =+    case lookupKeyValue name (parameterValuesFrom params) of+        Nothing -> Nothing+        Just argument -> case argument of+            Empty -> error "Invalid State"+            Value value -> Just value++{-|+Look to see if the user supplied a valued option and if so, what its value+was.+-}+-- Should this be more severe if it encounters Empty?+lookupOptionValue :: LongName -> Parameters -> Maybe String+lookupOptionValue name params =+    case lookupKeyValue name (parameterValuesFrom params) of+        Nothing -> Nothing+        Just argument -> case argument of+            Empty -> Nothing+            Value value -> Just value++{-|+Returns @Just True@ if the option is present, and @Nothing@ if it is not.+-}+-- The type is boolean to support a possible future extension of negated+-- arguments.+lookupOptionFlag :: LongName -> Parameters -> Maybe Bool+lookupOptionFlag name params =+    case lookupKeyValue name (parameterValuesFrom params) of+        Nothing -> Nothing+        Just argument -> case argument of+            _ -> Just True        -- nom, nom+++{-|+Illegal internal state resulting from what should be unreachable code+or otherwise a programmer error.+-}+invalid :: Program τ α+invalid = error "Invalid State"
+ lib/Core/Program/Logging.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_HADDOCK prune #-}++module Core.Program.Logging+    (+        putMessage+      , Verbosity(..)+      , event+      , 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 contains '\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++{-|+Note a significant event, state transition, status, or debugging+message. This:++@+    'event' "Starting..."+@++will result in++> 13:05:55Z (0000.001) Starting...++appearing on stdout /and/ the message being sent down the logging+channel. The output string is current time in UTC, and time elapsed+since startup shown to the nearest millisecond (our timestamps are to+nanosecond precision, but you don't need that kind of resolution in+in ordinary debugging).++Messages sent to syslog will be logged at @Info@ level severity.+-}+event :: Rope -> Program τ ()+event text = do+    context <- ask+    liftIO $ do+        level <- readMVar (verbosityLevelFrom context)+        when (isEvent level) $ do+            now <- getCurrentTimeNanoseconds+            putMessage context (Message now Event text Nothing)++isEvent :: Verbosity -> Bool+isEvent level = case level of+    Output -> False+    Event  -> True+    Debug  -> True++isDebug :: Verbosity -> Bool+isDebug level = case level of+    Output -> False+    Event  -> False+    Debug  -> True++{-|+Output a debugging message formed from a label and a value. This is like+'event' above but for the (rather common) case of needing to inspect or+record the value of a variable when debugging code.  This:++@+    'setProgramName' \"hello\"+    name <- 'getProgramName'+    'debug' \"programName\" name+@++will result in++> 13:05:58Z (0003.141) programName = hello++appearing on stdout /and/ the message being sent down the logging channel,+assuming these actions executed about three seconds after program start.++Messages sent to syslog will be logged at @Debug@ level severity.+-}+debug :: Rope -> Rope -> Program τ ()+debug label value = do+    context <- ask+    liftIO $ do+        level <- readMVar (verbosityLevelFrom context)+        when (isDebug level) $ do+            now <- getCurrentTimeNanoseconds+            !value' <- evaluate value+            putMessage context (Message now Debug label (Just value'))++{-|+Convenience for the common case of needing to inspect the value+of a general variable which has a 'Show' instance+-}+debugS :: Show α => Rope -> α -> Program τ ()+debugS label value = debug label (intoRope (show value))++{-|+Convenience for the common case of needing to inspect the value of a+general variable for which there is a 'Render' instance and so can pretty+print the supplied argument to the log. This will pass the detected+terminal width to the 'render' function, resulting in appopriate line+wrapping when rendering your value (if logging to something other than+console the default width of @80@ will be applied).+-}+debugR :: Render α => Rope -> α -> Program τ ()+debugR label thing = do+    context <- ask+    liftIO $ do+        level <- readMVar (verbosityLevelFrom context)+        when (isDebug level) $ do+            now <- getCurrentTimeNanoseconds++            let columns = terminalWidthFrom context++            -- TODO take into account 22 width already consumed by timestamp+            -- TODO move render to putMessage? putMessageR?+            let value = render columns thing+            !value' <- evaluate value+            putMessage context (Message now Debug label (Just value'))+
+ lib/Core/Program/Metadata.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveLift #-}++{-|+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 qualified Data.List as List+import Data.String+import Distribution.Types.GenericPackageDescription (GenericPackageDescription, packageDescription)+import Distribution.Types.PackageDescription (synopsis, package)+import Distribution.Types.PackageId (pkgName, pkgVersion)+import Distribution.Types.PackageName (unPackageName)+import Distribution.PackageDescription.Parsec (readGenericPackageDescription)+import Distribution.Pretty (prettyShow)+import Distribution.Verbosity (normal)+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' ...+@++(this wraps the extensive machinery in the __Cabal__ library, notably+'PackageDescription'. 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+    generic <- readCabalFile+    let desc = packageDescription generic+        version = Version+            { projectNameFrom = unPackageName . pkgName . package $ desc+            , projectSynopsisFrom = synopsis desc+            , versionNumberFrom = prettyShow . pkgVersion . package $ desc+            }++--  I would have preferred+--+--  let e = AppE (VarE ...+--  return e+--+--  but that's not happening. So more voodoo TH nonsense instead.++    [e|version|]+++{-+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 GenericPackageDescription+readCabalFile = runIO $ do+    -- Find .cabal file+    file <- findCabalFile+    +    -- Parse .cabal file+    desc <- readGenericPackageDescription normal file++    -- pass to calling program+    return desc++
+ lib/Core/Program/Signal.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++module Core.Program.Signal+(+    setupSignalHandlers+)+where++import Control.Concurrent.MVar (MVar, putMVar, modifyMVar_)+import Foreign.C.Types (CInt)+import System.Exit (ExitCode(..))+import System.IO (hPutStrLn, hFlush, stdout)+import System.Posix.Signals (Handler(Catch), installHandler,+    sigINT, sigTERM, sigUSR1)++import Core.Program.Context++--+-- | Make a non-zero exit code which is 0b1000000 + the number of the+-- signal. Probably never need this (especaially given our attempt to+-- write out a human readable name for the signal caught) but it's a+-- convention we're happy to observe.+--+code :: CInt -> ExitCode+code signal = ExitFailure (128 + fromIntegral signal)++{-+    Technique to have a blocking MVar and signal handlers to set it+    adapted from code in vaultaire-common package's Vaultaire.Program,+    BSD3 licenced.+-}++interruptHandler :: MVar ExitCode -> Handler+interruptHandler quit = Catch $ do+    hPutStrLn stdout "\nInterrupt"+    hFlush stdout+    putMVar quit (code sigINT)++terminateHandler :: MVar ExitCode -> Handler+terminateHandler quit = Catch $ do+    hPutStrLn stdout "Terminating"+    hFlush stdout+    putMVar quit (code sigTERM)++logLevelHandler :: MVar Verbosity -> Handler+logLevelHandler v = Catch $ do+    hPutStrLn stdout "Signal"+    hFlush stdout+    modifyMVar_ v (\level -> case level of+            Output -> pure Debug+            Event  -> pure Debug+            Debug  -> pure Output)++--+-- | Install signal handlers for SIGINT and SIGTERM that set the exit+-- semaphore so that a Program's [minimal] cleanup can occur.+--+setupSignalHandlers :: MVar ExitCode -> MVar Verbosity -> IO ()+setupSignalHandlers quit level = do+    installHandler sigINT (interruptHandler quit) Nothing+    installHandler sigTERM (terminateHandler quit) Nothing+    installHandler sigUSR1 (logLevelHandler level) Nothing+    return ()
+ lib/Core/Program/Unlift.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_HADDOCK prune #-}++{-|+The 'Program' monad is an instance of 'MonadIO', which makes sense; it's+just a wrapper around doing 'IO' and you call it using+'execute' from the top-level @main@ action that is the+entrypoint to any program.  So when you need to actually do some I/O or+interact with other major libraries in the Haskell ecosystem, you need to+get back to 'IO' and you use 'liftIO' to do it:++@+main :: 'IO' ()+main = 'execute' $ do+    -- now in the Program monad+    'write' "Hello there"++    'liftIO' $ do+        -- now something in IO+        source <- readFile "hello.c"+        compileSourceCode source++    -- back in Program monad+    'write' \"Finished\"+@++and this is a perfectly reasonable pattern.++Sometimes, however, you want to get to the 'Program' monad from /there/,+and that's tricky; you can't just 'execute' a new+program (and don't try: we've already initialized output and logging+channels, signal handlers, your application context, etc).++@+main :: 'IO' ()+main = 'execute' $ do+    -- now in the Program monad+    'write' "Hello there"++    'liftIO' $ do+        -- now something in IO+        source <- readFile "hello.c"+        -- log that we're starting compile      ... FIXME how???+        result <- compileSourceCode source+        case result of+            Right object -> linkObjectCode object+            Left err     -> -- debug the error  ... FIXME how???++    -- back in Program monad+    'write' \"Finished\"+@++We have a problem, because we'd like to do is use, say, 'debug' to log the+compiler error, but we have no way to unlift back out of 'IO' to get to the+'Program' monad.++To workaround this, we offer 'withContext'. It gives you a function that+you can then use within your lifted 'IO' to run a (sub)'Program' action:++@+main :: 'IO' ()+main = 'execute' $ do+    -- now in the Program monad+    'write' "Hello there"++    'withContext' $ \\runProgram -> do+        -- now lifted to IO+        source <- readFile "hello.c"++        runProgram $ do+            -- now \"unlifted\" back to Program monad!+            'event' \"Starting compile...\"+            'event' \"Nah. Changed our minds\"+            'event' \"Ok, fine, compile the thing\"++        -- more IO+        result <- compileSourceCode source+        case result of+            'Right' object -> linkObjectCode object+            'Left' err     -> runProgram ('debugS' err)++    -- back in Program monad+    'write' \"Finished\"+@++Sometimes Haskell type inference can give you trouble because it tends to+assume you mean what you say with the last statement of do-notation block.+If you've got the type wrong you'll get an error, but in an odd place,+probably at the top where you have the lambda. This can be confusing. If+you're having trouble with the types try putting @return ()@ at the end of+your subprogram.+-}+module Core.Program.Unlift+    (+        {-* Unlifting -}+        withContext+        {-* Internals -}+      , getContext+      , subProgram+    ) where++import Core.Program.Context+import Core.Program.Execute+import Core.Program.Logging+import Core.System.Base++{-|+This gives you a function that you can use within your lifted 'IO' actions+to return to the 'Program' monad.++The type signature of this function is a bit involved, but the example below+shows that the lambda gives you a /function/ as its argument (we recommend+you name it @__runProgram__@ for consistency) which gives you a way to run a+subprogram, be that a single action like writing to terminal or logging, or+a larger action in a do-notation block:++@+main :: IO ()+main = 'execute' $ do+    'withContext' $ \\runProgram -> do+        -- in IO monad, lifted+        -- (just as if you had used liftIO)++        ...++        runProgram $ do+            -- now unlifted, back to Program monad++        ...+@++Think of this as 'liftIO' with an escape hatch.++This function is named 'withContext' because it is a convenience around the+following pattern:++@+    context <- 'getContext'+    liftIO $ do+        ...+        'subProgram' context $ do+            -- now in Program monad+        ...+@+-}+-- I think I just discovered the same pattern as **unliftio**? Certainly+-- the signature is similar. I'm not sure if there is any benefit to+-- restating this as a `withRunInIO` action; we're deliberately trying to+-- constrain the types.+withContext+    :: ((forall β. Program τ β -> IO β) -> IO α)+    -> Program τ α+withContext action = do+    context <- getContext+    let runThing = subProgram context+    liftIO (action runThing)+
+ lib/Core/System.hs view
@@ -0,0 +1,40 @@+{-# OPTIONS_HADDOCK not-home #-}++{-|+Common elements from the rest of the Haskell ecosystem. This is mostly+about re-exports. There are numerous types and functions that are more or+less assumed to be in scope when you're doing much of anything in Haskell;+this module is a convenience to pull in the ones we rely on for the rest of+this library.++You can just import this directly:++@+import "Core.System"+@++as there's no particular benefit to cherry-picking the various sub-modules.++-}+module Core.System+    (+        {-* Base libraries -}+{-|+Re-exports from foundational libraries supplied by the compiler runtime,+or from re-implementations of those areas.+-}+        module Core.System.Base++        {-* External dependencies -}+{-|+Dependencies from libraries outside the traditional ecosystem of Haskell.+These are typically special cases or custom re-implementations of things+which are maintained either by ourselves or people we are in regular+contact with.+-}+      , module Core.System.External+    ) where++import Core.System.Base+import Core.System.External+
+ lib/Core/System/Base.hs view
@@ -0,0 +1,33 @@+{-# 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+    , stdin, stdout, stderr+    , hFlush+    , unsafePerformIO+      {-* Exception handling -}+      {-** from Control.Exception.Safe -}+      {-| Re-exported from "Control.Exception.Safe" in the __safe-exceptions__ package: -}+    , Exception(..)+    , throw+    , bracket+    , catch+    ) where++import Control.Exception.Safe (Exception(..), throw, bracket, catch)+import Control.Monad.IO.Class (MonadIO, liftIO)+import System.IO (Handle, stdin, stdout, stderr, hFlush)+import System.IO.Unsafe (unsafePerformIO)+
+ lib/Core/System/External.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_HADDOCK not-home #-}++--+-- | Re-exports of dependencies from various external libraries.+--+module Core.System.External+    ( {-* Time -}+      {-** from Chrono.TimeStamp -}+      {-| Re-exported from "Chrono.TimeStamp" in __chronologique__: -}+      TimeStamp(..)+    , getCurrentTimeNanoseconds+    ) where++import Chrono.TimeStamp (TimeStamp(..), getCurrentTimeNanoseconds)+
+ lib/Core/Text.hs view
@@ -0,0 +1,36 @@+{-# OPTIONS_HADDOCK not-home #-}++{-|+A unified Text type providing interoperability between various text+back-ends present in the Haskell ecosystem.++This is intended to be used directly:++@+import "Core.Text"+@++as this module re-exports all of the various components making up this+library's text handling subsystem.+-}+module Core.Text+    (+        {-* Internal representation -}+{-|+Exposes 'Bytes', a wrapper around different types of binary data, and 'Rope',+a finger-tree over buffers containing text.+-}+        module Core.Text.Bytes+      , module Core.Text.Rope++        {-* Useful utilities -}+{-|+Useful functions for common use cases.+-}+      , module Core.Text.Utilities+    ) where++import Core.Text.Bytes+import Core.Text.Rope+import Core.Text.Utilities+
+ lib/Core/Text/Bytes.hs view
@@ -0,0 +1,175 @@+{-# 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+    , chunk+    ) where++import Data.Bits (Bits (..))+import Data.Char (intToDigit)+import qualified Data.ByteString as B (ByteString, foldl', splitAt+    , pack, unpack, length, hPut)+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.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++{-| 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++{-|+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:++@+    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'++-- (), aka Unit, aka **1**, aka something with only one inhabitant++instance Render Bytes where+    type Token Bytes = ()+    colourize = const (color Green)+    intoDocA = prettyBytes+    +prettyBytes :: Bytes -> Doc ()+prettyBytes (StrictBytes b') = annotate () . vcat . twoWords+    . fmap wordToHex . chunk $ b'++twoWords :: [Doc ann] -> [Doc ann]+twoWords ds = go ds+  where+    go [] = []+    go [x] = [softline' <> x]+    go xs =+      let+        (one:two:[], remainder) = List.splitAt 2 xs+      in+        group (one <> spacer <> two) : go remainder++    spacer = flatAlt softline' "  "+++chunk :: B.ByteString -> [B.ByteString]+chunk = reverse . go []+  where+    go acc blob =+      let+        (eight, remainder) = B.splitAt 8 blob+      in+        if B.length remainder == 0+            then eight : acc+            else go (eight : acc) remainder++-- Take an [up to] 8 byte (64 bit) word+wordToHex :: B.ByteString -> Doc ann+wordToHex eight =+  let+    ws = B.unpack eight+    ds = fmap byteToHex ws+  in+    hsep ds++byteToHex :: Word8 -> Doc ann+byteToHex c = pretty hi <> pretty low+  where+    !low      = byteToDigit $ c .&. 0xf+    !hi       = byteToDigit $ (c .&. 0xf0) `shiftR` 4++    byteToDigit :: Word8 -> Char+    byteToDigit = intToDigit . fromIntegral++{-+instance Show Bytes where+    show x = case x of+        StrictBytes b' -> +-}
+ lib/Core/Text/Rope.hs view
@@ -0,0 +1,460 @@+{-# 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+    , width+    , split+    , insert+    , contains+      {-* Interoperation and Output -}+    , Textual(fromRope, intoRope, append)+    , unsafeIntoRope+    , hWrite+      {-* Internals -}+    , unRope+    , 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 Data.String (IsString(..))+import qualified Data.FingerTree as F (FingerTree, Measured(..), empty+    , singleton, (><), (<|), (|>), search, SearchResult(..))+import Data.Foldable (foldr, foldr', foldMap, toList, any)+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+    , fromText, toText, fromByteString, pack, unpack+    , append, empty, toBuilder, splitAt)+import qualified Data.Text.Short.Unsafe as S (fromByteStringUnsafe)+import Data.Hashable (Hashable, hashWithSalt)+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+'append' method as below or ('Data.Semigroup.<>') 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 = Rope . F.singleton . S.pack++instance Semigroup Rope where+    (<>) (Rope x1) (Rope x2) = Rope ((F.><) x1 x2) -- god I hate these operators++instance Monoid Rope where+    mempty = Rope F.empty+    mappend = (<>)++{-|+Get the length of this text, in characters.+-}+width :: Rope -> Int+width = foldr' f 0 . unRope+  where+    f piece count = S.length piece + count++{-|+Break the text into two pieces at the specified offset.++Examples:++@+λ> __split 0 \"abcdef\"__+(\"\", \"abcdef\")+λ> __split 3 \"abcdef\"__+(\"abc\", \"def\")+λ> __split 6 \"abcdef\"__+(\"abcdef\",\"\")+@++Going off either end behaves sensibly:++@+λ> __split 7 \"abcdef\"__+(\"abcdef\",\"\")+λ> __split (-1) \"abcdef\"__+(\"\", \"abcdef\")+@+-}+split :: Int -> Rope -> (Rope,Rope)+split 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:++@+λ> __insert 3 \"Con\" \"Def 1\"__+"DefCon 1"+λ> __insert 0 \"United \" \"Nations\"__+"United Nations"+@+-}+insert :: Int -> Rope -> Rope -> Rope+insert 0 (Rope new) (Rope x) = Rope ((F.><) new x)+insert i (Rope new) text =+  let+    (Rope before,Rope after) = split 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 intermiate 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).+    -}+    append :: α -> Rope -> Rope+    append 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+    append (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+    append 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))+    append 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+    append 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 'contains' '\n' text+        then handleComplexCase+        else keepItSimple+@+-}+contains :: Char -> Rope -> Bool+contains q (Rope x) = any j x+  where+    j piece = S.any (\c -> c == q) piece
+ lib/Core/Text/Utilities.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-|+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+    , wrap+    , underline+      {-* Multi-line strings -}+    , quote+) 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.Lazy.Builder 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++-- 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 cs = pretty cs++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. It also appends a trailing+newline to finish the paragraph.+-}+wrap :: Int -> Rope -> Rope+wrap margin text =+  let+    built = wrapHelper margin (T.words (fromRope text))+  in+    intoRope (T.toLazyText built)++wrapHelper :: Int -> [T.Text] -> T.Builder+wrapHelper _ [] = ""+wrapHelper _ [x]  = T.fromText x+wrapHelper margin (x:xs) =+    snd $ List.foldl' (wrapLine margin) (T.length x, T.fromText x) xs++wrapLine :: Int -> (Int, T.Builder) -> T.Text -> (Int, T.Builder)+wrapLine margin (pos,builder) word =+  let+    wide = T.length word+    wide' = pos + wide + 1+  in+    if wide' > margin+        then (wide , builder <> "\n" <> T.fromText word)+        else (wide', builder <> " "  <> T.fromText word)+++underline :: Char -> Rope -> Rope+underline level text =+  let+    title = fromRope text+    line = T.map (\_ -> level) title+  in+    intoRope line++{-|+Multi-line string literals.++To use these you need to enable the @QuasiQuotes@ language extension+in your source file:++@+\{\-\# LANGUAGE OverloadedStrings \#\-\}+\{\-\# LANGUAGE QuasiQuotes \#\-\}+@++you are then able to easily write a string stretching over several lines.++How best to formatting multi-line string literal within your source code is+an aesthetic judgement. Sometimes you don't care about the whitespace+leading a passage (8 spaces in this example):++@+    let message = ['quote'|+        This is a test of the Emergency Broadcast System. Do not be+        alarmed. If this were a real emergency, someone would have tweeted+        about it by now.+    |]+@++because you are feeding it into a 'Data.Text.Prettyprint.Doc.Doc' for+pretty printing and know the renderer will convert the whole text into a+single line and then re-flow it. Other times you will want to have the+string as is, literally:++@+    let poem = ['quote'|+If the sun+    rises+        in the+    west+you     drank+    too much+                last week.+    |]+@++Leading whitespace from the first line and trailing whitespace from the+last line will be trimmed, so this:++@+    let value = ['quote'|+Hello+    |]+@++is translated to:++@+    let value = 'Data.String.fromString' \"Hello\\n\"+@++without the leading newline or trailing four spaces. Note that as string+literals they are presented to your code with 'Data.String.fromString' @::+String -> α@ so any type with an 'Data.String.IsString' instance (as 'Rope'+has) can be constructed from a multi-line @['quote'| ... |]@ literal.++-}+-- I thought this was going to be more complicated.+quote :: QuasiQuoter+quote = QuasiQuoter+    (litE . stringL . trim)        -- in an expression+    (error "Cannot use [quote| ... |] in a pattern")+    (error "Cannot use [quote| ... |] as a type")+    (error "Cannot use [quote| ... |] for a declaration")+  where+    trim :: String -> String+    trim = bot . top++    top [] = []+    top ('\n':cs) = cs+    top str = str++    bot = List.dropWhileEnd (== ' ')+
+ tests/CheckArgumentsParsing.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module CheckArgumentsParsing where++import Test.Hspec++import Core.Program.Arguments++options1 =+    [ Option "verbose" (Just 'v') Empty "Make the program verbose"+    , Option "quiet" (Just 'q') Empty "Be very very quiet, we're hunting wabbits"+    , Option "dry-run" Nothing (Value "WHEN") "Before trapping Road Runner, best to do a dry-run"+    ]++options2 =+    [ Option "recursive" Nothing Empty "Descend into darkness"+    , Argument "filename" "The file that you want"+    ]++options3 =+    [ Option "all" (Just 'a') Empty "Good will to everyone"+    ]+++commands1 =+    [ Global+        options1+    , Command "add" "Add a new file"+        options2+    ]++commands2 =+    [ Global+        options1+    , Command "add" "Add a new file"+        options2+    , Command "commit" "Commit for eternity"+        options3+    ]+++checkArgumentsParsing :: Spec+checkArgumentsParsing = do+    describe "Parsing of simple command-lines" $ do+        it "recognizes a single specified options" $+          let+            config = simple options1+            actual = parseCommandLine config ["--verbose"]+            expect = Parameters Nothing [("verbose", Empty)] []+          in+            actual `shouldBe` Right expect+        it "recognizes all specified options" $+          let+            config = simple options1+            actual = parseCommandLine config ["--verbose", "--quiet", "--dry-run=Tomorrow"]+            expect = Parameters Nothing+              [ ("verbose", Empty)+              , ("quiet", Empty)+              , ("dry-run", Value "Tomorrow")+              ] []+          in+            actual `shouldBe` Right expect++        it "recognizes required arguments" $+          let+            config = simple options2+            actual = parseCommandLine config ["hello.txt"]+            expect = Parameters Nothing+              [ ("filename", Value "hello.txt")+              ] []+          in+            actual `shouldBe` Right expect++        it "handles valued parameter" $+          let+            config = simple options2+            actual = parseCommandLine config ["hello.txt"]+            expect = Parameters Nothing+              [ ("filename", Value "hello.txt")+              ] []+          in+            actual `shouldBe` Right expect++        it "rejects unknown options" $+          let+            config = simple options2+            actual = parseCommandLine config ["-a"]+          in+            actual `shouldBe` Left (UnknownOption "-a")++        it "rejects a malformed option" $+          let+            config = simple options2+            actual = parseCommandLine config ["-help"]+          in+            actual `shouldBe` Left (InvalidOption "-help")++        it "fails on missing argument" $+          let+            config = simple options2+            actual = parseCommandLine config []+          in+            actual `shouldBe` Left (MissingArgument "filename")++    describe "Parsing of complex command-lines" $ do++        it "recognizes only single command" $+          let+            config = complex commands1+            actual = parseCommandLine config ["-q", "add", "--recursive", "Hello.hs"]+            expect = Parameters (Just "add")+                [ ("quiet", Empty)+                , ("recursive", Empty)+                , ("filename", Value "Hello.hs")+                ] []+          in+            actual `shouldBe` Right expect++        it "fails on missing command" $+          let+            config = complex commands1+            actual = parseCommandLine config []+          in+            actual `shouldBe` Left (NoCommandFound)++        it "rejects an unknown command" $+          let+            config = complex commands1+            actual = parseCommandLine config ["launch"]+          in+            actual `shouldBe` Left (UnknownCommand "launch")++        it "recognizes different command" $ -- ie, now from among multiple choices+          let+            config = complex commands2+            actual = parseCommandLine config ["commit"]+            expect = Parameters (Just "commit") [] []+          in+            actual `shouldBe` Right expect+++        it "rejects further trailing arguments" $+          let+            config = complex commands2+            actual = parseCommandLine config ["commit", "some"]+          in+            actual `shouldBe` Left (UnexpectedArguments ["some"])+
+ tests/CheckBytesBehaviour.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module CheckBytesBehaviour where++import qualified Data.ByteString.Char8 as C+import Test.Hspec++import Core.Text.Bytes++checkBytesBehaviour :: Spec+checkBytesBehaviour = do+    describe "Bytes data type" $ do+        it "chunks Bytes in 64 bit words" $+          let+            expected =+                [ C.pack "Hello Wo"+                , C.pack "rld! Goo"+                , C.pack "d Bye."+                ]+          in do+            chunk (C.pack "Hello World! Good Bye.") `shouldBe` expected
+ tests/CheckContainerBehaviour.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module CheckContainerBehaviour where++import Test.Hspec++import Core.Data.Structures+import Core.Text.Rope++climbing :: [Int]+climbing = [1,1,2,1,2,4,1,3,9]++fibonacci :: [Int]+fibonacci = [1,1,2,3,5,8,13,21]++introduction :: [(Int,Rope)]+introduction = [(2," "),(3,"world"),(1,"hello")]++checkContainerBehaviour :: Spec+checkContainerBehaviour = do+    describe "Set data type" $ do+        it "calculates length accurately" $ do+            length fibonacci `shouldBe` 8+            let s = intoSet fibonacci+            length s `shouldBe` 7++        it "converts to list in Ord order" $ do+            let s = intoSet climbing+            length s `shouldBe` 5+            fromSet s `shouldBe` [1,2,3,4,9]++    describe "Map data type" $ do+        it "calculates length accurately" $ do+            length introduction `shouldBe` 3+            let p = intoMap introduction+            length p `shouldBe` 3++        it "values can be looked up" $ do+            let p = intoMap introduction+            containsKey 3 p `shouldBe` True+            lookupKeyValue 3 p `shouldBe` (Just "world")+            containsKey 4 p `shouldBe` False+            lookupKeyValue 4 p `shouldBe` Nothing++        it "values can be inserted into Map" $ do+            let p = intoMap introduction+            let p' = insertKeyValue 4 "!" p+            containsKey 4 p' `shouldBe` True+            lookupKeyValue 4 p' `shouldBe` (Just "!")++        it "converts to list in Ord order" $ do+            let p = intoMap introduction+            fromMap p `shouldBe` [(1,"hello"),(2," "),(3,"world")]++        it "updated values supercede existing values" $ do+            let p = intoMap introduction+            let p' = insertKeyValue 2 "&" p+            containsKey 2 p' `shouldBe` True+            lookupKeyValue 2 p' `shouldBe` (Just "&")+
+ tests/CheckJsonWrapper.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module CheckJsonWrapper where++import qualified Data.ByteString.Char8 as C+import Test.Hspec++import Core.Data+import Core.Text+import Core.Encoding.Json++k = JsonKey "intro"+v = JsonString "Hello"++j = JsonObject (intoMap [(k, v)])++j2 = JsonObject (intoMap+        [ (JsonKey "song", JsonString "Thriller")+        , (JsonKey "other", JsonString "A very long name for the \"shadow of the moon\".")+        , (JsonKey "four", JsonObject (intoMap+                [ (JsonKey "n1", r)+                ]))+        ])++b = intoBytes (C.pack "{\"cost\": 4500}")++r = JsonArray [JsonBool False, JsonNull, JsonNumber 42]+++checkJsonWrapper :: Spec+checkJsonWrapper = do+    describe "JsonValue encoding" $+      do+        it "JSON String should be wrapped in quotes" $ do+            encodeToUTF8 v `shouldBe` intoBytes (C.pack "\"Hello\"")++        it "JSON Array renders correctly" $ do+            encodeToUTF8 r `shouldBe` intoBytes (C.pack "[false,null,42]")++        it "JSON Object renders correctly" $ do+            encodeToUTF8 j `shouldBe` intoBytes (C.pack "{\"intro\":\"Hello\"}")++        it "decoding an Object parses" $ do+            decodeFromUTF8 b `shouldBe` Just (JsonObject (intoMap [(JsonKey "cost", JsonNumber 4500)]))++        it "complex JSON Object round trips" $ do+            decodeFromUTF8 (encodeToUTF8 j2) `shouldBe` Just j2
+ tests/CheckProgramMonad.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE ScopedTypeVariables #-}++module CheckProgramMonad where++import qualified Control.Exception.Safe as Safe+import Test.Hspec hiding (context)++import Core.Data.Structures+import Core.Program.Arguments+import Core.Program.Execute+import Core.Program.Unlift+import Core.System.Base++options :: [Options]+options =+    [ Option "all" (Just 'a') Empty "Good will to everyone"+    ]++commands :: [Commands]+commands =+    [ Global+        options+    , Command "go-forth" "And multiply"+        []+    ]++data Boom = Boom+    deriving Show++instance Exception Boom++boom :: Selector Boom+boom = const True++checkProgramMonad :: Spec+checkProgramMonad = do+    describe "Context type" $ do+        it "Eq instance for None behaves" $ do+            None `shouldBe` None++    describe "Program monad" $ do+        it "execute with blank Context as expected" $ do+            context <- configure "0.1" None blank+            executeWith context $ do+                user <- getApplicationState+                liftIO $ do+                    user `shouldBe` None++        it "execute with simple Context as expected" $ do+            context <- configure "0.1" None (simple options)+            executeWith context $ do+                params <- getCommandLine+                liftIO $ do+                    -- this assumes that hspec isn't passing any+                    -- command-line arguments through to us.+                    params `shouldBe` (Parameters Nothing emptyMap emptyMap)++        -- not strictly necessary but sets up next spec item+        it "sub-programs can be run" $ do+            context <- configure "0.1" None blank+            user <- subProgram context (getApplicationState)+            user `shouldBe` None++        it "unlifting from lifted IO works" $ do+            execute $ do+                user1 <- getApplicationState+                withContext $ \runProgram -> do+                    user1 `shouldBe` None+                    user2 <- runProgram getApplicationState -- unlift!+                    user2 `shouldBe` user1++        it "thrown Exceptions can be caught" $ do+            context <- configure "0.1" None blank+            (subProgram context (throw Boom)) `shouldThrow` boom++            -- ok, so with that established, now try **safe-exceptions**'s+            -- code. Note if we move the exception handling code from+            -- `execute` to `subProgram` this will have to adapt.+            Safe.catch+                (subProgram context (throw Boom))+                (\(_ :: Boom) -> return ())++        it "MonadThrow and MonadCatch behave" $ do+            context <- configure "0.1" None blank+            subProgram context $ do+                Safe.catch (Safe.throw Boom) (\(_ :: Boom) -> return ())
+ tests/CheckRopeBehaviour.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module CheckRopeBehaviour where++import qualified Data.FingerTree as F+import qualified Data.List as List+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as U+import qualified Data.Text.Short as S+import Test.Hspec++import Core.Text.Rope+import Core.Text.Utilities++hydrogen = "H₂" :: Rope+sulfate = "SO₄" :: Rope++sulfuric_acid = hydrogen <> sulfate++compound = "3" <> "-" <> "ethyl" <> "-" <> "4" <> "-" <> "methyl" <> "hexane" :: Rope++checkRopeBehaviour :: Spec+checkRopeBehaviour = do+    describe "Rope data type" $+      do+        it "IsString instance behaves" $ do+            unRope ("Hello" :: Rope) `shouldBe` F.singleton (S.pack "Hello")++        it "calculates length accurately" $ do+            width hydrogen `shouldBe` 2+            width sulfate `shouldBe` 3+            width (hydrogen <> sulfate) `shouldBe` 5++        it "Eq instance behaves" $ do+             ("" :: Rope) == ("" :: Rope) `shouldBe` True+             ("C" :: Rope) /= ("" :: Rope) `shouldBe` True+             ("" :: Rope) /= ("F" :: Rope) `shouldBe` True+             ("O" :: Rope) == ("O" :: Rope) `shouldBe` True+             ("H₂" :: Rope) == ("H₂" :: Rope) `shouldBe` True+             ("H₂" :: Rope) /= ("SO₄" :: Rope)  `shouldBe` True++        -- depended on Textual instance for String being fixed and+        -- the Eq instance being customized to ignore tree structure+        it "concatonates two Ropes correctly (Monoid)" $ do+             ("H₂" :: Rope) <> ("SO₄" :: Rope)  `shouldBe` ("H₂SO₄" :: Rope)++        it "concatonates two Ropes correctly (Textual)" $ do+             append ("SO₄" :: Rope) ("H₂" :: Rope) `shouldBe` ("H₂SO₄" :: Rope)++        it "exports to ByteString" $+          let+            expected = T.encodeUtf8 (T.pack "H₂SO₄")+          in do+            fromRope sulfuric_acid `shouldBe` expected++        it "exports to Text (Strict)" $ do+            fromRope sulfuric_acid `shouldBe` T.pack "H₂SO₄"++        it "exports to Text (Lazy)" $ do+            fromRope sulfuric_acid `shouldBe` U.pack "H₂SO₄"++        it "does the splits" $ do+            -- compare behaviour on Haskell lists+            List.splitAt 0 ("123456789" :: String) `shouldBe` ("", "123456789")+            List.splitAt 3 ("123456789" :: String) `shouldBe` ("123", "456789")++            -- expect same behaviour of Rope+            split 0 ("123456789" :: Rope) `shouldBe` ("", "123456789")+            split 3 ("123456789" :: Rope) `shouldBe` ("123", "456789")+            split 9 ("123456789" :: Rope) `shouldBe` ("123456789","")+            split 10 ("123456789" :: Rope) `shouldBe` ("123456789","")+            split (-1) ("123456789" :: Rope) `shouldBe` ("", "123456789")++            -- exercise splitting at and between piece boundaries+            split 0 compound `shouldBe` ("", "3-ethyl-4-methylhexane")+            split 1 compound `shouldBe` ("3", "-ethyl-4-methylhexane")+            split 2 compound `shouldBe` ("3-", "ethyl-4-methylhexane")+            split 4 compound `shouldBe` ("3-et", "hyl-4-methylhexane")+            --                             1234567890+            split 10 compound `shouldBe` ("3-ethyl-4-", "methylhexane")+            split 11 compound `shouldBe` ("3-ethyl-4-m", "ethylhexane")+            split 16 compound `shouldBe` ("3-ethyl-4-methyl", "hexane")+            split 21 compound `shouldBe` ("3-ethyl-4-methylhexan", "e")+            width compound `shouldBe` 22+            split 22 compound `shouldBe` ("3-ethyl-4-methylhexane", "")+            split 23 compound `shouldBe` ("3-ethyl-4-methylhexane", "")+            split (-1) compound `shouldBe` ("", "3-ethyl-4-methylhexane")++        it "does insertion correctly" $ do+            insert 3 "two" "onethree" `shouldBe` "onetwothree"+            insert 3 "Con" "Def 1" `shouldBe` "DefCon 1"+            insert 0 "one" "twothree" `shouldBe` "onetwothree"+            insert 6 "three" "onetwo" `shouldBe` "onetwothree"++    describe "QuasiQuoted string literals" $+      do+        it "string literal is IsString" $ do+            [quote|Hello|] `shouldBe` ("Hello" :: String)+            [quote|Hello|] `shouldBe` ("Hello" :: Rope)++        it "trims multi-line string literal" $ do+            [quote|+Hello+            |] `shouldBe` ("Hello\n" :: Rope)+            [quote|+Hello+World+            |] `shouldBe` ("Hello\nWorld\n" :: Rope)+
+ tests/SimpleExperiment.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++--import Data.Text (Text)+import Control.Concurrent (threadDelay)+import Control.Monad (replicateM_)+import qualified Data.ByteString.Char8 as S+import qualified Data.HashMap.Strict as HashMap+import Data.Text.Prettyprint.Doc (layoutPretty, defaultLayoutOptions, Pretty(..))+import Data.Text.Prettyprint.Doc.Render.Text (renderStrict)++import Core.Data+import Core.Text+import Core.Encoding+import Core.Program+import Core.System++k = JsonKey "intro"+v = JsonString "Hello"++j = JsonObject+        [ (k, v)+        , (JsonKey "song", JsonString "Thriller")+        , ("other", "A very long name for the \"shadow of the moon\".")+        , (JsonKey "four", JsonObject+                [ (JsonKey "n1", r)+                ])+        ]++b = intoBytes (S.pack "{\"cost\": 4500}")++r = JsonArray [JsonBool False, JsonNull, 42]++data Boom = Boom+    deriving Show++instance Exception Boom++program :: Program None ()+program = do+    event "Starting..."++    params <- getCommandLine+    debugS "params" params++    level <- getVerbosityLevel+    debugS "level" level++    name <- getProgramName+    debug "programName" name++    setProgramName "hello"++    name <- getProgramName+    debug "programName" name++    debugR "key" k+    event "Verify internal values"++    state <- getApplicationState+    debugS "state" state++    let x = encodeToUTF8 j+    writeS x++    let (Just y) = decodeFromUTF8 b+    writeS y+    writeS (encodeToUTF8 y)+    writeR (encodeToUTF8 y)+    writeS (encodeToUTF8 r)++    debugR "packet" j++    event "Clock..."++    fork $ do+        sleep 1.5+        event "Wakey wakey"+        throw Boom++    replicateM_ 5 $ do+        sleep 0.5+        event "tick"+++    event "Brr! It's cold"+    terminate 0++version :: Version+version = $(fromPackage)++main :: IO ()+main = do+    context <- configure version None (simple+        [ Option "quiet" (Just 'q') Empty [quote|+            Supress normal output.+          |]+        , Argument "filename" [quote|+            The file you want to frobnicate.+          |]+        , Variable "HOME" "Home directory"+        ])++    executeWith context program
+ tests/Snippet.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}++import qualified Data.ByteString.Char8 as C++import Core.Program+import Core.Text+import Core.System++b = intoBytes (C.pack "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789")++data Boom = Boom deriving Show+instance Exception Boom++main :: IO ()+main = execute $ do+    event "Processing..."+    debugR "b" b++    let x = error "No!"++    write $ case x of+        Nothing -> "Nothing!"++    sleep 0.2++    write "Done"
+ tests/TestSuite.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}++import Test.Hspec++import CheckRopeBehaviour+import CheckBytesBehaviour+import CheckContainerBehaviour+import CheckJsonWrapper+import CheckArgumentsParsing+import CheckProgramMonad++main :: IO ()+main = do+    hspec suite+    putStrLn "."++suite :: Spec+suite = do+    checkRopeBehaviour+    checkBytesBehaviour+    checkContainerBehaviour+    checkJsonWrapper+    checkArgumentsParsing+    checkProgramMonad
+ unbeliever.cabal view
@@ -0,0 +1,248 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 1a286309370d68d11f651b386263a174b2744b09bf4f1919f38209b05542a639++name:           unbeliever+version:        0.7.3.0+synopsis:       Opinionated Haskell Interoperability+description:    A library to help build command-line programs, both tools and+                longer-running daemons.+                .+                Useful starting points are "Core.Program.Execute" and "Core.Text.Rope".+category:       System+stability:      experimental+author:         Andrew Cowie <andrew@operationaldynamics.com>+maintainer:     Andrew Cowie <andrew@operationaldynamics.com>+copyright:      © 2018 Operational Dynamics Consulting Pty Ltd, and Others+license:        BSD3+license-file:   LICENCE+tested-with:    GHC == 8.4+build-type:     Simple++flag development+  manual: True+  default: False++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+  other-modules:+      Core.Program.Context+      Core.Program.Signal+  hs-source-dirs:+      lib+  ghc-options: -Wall -Wwarn -fwarn-tabs+  build-depends:+      Cabal+    , aeson+    , async+    , base >=4.11 && <5+    , bytestring+    , chronologique+    , containers+    , deepseq+    , directory+    , exceptions+    , fingertree+    , hashable+    , hourglass+    , mtl+    , prettyprinter+    , prettyprinter-ansi-terminal+    , safe-exceptions+    , scientific+    , stm+    , template-haskell+    , terminal-size+    , text+    , text-short+    , transformers+    , unix+    , unordered-containers+    , vector+  default-language: Haskell2010++executable experiment+  main-is: SimpleExperiment.hs+  hs-source-dirs:+      tests+  ghc-options: -Wall -Wwarn -fwarn-tabs -threaded+  build-depends:+      Cabal+    , aeson+    , async+    , base >=4.11 && <5+    , bytestring+    , chronologique+    , containers+    , deepseq+    , directory+    , exceptions+    , fingertree+    , hashable+    , hourglass+    , mtl+    , prettyprinter+    , prettyprinter-ansi-terminal+    , safe-exceptions+    , scientific+    , stm+    , template-haskell+    , terminal-size+    , text+    , text-short+    , transformers+    , unbeliever+    , unix+    , unordered-containers+    , vector+  if flag(development)+    ghc-prof-options: -fprof-auto-top+    buildable: True+  else+    buildable: False+  default-language: Haskell2010++executable snippet+  main-is: Snippet.hs+  hs-source-dirs:+      tests+  ghc-options: -Wall -Wwarn -fwarn-tabs -threaded+  build-depends:+      Cabal+    , aeson+    , async+    , base >=4.11 && <5+    , bytestring+    , chronologique+    , containers+    , deepseq+    , directory+    , exceptions+    , fingertree+    , hashable+    , hourglass+    , mtl+    , prettyprinter+    , prettyprinter-ansi-terminal+    , safe-exceptions+    , scientific+    , stm+    , template-haskell+    , terminal-size+    , text+    , text-short+    , transformers+    , unbeliever+    , unix+    , unordered-containers+    , vector+  if flag(development)+    ghc-prof-options: -fprof-auto-top+    buildable: True+  else+    buildable: False+  default-language: Haskell2010++test-suite check+  type: exitcode-stdio-1.0+  main-is: TestSuite.hs+  other-modules:+      CheckArgumentsParsing+      CheckBytesBehaviour+      CheckContainerBehaviour+      CheckJsonWrapper+      CheckProgramMonad+      CheckRopeBehaviour+  hs-source-dirs:+      tests+  ghc-options: -Wall -Wwarn -fwarn-tabs -threaded+  build-depends:+      Cabal+    , aeson+    , async+    , base >=4.11 && <5+    , bytestring+    , chronologique+    , containers+    , deepseq+    , directory+    , exceptions+    , fingertree+    , hashable+    , hourglass+    , hspec+    , mtl+    , prettyprinter+    , prettyprinter-ansi-terminal+    , safe-exceptions+    , scientific+    , stm+    , template-haskell+    , terminal-size+    , text+    , text-short+    , transformers+    , unbeliever+    , unix+    , unordered-containers+    , vector+  default-language: Haskell2010++benchmark performance+  type: exitcode-stdio-1.0+  main-is: GeneralPerformance.hs+  hs-source-dirs:+      bench+  ghc-options: -Wall -Wwarn -fwarn-tabs -threaded+  build-depends:+      Cabal+    , aeson+    , async+    , base >=4.11 && <5+    , bytestring+    , chronologique+    , containers+    , deepseq+    , directory+    , exceptions+    , fingertree+    , gauge+    , hashable+    , hourglass+    , mtl+    , prettyprinter+    , prettyprinter-ansi-terminal+    , safe-exceptions+    , scientific+    , stm+    , template-haskell+    , terminal-size+    , text+    , text-short+    , transformers+    , unbeliever+    , unix+    , unordered-containers+    , vector+  default-language: Haskell2010