diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -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. diff --git a/bench/GeneralPerformance.hs b/bench/GeneralPerformance.hs new file mode 100644 --- /dev/null +++ b/bench/GeneralPerformance.hs @@ -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 diff --git a/lib/Core/Data.hs b/lib/Core/Data.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Data.hs @@ -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 + diff --git a/lib/Core/Data/Structures.hs b/lib/Core/Data/Structures.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Data/Structures.hs @@ -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) diff --git a/lib/Core/Encoding.hs b/lib/Core/Encoding.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Encoding.hs @@ -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 + diff --git a/lib/Core/Encoding/Json.hs b/lib/Core/Encoding/Json.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Encoding/Json.hs @@ -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 #-} + diff --git a/lib/Core/Program.hs b/lib/Core/Program.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program.hs @@ -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 + diff --git a/lib/Core/Program/Arguments.hs b/lib/Core/Program/Arguments.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Arguments.hs @@ -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 + diff --git a/lib/Core/Program/Context.hs b/lib/Core/Program/Context.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Context.hs @@ -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 diff --git a/lib/Core/Program/Execute.hs b/lib/Core/Program/Execute.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Execute.hs @@ -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" diff --git a/lib/Core/Program/Logging.hs b/lib/Core/Program/Logging.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Logging.hs @@ -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')) + diff --git a/lib/Core/Program/Metadata.hs b/lib/Core/Program/Metadata.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Metadata.hs @@ -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 + + diff --git a/lib/Core/Program/Signal.hs b/lib/Core/Program/Signal.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Signal.hs @@ -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 () diff --git a/lib/Core/Program/Unlift.hs b/lib/Core/Program/Unlift.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Unlift.hs @@ -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) + diff --git a/lib/Core/System.hs b/lib/Core/System.hs new file mode 100644 --- /dev/null +++ b/lib/Core/System.hs @@ -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 + diff --git a/lib/Core/System/Base.hs b/lib/Core/System/Base.hs new file mode 100644 --- /dev/null +++ b/lib/Core/System/Base.hs @@ -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) + diff --git a/lib/Core/System/External.hs b/lib/Core/System/External.hs new file mode 100644 --- /dev/null +++ b/lib/Core/System/External.hs @@ -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) + diff --git a/lib/Core/Text.hs b/lib/Core/Text.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Text.hs @@ -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 + diff --git a/lib/Core/Text/Bytes.hs b/lib/Core/Text/Bytes.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Text/Bytes.hs @@ -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' -> +-} diff --git a/lib/Core/Text/Rope.hs b/lib/Core/Text/Rope.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Text/Rope.hs @@ -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 diff --git a/lib/Core/Text/Utilities.hs b/lib/Core/Text/Utilities.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Text/Utilities.hs @@ -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 (== ' ') + diff --git a/tests/CheckArgumentsParsing.hs b/tests/CheckArgumentsParsing.hs new file mode 100644 --- /dev/null +++ b/tests/CheckArgumentsParsing.hs @@ -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"]) + diff --git a/tests/CheckBytesBehaviour.hs b/tests/CheckBytesBehaviour.hs new file mode 100644 --- /dev/null +++ b/tests/CheckBytesBehaviour.hs @@ -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 diff --git a/tests/CheckContainerBehaviour.hs b/tests/CheckContainerBehaviour.hs new file mode 100644 --- /dev/null +++ b/tests/CheckContainerBehaviour.hs @@ -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 "&") + diff --git a/tests/CheckJsonWrapper.hs b/tests/CheckJsonWrapper.hs new file mode 100644 --- /dev/null +++ b/tests/CheckJsonWrapper.hs @@ -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 diff --git a/tests/CheckProgramMonad.hs b/tests/CheckProgramMonad.hs new file mode 100644 --- /dev/null +++ b/tests/CheckProgramMonad.hs @@ -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 ()) diff --git a/tests/CheckRopeBehaviour.hs b/tests/CheckRopeBehaviour.hs new file mode 100644 --- /dev/null +++ b/tests/CheckRopeBehaviour.hs @@ -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) + diff --git a/tests/SimpleExperiment.hs b/tests/SimpleExperiment.hs new file mode 100644 --- /dev/null +++ b/tests/SimpleExperiment.hs @@ -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 diff --git a/tests/Snippet.hs b/tests/Snippet.hs new file mode 100644 --- /dev/null +++ b/tests/Snippet.hs @@ -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" diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs new file mode 100644 --- /dev/null +++ b/tests/TestSuite.hs @@ -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 diff --git a/unbeliever.cabal b/unbeliever.cabal new file mode 100644 --- /dev/null +++ b/unbeliever.cabal @@ -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 +maintainer: Andrew Cowie +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