diff --git a/AnsiColours.png b/AnsiColours.png new file mode 100644 Binary files /dev/null and b/AnsiColours.png differ diff --git a/core-text.cabal b/core-text.cabal --- a/core-text.cabal +++ b/core-text.cabal @@ -1,13 +1,13 @@ -cabal-version: 1.12 +cabal-version: 1.18 -- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 474b85de516532b23adffa6ac413f511b59db0da560430db29418b117b0fbff7 +-- hash: 32fe0043eab486639c92b9e8ea6c9c864fd2aa6c21f0861529c72898e51bc67a name: core-text -version: 0.2.3.6 +version: 0.3.0.0 synopsis: A rope type based on a finger tree over UTF-8 fragments description: A rope data type for text, built as a finger tree over UTF-8 text fragments. The package also includes utiltiy functions for breaking and @@ -32,8 +32,10 @@ copyright: © 2018-2020 Athae Eredh Siniath and Others license: BSD3 license-file: LICENSE -tested-with: GHC == 8.8.3 +tested-with: GHC == 8.8.4 build-type: Simple +extra-doc-files: + AnsiColours.png source-repository head type: git @@ -52,13 +54,14 @@ lib ghc-options: -Wall -Wwarn -fwarn-tabs build-depends: - base >=4.11 && <5 + ansi-terminal + , base >=4.11 && <5 , bytestring + , colour , deepseq , fingertree - , hashable >=1.2 && <1.4 - , prettyprinter >=1.2.1.1 && <1.8 - , prettyprinter-ansi-terminal + , hashable >=1.2 + , prettyprinter >=1.6.2 , template-haskell >=2.14 && <3 , text , text-short diff --git a/lib/Core/Text.hs b/lib/Core/Text.hs --- a/lib/Core/Text.hs +++ b/lib/Core/Text.hs @@ -1,36 +1,34 @@ {-# 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: +-- | +-- 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 -@ -import "Core.Text" -@ + -- | + -- 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, -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 utilities -} -{-| -Useful functions for common use cases. --} - , module Core.Text.Utilities - ) where + -- | + -- Useful functions for common use cases. + module Core.Text.Utilities, + ) +where import Core.Text.Bytes import Core.Text.Rope import Core.Text.Utilities - diff --git a/lib/Core/Text/Breaking.hs b/lib/Core/Text/Breaking.hs --- a/lib/Core/Text/Breaking.hs +++ b/lib/Core/Text/Breaking.hs @@ -3,88 +3,80 @@ -- This is an Internal module, hidden from Haddock module Core.Text.Breaking - ( breakWords - , breakLines - , breakPieces - , intoPieces - , intoChunks - , isNewline - ) + ( breakWords, + breakLines, + breakPieces, + intoPieces, + intoChunks, + isNewline, + ) where +import Core.Text.Rope import Data.Char (isSpace) -import Data.Foldable (foldr) import Data.List (uncons) -import qualified Data.Text.Short as S (ShortText, null, break, uncons,empty) - -import Core.Text.Rope - -{-| -Split a passage of text into a list of words. A line is broken wherever -there is one or more whitespace characters, as defined by "Data.Char"'s -'Data.Char.isSpace'. - -Examples: +import qualified Data.Text.Short as S (ShortText, break, empty, null, uncons) -@ -λ> __breakWords \"This is a test\"__ -[\"This\",\"is\",\"a\",\"test\"] -λ> __breakWords (\"St\" <> \"op and \" <> \"go left\")__ -[\"Stop\",\"and\",\"go\",\"left\"] -λ> __breakWords emptyRope__ -[] -@ --} +-- | +-- Split a passage of text into a list of words. A line is broken wherever +-- there is one or more whitespace characters, as defined by "Data.Char"'s +-- 'Data.Char.isSpace'. +-- +-- Examples: +-- +-- @ +-- λ> __breakWords \"This is a test\"__ +-- [\"This\",\"is\",\"a\",\"test\"] +-- λ> __breakWords (\"St\" <> \"op and \" <> \"go left\")__ +-- [\"Stop\",\"and\",\"go\",\"left\"] +-- λ> __breakWords emptyRope__ +-- [] +-- @ breakWords :: Rope -> [Rope] breakWords = filter (not . nullRope) . breakPieces isSpace -{-| -Split a paragraph of text into a list of its individual lines. The -paragraph will be broken wherever there is a @'\n'@ character. - -Blank lines will be preserved. Note that as a special case you do /not/ get -a blank entry at the end of the a list of newline terminated strings. - -@ -λ> __breakLines \"Hello\\n\\nWorld\\n\"__ -[\"Hello\",\"\",\"World\"] -@ --} +-- | +-- Split a paragraph of text into a list of its individual lines. The +-- paragraph will be broken wherever there is a @'\n'@ character. +-- +-- Blank lines will be preserved. Note that as a special case you do /not/ get +-- a blank entry at the end of the a list of newline terminated strings. +-- +-- @ +-- λ> __breakLines \"Hello\\n\\nWorld\\n\"__ +-- [\"Hello\",\"\",\"World\"] +-- @ breakLines :: Rope -> [Rope] breakLines text = - let - result = breakPieces isNewline text - n = length result - 1 - (fore,aft) = splitAt n result - in case result of - [] -> [] - [p] -> [p] - _ -> if aft == [""] - then fore - else result + let result = breakPieces isNewline text + n = length result - 1 + (fore, aft) = splitAt n result + in case result of + [] -> [] + [p] -> [p] + _ -> + if aft == [""] + then fore + else result -{-| -Predicate testing whether a character is a newline. After -'Data.Char.isSpace' et al in "Data.Char". --} +-- | +-- Predicate testing whether a character is a newline. After +-- 'Data.Char.isSpace' et al in "Data.Char". isNewline :: Char -> Bool isNewline c = c == '\n' {-# INLINEABLE isNewline #-} -{-| -Break a Rope into pieces whereever the given predicate function returns -@True@. If found, that character will not be included on either side. Empty -runs, however, *will* be preserved. --} +-- | +-- Break a Rope into pieces whereever the given predicate function returns +-- @True@. If found, that character will not be included on either side. Empty +-- runs, however, *will* be preserved. breakPieces :: (Char -> Bool) -> Rope -> [Rope] breakPieces predicate text = - let - x = unRope text - (final,result) = foldr (intoPieces predicate) (Nothing,[]) x - in - case final of - Nothing -> result - Just piece -> intoRope piece : result + let x = unRope text + (final, result) = foldr (intoPieces predicate) (Nothing, []) x + in case final of + Nothing -> result + Just piece -> intoRope piece : result {- Was the previous piece a match, or are we in the middle of a run of @@ -92,18 +84,15 @@ before processing into chunks. -} -- now for right fold -intoPieces :: (Char -> Bool) -> S.ShortText -> (Maybe S.ShortText,[Rope]) -> (Maybe S.ShortText,[Rope]) -intoPieces predicate piece (stream,list) = - let - piece' = case stream of +intoPieces :: (Char -> Bool) -> S.ShortText -> (Maybe S.ShortText, [Rope]) -> (Maybe S.ShortText, [Rope]) +intoPieces predicate piece (stream, list) = + let piece' = case stream of Nothing -> piece - Just previous -> piece <> previous -- more rope, less text? - - pieces = intoChunks predicate piece' - in - case uncons pieces of - Nothing -> (Nothing,list) - Just (text,remainder) -> (Just (fromRope text),remainder ++ list) + Just previous -> piece <> previous -- more rope, less text? + pieces = intoChunks predicate piece' + in case uncons pieces of + Nothing -> (Nothing, list) + Just (text, remainder) -> (Just (fromRope text), remainder ++ list) -- -- λ> S.break isSpace "a d" @@ -123,7 +112,7 @@ -- {- -This was more easily expressed as +This was more easily expressed as let remainder' = S.drop 1 remainder @@ -137,17 +126,16 @@ intoChunks :: (Char -> Bool) -> S.ShortText -> [Rope] intoChunks _ piece | S.null piece = [] intoChunks predicate piece = - let - (chunk,remainder) = S.break predicate piece + let (chunk, remainder) = S.break predicate piece - -- Handle the special case that a trailing " " (generalized to predicate) - -- is the only character left. - (trailing,remainder') = case S.uncons remainder of - Nothing -> (False,S.empty) - Just (c,remaining) -> if S.null remaining - then (predicate c,S.empty) - else (False,remaining) - in - if trailing + -- Handle the special case that a trailing " " (generalized to predicate) + -- is the only character left. + (trailing, remainder') = case S.uncons remainder of + Nothing -> (False, S.empty) + Just (c, remaining) -> + if S.null remaining + then (predicate c, S.empty) + else (False, remaining) + in if trailing then intoRope chunk : emptyRope : [] else intoRope chunk : intoChunks predicate remainder' diff --git a/lib/Core/Text/Bytes.hs b/lib/Core/Text/Bytes.hs --- a/lib/Core/Text/Bytes.hs +++ b/lib/Core/Text/Bytes.hs @@ -1,150 +1,141 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- FIXME -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- FIXME +{-# LANGUAGE TypeSynonymInstances #-} {-# 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. --} +-- | +-- Binary (as opposed to textual) data is encountered in weird corners of the +-- Haskell ecosystem. We tend to forget (for example) that the content +-- recieved from a web server is /not/ text until we convert it from UTF-8 (if +-- that's what it is); and of course that glosses over the fact that something +-- of content-type @image/jpeg@ is not text in any way, shape, or form. +-- +-- Bytes also show up when working with crypto algorithms, taking hashes, and +-- when doing serialization to external binary formats. Although we frequently +-- display these in terminals (and in URLs!) as text, but we take for granted +-- that we have actually deserialized the data or rendered the it in +-- hexidecimal or base64 or... +-- +-- This module presents a simple wrapper around various representations of +-- binary data to make it easier to interoperate with libraries supplying +-- or consuming bytes. module Core.Text.Bytes - ( Bytes - , Binary(fromBytes, intoBytes) - , hOutput - , hInput - {-* Internals -} - , unBytes - ) where + ( Bytes, + Binary (fromBytes, intoBytes), + hOutput, + hInput, -import qualified Data.ByteString as B (ByteString, foldl', splitAt - , pack, unpack, length, hPut, hGetContents) -import qualified Data.ByteString.Char8 as C (pack, unpack) -import qualified Data.ByteString.Builder as B (Builder, toLazyByteString, byteString) + -- * Internals + unBytes, + ) +where + +import qualified Data.ByteString as B + ( ByteString, + hGetContents, + hPut, + pack, + unpack, + ) +import qualified Data.ByteString.Builder as B (Builder, byteString, toLazyByteString) import qualified Data.ByteString.Lazy as L (ByteString, fromStrict, toStrict) import Data.Hashable (Hashable) 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) -{-| -A block of data in binary form. --} +-- | +-- A block of data in binary form. newtype Bytes - = StrictBytes B.ByteString - deriving (Show, Eq, Ord, Generic) + = StrictBytes B.ByteString + deriving (Show, Eq, Ord, Generic) -{-| -Access the strict 'ByteString' underlying the @Bytes@ type. --} +-- | +-- Access the strict 'ByteString' underlying the @Bytes@ type. unBytes :: Bytes -> B.ByteString unBytes (StrictBytes b') = b' {-# INLINE unBytes #-} 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. --} +-- | +-- 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 + fromBytes :: Bytes -> α + intoBytes :: α -> Bytes instance Binary Bytes where - fromBytes = id - intoBytes = id + fromBytes = id + intoBytes = id -{-| from "Data.ByteString" Strict -} +-- | from "Data.ByteString" Strict instance Binary B.ByteString where - fromBytes (StrictBytes b') = b' - intoBytes b' = StrictBytes b' + fromBytes (StrictBytes b') = b' + intoBytes b' = StrictBytes b' -{-| from "Data.ByteString.Lazy" -} +-- | from "Data.ByteString.Lazy" instance Binary L.ByteString where - fromBytes (StrictBytes b') = L.fromStrict b' - intoBytes b' = StrictBytes (L.toStrict b') -- expensive + fromBytes (StrictBytes b') = L.fromStrict b' + intoBytes b' = StrictBytes (L.toStrict b') -- expensive instance Binary B.Builder where - fromBytes (StrictBytes b') = B.byteString b' - intoBytes b' = StrictBytes (L.toStrict (B.toLazyByteString b')) + fromBytes (StrictBytes b') = B.byteString b' + intoBytes b' = StrictBytes (L.toStrict (B.toLazyByteString b')) -{-| from "Data.Word" -} +-- | 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: - -@ - 'Core.Program.Execute.write' ('intoRope' b) -@ + fromBytes (StrictBytes b') = B.unpack b' + intoBytes = StrictBytes . B.pack -on the assumption that the bytes in question are UTF-8 (or plain ASCII) -encoded. --} +-- | +-- Output the content of the 'Bytes' to the specified 'Handle'. +-- +-- @ +-- hOutput h b +-- @ +-- +-- 'Core.Program.Execute.output' provides a convenient way to write a @Bytes@ +-- to a file or socket handle from within the 'Core.Program.Execute.Program' +-- monad. +-- +-- Don't use this function to write to @stdout@ if you are using any of the +-- other output or logging facililities of this libarary as you will corrupt +-- the ordering of output on the user's terminal. Instead do: +-- +-- @ +-- 'Core.Program.Execute.write' ('intoRope' b) +-- @ +-- +-- on the assumption that the bytes in question are UTF-8 (or plain ASCII) +-- encoded. hOutput :: Handle -> Bytes -> IO () hOutput handle (StrictBytes b') = B.hPut handle b' -{-| -Read the (entire) contents of a handle into a Bytes object. - -If you want to read the entire contents of a file, you can do: - -@ - contents <- 'Core.System.Base.withFile' name 'Core.System.Base.ReadMode' 'hInput' -@ - -At any kind of scale, Streaming I/O is almost always for better, but for -small files you need to pick apart this is fine. --} +-- | +-- Read the (entire) contents of a handle into a Bytes object. +-- +-- If you want to read the entire contents of a file, you can do: +-- +-- @ +-- contents <- 'Core.System.Base.withFile' name 'Core.System.Base.ReadMode' 'hInput' +-- @ +-- +-- At any kind of scale, Streaming I/O is almost always for better, but for +-- small files you need to pick apart this is fine. hInput :: Handle -> IO Bytes hInput handle = do - contents <- B.hGetContents handle - return (StrictBytes contents) + contents <- B.hGetContents handle + return (StrictBytes contents) {- instance Show Bytes where show x = case x of - StrictBytes b' -> + StrictBytes b' -> -} diff --git a/lib/Core/Text/Parsing.hs b/lib/Core/Text/Parsing.hs --- a/lib/Core/Text/Parsing.hs +++ b/lib/Core/Text/Parsing.hs @@ -1,39 +1,37 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide #-} -- This is an Internal module, hidden from Haddock module Core.Text.Parsing - ( calculatePositionEnd - ) + ( calculatePositionEnd, + ) where +import Core.Text.Rope import Data.Foldable (foldl') import qualified Data.Text.Short as S (ShortText, foldl') -import Core.Text.Rope +-- | +-- Calculate the line number and column number of a Rope (interpreting it as +-- if is a block of text in a file). By the convention observed by all leading +-- brands of text editor, lines and columns are @1@ origin, so an empty Rope +-- is position @(1,1)@. -{-| -Calculate the line number and column number of a Rope (interpreting it as -if is a block of text in a file). By the convention observed by all leading -brands of text editor, lines and columns are @1@ origin, so an empty Rope -is position @(1,1)@. --} -- Of course, if Rope itself cached position information in the FingerTree -- monoid this would be trivial. -calculatePositionEnd :: Rope -> (Int,Int) +calculatePositionEnd :: Rope -> (Int, Int) calculatePositionEnd text = - let - x = unRope text - (l,c) = foldl' calculateChunk (1,1) x - in - (l,c) + let x = unRope text + (l, c) = foldl' calculateChunk (1, 1) x + in (l, c) -calculateChunk :: (Int,Int) -> S.ShortText -> (Int,Int) +calculateChunk :: (Int, Int) -> S.ShortText -> (Int, Int) calculateChunk loc piece = - S.foldl' f loc piece + S.foldl' f loc piece where - f :: (Int,Int) -> Char -> (Int,Int) - f !(!l,!c) ch = if ch == '\n' - then (l+1,1) - else (l,c+1) + f :: (Int, Int) -> Char -> (Int, Int) + f !(!l, !c) ch = + if ch == '\n' + then (l + 1, 1) + else (l, c + 1) diff --git a/lib/Core/Text/Rope.hs b/lib/Core/Text/Rope.hs --- a/lib/Core/Text/Rope.hs +++ b/lib/Core/Text/Rope.hs @@ -1,282 +1,309 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# 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. +-- | +-- If you're accustomed to working with text in almost any other programming +-- language, you'd be aware that a \"string\" typically refers to an in-memory +-- /array/ of characters. Traditionally this was a single ASCII byte per +-- character; more recently UTF-8 variable byte encodings which dramatically +-- complicates finding offsets but which gives efficient support for the +-- entire Unicode character space. In Haskell, the original text type, +-- 'String', is implemented as a list of 'Char' which, because a Haskell list +-- is implemented as a /linked-list of boxed values/, is wildly inefficient at +-- any kind of scale. +-- +-- In modern Haskell there are two primary ways to represent text. +-- +-- First is via the [rather poorly named] @ByteString@ from the __bytestring__ +-- package (which is an array of bytes in pinned memory). The +-- "Data.ByteString.Char8" submodule gives you ways to manipulate those arrays +-- as if they were ASCII characters. Confusingly there are both strict +-- (@Data.ByteString@) and lazy (@Data.ByteString.Lazy@) variants which are +-- often hard to tell the difference between when reading function signatures +-- or haddock documentation. The performance problem an immutable array backed +-- data type runs into is that appending a character (that is, ASCII byte) or +-- concatonating a string (that is, another array of ASCII bytes) is very +-- expensive and requires allocating a new larger array and copying the whole +-- thing into it. This led to the development of \"builders\" which amortize +-- this reallocation cost over time, but it can be cumbersome to switch +-- between @Builder@, the lazy @ByteString@ that results, and then having to +-- inevitably convert to a strict @ByteString@ because that's what the next +-- function in your sequence requires. +-- +-- The second way is through the opaque @Text@ type of "Data.Text" from the +-- __text__ package, which is well tuned and high-performing but suffers from +-- the same design; it is likewise backed by arrays. Rather surprisingly, the +-- storage backing Text objects are encoded in UTF-16, meaning every time you +-- want to work with unicode characters that came in from /anywhere/ else and +-- which inevitably are UTF-8 encoded you have to convert to UTF-16 and copy +-- into a new array, wasting time and memory. +-- +-- In this package we introduce 'Rope', a text type backed by the 2-3 +-- 'Data.FingerTree.FingerTree' data structure from the __fingertree__ +-- package. This is not an uncommon solution in many languages as finger trees +-- support exceptionally efficient appending to either end and good +-- performance inserting anywhere else (you often find them as the backing +-- data type underneath text editors for this reason). Rather than 'Char' the +-- pieces of the rope are 'Data.Text.Short.ShortText' from the __text-short__ +-- package, which are UTF-8 encoded and in normal memory managed by the +-- Haskell runtime. Conversion from other Haskell text types is not /O(1)/ +-- (UTF-8 validity must be checked, or UTF-16 decoded, or...), but in our +-- benchmarking the performance has been comparable to the established types +-- and you may find the resultant interface for combining chunks is comparable +-- to using a Builder, without being forced to use a Builder. +-- +-- 'Rope' is used as the text type throughout this library. If you use the +-- functions within this package (rather than converting to other text types) +-- operations are quite efficient. When you do need to convert to another type +-- you can use 'fromRope' or 'intoRope' from the 'Textual' typeclass. +-- +-- Note that we haven't tried to cover the entire gamut of operations or +-- customary convenience functions you would find in the other libraries; so +-- far 'Rope' is concentrated on aiding interoperation, being good at +-- appending (lots of) small pieces, and then efficiently taking the resultant +-- text object out to a file handle, be that the terminal console, a file, or +-- a network socket. +module Core.Text.Rope + ( -- * Rope type + Rope, + emptyRope, + singletonRope, + replicateRope, + replicateChar, + widthRope, + splitRope, + insertRope, + containsCharacter, + findIndexRope, -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. + -- * Interoperation and Output + Textual (fromRope, intoRope, appendRope), + hWrite, --} -module Core.Text.Rope - ( {-* Rope type -} - Rope - , emptyRope - , singletonRope - , replicateRope - , replicateChar - , widthRope - , splitRope - , insertRope - , containsCharacter - , findIndexRope - {-* Interoperation and Output -} - , Textual(fromRope, intoRope, appendRope) - , hWrite - {-* Internals -} - , unRope - , nullRope - , unsafeIntoRope - , Width(..) - ) where + -- * Internals + unRope, + nullRope, + unsafeIntoRope, + Width (..), + ) +where -import Control.DeepSeq (NFData(..)) +import Control.DeepSeq (NFData (..)) +import Core.Text.Bytes import qualified Data.ByteString as B (ByteString) -import qualified Data.ByteString.Builder as B (toLazyByteString - , hPutBuilder) -import qualified Data.ByteString.Lazy as L (ByteString, toStrict - , foldrChunks) -import qualified Data.FingerTree as F (FingerTree, Measured(..), empty - , singleton, (><), (<|), (|>), search, SearchResult(..), null - , viewl, ViewL(..)) -import Data.Foldable (foldr, foldr', foldl', foldMap, toList, any) +import qualified Data.ByteString.Builder as B + ( hPutBuilder, + toLazyByteString, + ) +import qualified Data.ByteString.Lazy as L + ( ByteString, + foldrChunks, + toStrict, + ) +import qualified Data.FingerTree as F + ( FingerTree, + Measured (..), + SearchResult (..), + ViewL (..), + empty, + null, + search, + singleton, + viewl, + (<|), + (><), + (|>), + ) +import Data.Foldable (foldl', foldr', toList) import Data.Hashable (Hashable, hashWithSalt) -import Data.String (IsString(..)) +import Data.String (IsString (..)) import qualified Data.Text as T (Text) -import qualified Data.Text.Lazy as U (Text, fromChunks, foldrChunks - , toStrict) -import qualified Data.Text.Lazy.Builder as U (Builder, toLazyText - , fromText) -import Data.Text.Prettyprint.Doc (Pretty(..), emptyDoc) -import qualified Data.Text.Short as S (ShortText, length, any, null - , fromText, toText, fromByteString, pack, unpack, singleton - , append, empty, toBuilder, splitAt, findIndex, replicate) +import qualified Data.Text.Lazy as U + ( Text, + foldrChunks, + fromChunks, + toStrict, + ) +import qualified Data.Text.Lazy.Builder as U + ( Builder, + fromText, + toLazyText, + ) +import Data.Text.Prettyprint.Doc (Pretty (..), emptyDoc) +import qualified Data.Text.Short as S + ( ShortText, + any, + append, + empty, + findIndex, + fromByteString, + fromText, + length, + null, + pack, + replicate, + singleton, + splitAt, + toBuilder, + toText, + unpack, + ) import qualified Data.Text.Short.Unsafe as S (fromByteStringUnsafe) import GHC.Generics (Generic) import System.IO (Handle) -import Core.Text.Bytes - -{-| -A type for textual data. A rope is text backed by a tree data structure, -rather than a single large continguous array, as is the case for strings. - -There are three use cases: - -/Referencing externally sourced data/ - -Often we interpret large blocks of data sourced from external systems as -text. Ideally we would hold onto this without copying the memory, but (as -in the case of @ByteString@ which is the most common source of data) before -we can treat it as text we have to validate the UTF-8 content. Safety -first. We also copy it out of pinned memory, allowing the Haskell runtime -to manage the storage. - -/Interoperating with other libraries/ - -The only constant of the Haskell universe is that you won't have the right -combination of {strict, lazy} × {@Text@, @ByteString@, @String@, @[Word8]@, -etc} you need for the next function call. The 'Textual' typeclass provides -for moving between different text representations. To convert between -@Rope@ and something else use 'fromRope'; to construct a @Rope@ from -textual content in another type use 'intoRope'. - -You can get at the underlying finger tree with the 'unRope' function. - -/Assembling text to go out/ - -This involves considerable appending of data, very very occaisionally -inserting it. Often the pieces are tiny. To add text to a @Rope@ use the -'appendRope' method as below or the ('Data.Semigroup.<>') operator from -"Data.Monoid" (like you would have with a @Builder@). - -Output to a @Handle@ can be done efficiently with 'hWrite'. --} +-- | +-- A type for textual data. A rope is text backed by a tree data structure, +-- rather than a single large continguous array, as is the case for strings. +-- +-- There are three use cases: +-- +-- /Referencing externally sourced data/ +-- +-- Often we interpret large blocks of data sourced from external systems as +-- text. Ideally we would hold onto this without copying the memory, but (as +-- in the case of @ByteString@ which is the most common source of data) before +-- we can treat it as text we have to validate the UTF-8 content. Safety +-- first. We also copy it out of pinned memory, allowing the Haskell runtime +-- to manage the storage. +-- +-- /Interoperating with other libraries/ +-- +-- The only constant of the Haskell universe is that you won't have the right +-- combination of {strict, lazy} × {@Text@, @ByteString@, @String@, @[Word8]@, +-- etc} you need for the next function call. The 'Textual' typeclass provides +-- for moving between different text representations. To convert between +-- @Rope@ and something else use 'fromRope'; to construct a @Rope@ from +-- textual content in another type use 'intoRope'. +-- +-- You can get at the underlying finger tree with the 'unRope' function. +-- +-- /Assembling text to go out/ +-- +-- This involves considerable appending of data, very very occaisionally +-- inserting it. Often the pieces are tiny. To add text to a @Rope@ use the +-- 'appendRope' method as below or the ('Data.Semigroup.<>') operator from +-- "Data.Monoid" (like you would have with a @Builder@). +-- +-- Output to a @Handle@ can be done efficiently with 'hWrite'. newtype Rope - = Rope (F.FingerTree Width S.ShortText) - deriving Generic + = Rope (F.FingerTree Width S.ShortText) + deriving (Generic) instance NFData Rope where - rnf (Rope x) = foldMap (\piece -> rnf piece) x + rnf (Rope x) = foldMap (\piece -> rnf piece) x instance Show Rope where - show text = "\"" ++ fromRope text ++ "\"" + show text = "\"" ++ fromRope text ++ "\"" instance Eq Rope where - (==) (Rope x1) (Rope x2) = (==) (stream x1) (stream x2) - where - stream x = foldMap S.unpack x + (==) (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 + 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: + pretty (Rope x) = foldr ((<>) . pretty . S.toText) emptyDoc x -@ -import qualified "Data.FingerTree" as F -- from the __fingertree__ package -import qualified "Data.Text.Short" as S -- from the __text-short__ package -@ --} +-- | +-- 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@. --} +-- | +-- 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) + deriving (Eq, Ord, Show, Num, Generic) instance F.Measured Width S.ShortText where - measure :: S.ShortText -> Width - measure piece = Width (S.length piece) + measure :: S.ShortText -> Width + measure piece = Width (S.length piece) instance Semigroup Width where - (<>) (Width w1) (Width w2) = Width (w1 + w2) + (<>) (Width w1) (Width w2) = Width (w1 + w2) instance Monoid Width where - mempty = Width 0 - mappend = (<>) + mempty = Width 0 + mappend = (<>) -- here Maybe we just need type Strand = ShortText and then Rope is -- FingerTree Strand or Builder (Strand) instance IsString Rope where - fromString "" = emptyRope - fromString xs = Rope . F.singleton . S.pack $ xs + fromString "" = emptyRope + fromString xs = Rope . F.singleton . S.pack $ xs instance Semigroup Rope where - (<>) text1@(Rope x1) text2@(Rope x2) = - if F.null x2 - then text1 - else if F.null x1 - then text2 - else Rope ((F.><) x1 x2) -- god I hate these operators + (<>) text1@(Rope x1) text2@(Rope x2) = + if F.null x2 + then text1 + else + if F.null x1 + then text2 + else Rope ((F.><) x1 x2) -- god I hate these operators instance Monoid Rope where - mempty = emptyRope - mappend = (<>) + mempty = emptyRope + mappend = (<>) -{-| -An zero-length 'Rope'. You can also use @\"\"@ presuming the -__@OverloadedStrings@__ language extension is turned on in your source -file. --} +-- | +-- An zero-length 'Rope'. You can also use @\"\"@ presuming the +-- __@OverloadedStrings@__ language extension is turned on in your source +-- file. emptyRope :: Rope emptyRope = Rope F.empty -{-# INLINABLE emptyRope #-} +{-# INLINEABLE emptyRope #-} -{-| -A 'Rope' with but a single character. --} +-- | +-- A 'Rope' with but a single character. singletonRope :: Char -> Rope singletonRope = Rope . F.singleton . S.singleton - -{-| -Repeat the input 'Rope' @n@ times. The follows the same semantics as other -@replicate@ functions; if you ask for zero copies you'll get an empty text -and if you ask for lots of @""@ you'll get ... an empty text. - -/Implementation note/ - -Rather than copying the input /n/ times, this will simply add structure to hold /n/ -references to the provided input text. --} +-- | +-- Repeat the input 'Rope' @n@ times. The follows the same semantics as other +-- @replicate@ functions; if you ask for zero copies you'll get an empty text +-- and if you ask for lots of @""@ you'll get ... an empty text. +-- +-- /Implementation note/ +-- +-- Rather than copying the input /n/ times, this will simply add structure to hold /n/ +-- references to the provided input text. replicateRope :: Int -> Rope -> Rope replicateRope count (Rope x) = - let - x' = foldr (\ _ acc -> (F.><) x acc) F.empty [1..count] - in - Rope x' - -{-| -Repeat the input 'Char' @n@ times. This is a special case of -'replicateRope' above. - -/Implementation note/ + let x' = foldr (\_ acc -> (F.><) x acc) F.empty [1 .. count] + in Rope x' -Rather than making a huge FingerTree full of single characters, this -function will allocate a single ShortText comprised of the repeated input -character. --} +-- | +-- Repeat the input 'Char' @n@ times. This is a special case of +-- 'replicateRope' above. +-- +-- /Implementation note/ +-- +-- Rather than making a huge FingerTree full of single characters, this +-- function will allocate a single ShortText comprised of the repeated input +-- character. replicateChar :: Int -> Char -> Rope replicateChar count = Rope . F.singleton . S.replicate count . S.singleton -{-| -Get the length of this text, in characters. --} +-- | +-- Get the length of this text, in characters. widthRope :: Rope -> Int widthRope = foldr' f 0 . unRope where @@ -284,79 +311,71 @@ nullRope :: Rope -> Bool nullRope (Rope x) = case F.viewl x of - F.EmptyL -> True - (F.:<) piece _ -> S.null piece - -{-| -Break the text into two pieces at the specified offset. - -Examples: - -@ -λ> __splitRope 0 \"abcdef\"__ -(\"\", \"abcdef\") -λ> __splitRope 3 \"abcdef\"__ -(\"abc\", \"def\") -λ> __splitRope 6 \"abcdef\"__ -(\"abcdef\",\"\") -@ - -Going off either end behaves sensibly: + F.EmptyL -> True + (F.:<) piece _ -> S.null piece -@ -λ> __splitRope 7 \"abcdef\"__ -(\"abcdef\",\"\") -λ> __splitRope (-1) \"abcdef\"__ -(\"\", \"abcdef\") -@ --} -splitRope :: Int -> Rope -> (Rope,Rope) +-- | +-- Break the text into two pieces at the specified offset. +-- +-- Examples: +-- +-- @ +-- λ> __splitRope 0 \"abcdef\"__ +-- (\"\", \"abcdef\") +-- λ> __splitRope 3 \"abcdef\"__ +-- (\"abc\", \"def\") +-- λ> __splitRope 6 \"abcdef\"__ +-- (\"abcdef\",\"\") +-- @ +-- +-- Going off either end behaves sensibly: +-- +-- @ +-- λ> __splitRope 7 \"abcdef\"__ +-- (\"abcdef\",\"\") +-- λ> __splitRope (-1) \"abcdef\"__ +-- (\"\", \"abcdef\") +-- @ +splitRope :: Int -> Rope -> (Rope, Rope) splitRope i text@(Rope x) = - let - pos = Width i - result = F.search (\w1 _ -> w1 >= pos) x - in - case result of + 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)) + let (Width w) = F.measure before + (one, two) = S.splitAt (i - w) piece + in (Rope ((F.|>) before one), Rope ((F.<|) two after)) F.OnLeft -> (Rope F.empty, text) F.OnRight -> (text, Rope F.empty) F.Nowhere -> error "Position not found in split. Probable cause: predicate function given not monotonic. This is supposed to be unreachable" -{-| -Insert a new piece of text into an existing @Rope@ at the specified offset. - -Examples: - -@ -λ> __insertRope 3 \"Con\" \"Def 1\"__ -"DefCon 1" -λ> __insertRope 0 \"United \" \"Nations\"__ -"United Nations" -@ --} +-- | +-- Insert a new piece of text into an existing @Rope@ at the specified offset. +-- +-- Examples: +-- +-- @ +-- λ> __insertRope 3 \"Con\" \"Def 1\"__ +-- "DefCon 1" +-- λ> __insertRope 0 \"United \" \"Nations\"__ +-- "United Nations" +-- @ insertRope :: Int -> Rope -> Rope -> Rope insertRope 0 (Rope new) (Rope x) = Rope ((F.><) new x) insertRope i (Rope new) text = - let - (Rope before,Rope after) = splitRope i text - in - Rope (mconcat [before, new, after]) + let (Rope before, Rope after) = splitRope i text + in Rope (mconcat [before, new, after]) findIndexRope :: (Char -> Bool) -> Rope -> Maybe Int -findIndexRope predicate = fst . foldl f (Nothing,0) . unRope +findIndexRope predicate = fst . foldl f (Nothing, 0) . unRope where -- convert this to Maybe monad, maybe - f :: (Maybe Int,Int) -> S.ShortText -> (Maybe Int,Int) + f :: (Maybe Int, Int) -> S.ShortText -> (Maybe Int, Int) f acc piece = case acc of - (Just j,_) -> (Just j,0) - (Nothing,!i) -> case S.findIndex predicate piece of - Nothing -> (Nothing,i + S.length piece) - Just !j -> (Just (i + j),0) + (Just j, _) -> (Just j, 0) + (Nothing, !i) -> case S.findIndex predicate piece of + Nothing -> (Nothing, i + S.length piece) + Just !j -> (Just (i + j), 0) -- -- Manual instance to get around the fact that FingerTree doesn't have a @@ -371,180 +390,174 @@ -- corresponding tree. -- instance Hashable Rope where - hashWithSalt salt (Rope x) = foldl' f salt x - where - f :: Int -> S.ShortText -> Int - f num piece = hashWithSalt num piece - -{-| -Machinery to interpret a type as containing valid Unicode that can be -represented as a @Rope@ object. - -/Implementation notes/ + hashWithSalt salt (Rope x) = foldl' f salt x + where + f :: Int -> S.ShortText -> Int + f num piece = hashWithSalt num piece -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. +-- | +-- Machinery to interpret a type as containing valid Unicode that can be +-- represented as a @Rope@ object. +-- +-- /Implementation notes/ +-- +-- Given that @Rope@ is backed by a finger tree, 'append' is relatively +-- inexpensive, plus whatever the cost of conversion is. There is a subtle +-- trap, however: if adding small fragments of that were obtained by slicing +-- (for example) a large ByteString we would end up holding on to a reference +-- to the entire underlying block of memory. This module is optimized to +-- reduce heap fragmentation by letting the Haskell runtime and garbage +-- collector manage the memory, so instances are expected to /copy/ these +-- substrings out of pinned memory. +-- +-- The @ByteString@ instance requires that its content be valid UTF-8. If not +-- an empty @Rope@ will be returned. +-- +-- Several of the 'fromRope' implementations are expensive and involve a lot +-- of intermediate allocation and copying. If you're ultimately writing to a +-- handle prefer 'hWrite' which will write directly to the output buffer. +class Textual α where + -- | + -- Convert a @Rope@ into another text-like type. + fromRope :: Rope -> α -The @ByteString@ instance requires that its content be valid UTF-8. If not -an empty @Rope@ will be returned. + -- | + -- Take another text-like type and convert it to a @Rope@. + intoRope :: α -> Rope -Several of the 'fromRope' implementations are expensive and involve a lot -of intermediate allocation and copying. If you're ultimately writing to a -handle prefer 'hWrite' which will write directly to the output buffer. --} -class Textual α where - {-| -Convert a @Rope@ into another text-like type. - -} - fromRope :: Rope -> α - {-| -Take another text-like type and convert it to a @Rope@. - -} - intoRope :: α -> Rope - {-| -Append some text to this @Rope@. The default implementation is basically a -convenience wrapper around calling 'intoRope' and 'mappend'ing it to your -text (which will work just fine, but for some types more efficient -implementations are possible). - -} - appendRope :: α -> Rope -> Rope - appendRope thing text = text <> intoRope thing + -- | + -- Append some text to this @Rope@. The default implementation is basically a + -- convenience wrapper around calling 'intoRope' and 'mappend'ing it to your + -- text (which will work just fine, but for some types more efficient + -- implementations are possible). + appendRope :: α -> Rope -> Rope + appendRope thing text = text <> intoRope thing instance Textual (F.FingerTree Width S.ShortText) where - fromRope = unRope - intoRope = Rope + fromRope = unRope + intoRope = Rope instance Textual Rope where - fromRope = id - intoRope = id - appendRope (Rope x2) (Rope x1) = Rope ((F.><) x1 x2) + fromRope = id + intoRope = id + appendRope (Rope x2) (Rope x1) = Rope ((F.><) x1 x2) -{-| from "Data.Text.Short" -} +-- | from "Data.Text.Short" instance Textual S.ShortText where - fromRope = foldr S.append S.empty . unRope - intoRope = Rope . F.singleton - appendRope piece (Rope x) = Rope ((F.|>) x piece) + fromRope = foldr S.append S.empty . unRope + intoRope = Rope . F.singleton + appendRope piece (Rope x) = Rope ((F.|>) x piece) -{-| from "Data.Text" Strict -} +-- | 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 + fromRope = U.toStrict . U.toLazyText . foldr f mempty . unRope + where + f :: S.ShortText -> U.Builder -> U.Builder + f piece built = (<>) (U.fromText (S.toText piece)) built - intoRope t = Rope (F.singleton (S.fromText t)) - appendRope chunk (Rope x) = Rope ((F.|>) x (S.fromText chunk)) + intoRope t = Rope (F.singleton (S.fromText t)) + appendRope chunk (Rope x) = Rope ((F.|>) x (S.fromText chunk)) -{-| from "Data.Text.Lazy" -} +-- | 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) + 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 -} +-- | 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 + 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 + -- If the input ByteString does not contain valid UTF-8 then an empty + -- Rope will be returned. That's not ideal. + intoRope b' = case S.fromByteString b' of + Just piece -> Rope (F.singleton piece) + Nothing -> Rope F.empty -- bad - -- ditto - appendRope b' (Rope x) = case S.fromByteString b' of - Just piece -> Rope ((F.|>) x piece) - Nothing -> (Rope x) -- bad + -- ditto + appendRope b' (Rope x) = case S.fromByteString b' of + Just piece -> Rope ((F.|>) x piece) + Nothing -> (Rope x) -- bad -{-| from "Data.ByteString.Lazy" -} +-- | from "Data.ByteString.Lazy" instance Textual L.ByteString where - fromRope = B.toLazyByteString . foldr g mempty . unRope - where - g piece built = (<>) (S.toBuilder piece) built + 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 + 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 instance Textual Bytes where - fromRope = intoBytes . (fromRope :: Rope -> B.ByteString) - intoRope = intoRope . unBytes + fromRope = intoBytes . (fromRope :: Rope -> B.ByteString) + intoRope = intoRope . unBytes instance Binary Rope where - fromBytes = intoRope . unBytes - intoBytes = intoBytes . (fromRope :: Rope -> B.ByteString) - + fromBytes = intoRope . unBytes + intoBytes = intoBytes . (fromRope :: Rope -> B.ByteString) -{-| -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@. --} +-- | +-- 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" -} +-- | 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. + fromRope (Rope x) = foldr h [] x + where + h piece string = (S.unpack piece) ++ string -- ugh + intoRope = Rope . F.singleton . S.pack -If you're working in the - -monad, then - -provides an efficient way to write a @Rope@ to @stdout@. --} +-- | +-- 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 +-- +-- monad, then +-- +-- provides an efficient way to write a @Rope@ to @stdout@. hWrite :: Handle -> Rope -> IO () hWrite handle (Rope x) = B.hPutBuilder handle (foldr j mempty x) where j piece built = (<>) (S.toBuilder piece) built -{-| -Does the text contain this character? - -We've used it to ask whether there are newlines present in a @Rope@, for -example: - -@ - if 'containsCharacter' \'\\n\' text - then handleComplexCase - else keepItSimple -@ --} +-- | +-- Does the text contain this character? +-- +-- We've used it to ask whether there are newlines present in a @Rope@, for +-- example: +-- +-- @ +-- if 'containsCharacter' \'\\n\' text +-- then handleComplexCase +-- else keepItSimple +-- @ containsCharacter :: Char -> Rope -> Bool containsCharacter q (Rope x) = any j x where diff --git a/lib/Core/Text/Utilities.hs b/lib/Core/Text/Utilities.hs --- a/lib/Core/Text/Utilities.hs +++ b/lib/Core/Text/Utilities.hs @@ -1,134 +1,332 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK prune #-} -{-| -Useful tools for working with 'Rope's. Support for pretty printing, -multi-line strings, and... --} -module Core.Text.Utilities ( - {-* Pretty printing -} - Render(..) - , render - , renderNoAnsi - {-* Helpers -} - , indefinite - , breakWords - , breakLines - , breakPieces - , isNewline - , wrap - , calculatePositionEnd - , underline - , leftPadWith - , rightPadWith - {-* Multi-line strings -} - , quote +-- | +-- Useful tools for working with 'Rope's. Support for pretty printing, +-- multi-line strings, and... +-- +-- ![ANSI colours](AnsiColours.png) +module Core.Text.Utilities + ( -- * Pretty printing + Render (..), + AnsiColour, + bold, + render, + renderNoAnsi, + dullRed, + brightRed, + pureRed, + dullGreen, + brightGreen, + pureGreen, + dullBlue, + brightBlue, + pureBlue, + dullCyan, + brightCyan, + pureCyan, + dullMagenta, + brightMagenta, + pureMagenta, + dullYellow, + brightYellow, + pureYellow, + pureBlack, + dullGrey, + brightGrey, + pureGrey, + pureWhite, + dullWhite, + brightWhite, - -- for testing - , intoPieces - , intoChunks + -- * Helpers + indefinite, + breakWords, + breakLines, + breakPieces, + isNewline, + wrap, + calculatePositionEnd, + underline, + leftPadWith, + rightPadWith, - , byteChunk -) where + -- * Multi-line strings + quote, + -- for testing + intoPieces, + intoChunks, + byteChunk, + intoDocA, + ) +where +import Core.Text.Breaking +import Core.Text.Bytes +import Core.Text.Parsing +import Core.Text.Rope import Data.Bits (Bits (..)) +import qualified Data.ByteString as B (ByteString, length, splitAt, unpack) import Data.Char (intToDigit) -import qualified Data.ByteString as B (ByteString, splitAt, length, unpack) -import qualified Data.FingerTree as F ((<|), ViewL(..), viewl) -import qualified Data.List as List (foldl', dropWhileEnd, splitAt) -import Data.Monoid ((<>)) +import Data.Colour.SRGB (sRGB, sRGB24read) +import qualified Data.FingerTree as F (ViewL (..), viewl, (<|)) +import qualified Data.List as List (dropWhileEnd, foldl', splitAt) import qualified Data.Text as T -import qualified Data.Text.Short as S (ShortText, uncons, toText, replicate - , singleton) -import Data.Text.Prettyprint.Doc (Doc, layoutPretty , annotate, reAnnotateS - , unAnnotateS, Pretty(..), pretty, emptyDoc - , LayoutOptions(LayoutOptions) - , PageWidth(AvailablePerLine) - , hsep, vcat, group, flatAlt - , softline' - ) - -import Data.Text.Prettyprint.Doc.Render.Terminal (renderLazy, AnsiStyle - , color, Color(..)) - +import Data.Text.Prettyprint.Doc + ( Doc, + LayoutOptions (LayoutOptions), + PageWidth (AvailablePerLine), + Pretty (..), + SimpleDocStream (..), + annotate, + emptyDoc, + flatAlt, + group, + hsep, + layoutPretty, + pretty, + reAnnotateS, + softline', + unAnnotateS, + vcat, + ) +import Data.Text.Prettyprint.Doc.Render.Text (renderLazy) +import qualified Data.Text.Short as S + ( ShortText, + replicate, + singleton, + toText, + uncons, + ) import Data.Word (Word8) import Language.Haskell.TH (litE, stringL) -import Language.Haskell.TH.Quote (QuasiQuoter(QuasiQuoter)) +import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter)) +import System.Console.ANSI.Codes (setSGRCode) +import System.Console.ANSI.Types (ConsoleIntensity (..), ConsoleLayer (..), SGR (..)) -import Core.Text.Bytes -import Core.Text.Breaking -import Core.Text.Parsing -import Core.Text.Rope +-- | +-- An accumulation of ANSI escape codes used to add colour when pretty +-- printing to console. +newtype AnsiColour = Escapes [SGR] -- 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. +-- | +-- 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 +-- 's +-- +-- 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 α :: * -Use 'render' to build text object for later use or -'s - -if you're writing directly to console now. --} + -- | + -- Convert semantic tokens to specific ANSI escape tokens + colourize :: Token α -> AnsiColour -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 α) + -- | + -- Arrange your type as a 'Doc' @ann@, annotated with your semantic + -- tokens. + highlight :: α -> Doc (Token α) +-- | Nothing should be invoking 'intoDocA'. +intoDocA :: α -> Doc (Token α) +intoDocA = error "Nothing should be invoking this method directly." + +{-# DEPRECATED intoDocA "method'intoDocA' has been renamed 'highlight'; implement that instead." #-} + +-- | Medium \"Scarlet Red\" (@#cc0000@ from the Tango color palette). +dullRed :: AnsiColour +dullRed = + Escapes [SetRGBColor Foreground (sRGB24read "#CC0000")] + +-- | Highlighted \"Scarlet Red\" (@#ef2929@ from the Tango color palette). +brightRed :: AnsiColour +brightRed = + Escapes [SetRGBColor Foreground (sRGB24read "#EF2929")] + +-- | Pure \"Red\" (full RGB red channel only). +pureRed :: AnsiColour +pureRed = + Escapes [SetRGBColor Foreground (sRGB 1 0 0)] + +-- | Shadowed \"Chameleon\" (@#4e9a06@ from the Tango color palette). +dullGreen :: AnsiColour +dullGreen = + Escapes [SetRGBColor Foreground (sRGB24read "#4E9A06")] + +-- | Highlighted \"Chameleon\" (@#8ae234@ from the Tango color palette). +brightGreen :: AnsiColour +brightGreen = + Escapes [SetRGBColor Foreground (sRGB24read "#8AE234")] + +-- | Pure \"Green\" (full RGB green channel only). +pureGreen :: AnsiColour +pureGreen = + Escapes [SetRGBColor Foreground (sRGB 0 1 0)] + +-- | Medium \"Sky Blue\" (@#3465a4@ from the Tango color palette). +dullBlue :: AnsiColour +dullBlue = + Escapes [SetRGBColor Foreground (sRGB24read "#3465A4")] + +-- | Highlighted \"Sky Blue\" (@#729fcf@ from the Tango color palette). +brightBlue :: AnsiColour +brightBlue = + Escapes [SetRGBColor Foreground (sRGB24read "#729FCF")] + +-- | Pure \"Blue\" (full RGB blue channel only). +pureBlue :: AnsiColour +pureBlue = + Escapes [SetRGBColor Foreground (sRGB 0 0 1)] + +-- | Dull \"Cyan\" (from the __gnome-terminal__ console theme). +dullCyan :: AnsiColour +dullCyan = + Escapes [SetRGBColor Foreground (sRGB24read "#06989A")] + +-- | Bright \"Cyan\" (from the __gnome-terminal__ console theme). +brightCyan :: AnsiColour +brightCyan = + Escapes [SetRGBColor Foreground (sRGB24read "#34E2E2")] + +-- | Pure \"Cyan\" (full RGB blue + green channels). +pureCyan :: AnsiColour +pureCyan = + Escapes [SetRGBColor Foreground (sRGB 0 1 1)] + +-- | Medium \"Plum\" (@#75507b@ from the Tango color palette). +dullMagenta :: AnsiColour +dullMagenta = + Escapes [SetRGBColor Foreground (sRGB24read "#75507B")] + +-- | Highlighted \"Plum\" (@#ad7fa8@ from the Tango color palette). +brightMagenta :: AnsiColour +brightMagenta = + Escapes [SetRGBColor Foreground (sRGB24read "#AD7FA8")] + +-- | Pure \"Magenta\" (full RGB red + blue channels). +pureMagenta :: AnsiColour +pureMagenta = + Escapes [SetRGBColor Foreground (sRGB 1 0 1)] + +-- | Shadowed \"Butter\" (@#c4a000@ from the Tango color palette). +dullYellow :: AnsiColour +dullYellow = + Escapes [SetRGBColor Foreground (sRGB24read "#C4A000")] + +-- | Highlighted \"Butter\" (@#fce94f@ from the Tango color palette). +brightYellow :: AnsiColour +brightYellow = + Escapes [SetRGBColor Foreground (sRGB24read "#FCE94F")] + +-- | Pure \"Yellow\" (full RGB red + green channels). +pureYellow :: AnsiColour +pureYellow = + Escapes [SetRGBColor Foreground (sRGB 1 1 0)] + +-- | Pure \"Black\" (zero in all RGB channels). +pureBlack :: AnsiColour +pureBlack = + Escapes [SetRGBColor Foreground (sRGB 0 0 0)] + +-- | Shadowed \"Deep Aluminium\" (@#2e3436@ from the Tango color palette). +dullGrey :: AnsiColour +dullGrey = + Escapes [SetRGBColor Foreground (sRGB24read "#2E3436")] + +-- | Medium \"Dark Aluminium\" (from the Tango color palette). +brightGrey :: AnsiColour +brightGrey = + Escapes [SetRGBColor Foreground (sRGB24read "#555753")] + +-- | Pure \"Grey\" (set at @#999999@, being just over half in all RGB channels). +pureGrey :: AnsiColour +pureGrey = + Escapes [SetRGBColor Foreground (sRGB24read "#999999")] + +-- | Pure \"White\" (fully on in all RGB channels). +pureWhite :: AnsiColour +pureWhite = + Escapes [SetRGBColor Foreground (sRGB 1 1 1)] + +-- | Medium \"Light Aluminium\" (@#d3d7cf@ from the Tango color palette). +dullWhite :: AnsiColour +dullWhite = + Escapes [SetRGBColor Foreground (sRGB24read "#D3D7CF")] + +-- | Highlighted \"Light Aluminium\" (@#eeeeec@ from the Tango color palette). +brightWhite :: AnsiColour +brightWhite = + Escapes [SetRGBColor Foreground (sRGB24read "#EEEEEC")] + +-- | +-- Given an 'AnsiColour', lift it to bold intensity. +-- +-- Note that many console fonts do /not/ have a bold face variant, and +-- terminal emulators that "support bold" do so by doubling the thickness of +-- the lines in the glyphs. This may or may not be desirable from a +-- readibility standpoint but really there's only so much you can do to keep +-- users who make poor font choices from making poor font choices. +bold :: AnsiColour -> AnsiColour +bold (Escapes list) = + Escapes (SetConsoleIntensity BoldIntensity : list) + +instance Semigroup AnsiColour where + (<>) (Escapes list1) (Escapes list2) = Escapes (list1 <> list2) + +instance Monoid AnsiColour where + mempty = Escapes [] + 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 + type Token Rope = () + colourize = const mempty + highlight = foldr f emptyDoc . unRope + where + f :: S.ShortText -> Doc () -> Doc () + f piece built = (<>) (pretty (S.toText piece)) built instance Render Char where - type Token Char = () - colourize = const mempty - intoDocA c = pretty c + type Token Char = () + colourize = const mempty + highlight c = pretty c instance (Render a) => Render [a] where - type Token [a] = Token a - colourize = colourize @a - intoDocA = mconcat . fmap intoDocA + type Token [a] = Token a + colourize = colourize @a + highlight = mconcat . fmap highlight instance Render T.Text where - type Token T.Text = () - colourize = const mempty - intoDocA t = pretty t + type Token T.Text = () + colourize = const mempty + highlight t = pretty t -- (), aka Unit, aka **1**, aka something with only one inhabitant instance Render Bytes where - type Token Bytes = () - colourize = const (color Green) - intoDocA = prettyBytes + type Token Bytes = () + colourize = const brightGreen + highlight = prettyBytes prettyBytes :: Bytes -> Doc () -prettyBytes = annotate () . vcat . twoWords - . fmap wordToHex . byteChunk . unBytes +prettyBytes = + annotate () . vcat . twoWords + . fmap wordToHex + . byteChunk + . unBytes twoWords :: [Doc ann] -> [Doc ann] twoWords ds = go ds @@ -136,10 +334,8 @@ go [] = [] go [x] = [softline' <> x] go xs = - let - (one:two:[], remainder) = List.splitAt 2 xs - in - group (one <> spacer <> two) : go remainder + let (one : two : [], remainder) = List.splitAt 2 xs + in group (one <> spacer <> two) : go remainder spacer = flatAlt softline' " " @@ -147,230 +343,243 @@ byteChunk = reverse . go [] where go acc blob = - let - (eight, remainder) = B.splitAt 8 blob - in - if B.length remainder == 0 + 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 + 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 + !low = byteToDigit $ c .&. 0xf + !hi = byteToDigit $ (c .&. 0xf0) `shiftR` 4 byteToDigit :: Word8 -> Char byteToDigit = intToDigit . fromIntegral -{-| -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 -@ +-- | +-- 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. -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 + let options = LayoutOptions (AvailablePerLine (columns - 1) 1.0) + in intoRope . go [] . reAnnotateS (colourize @α) + . layoutPretty options + . highlight + $ thing + where + go :: [AnsiColour] -> SimpleDocStream AnsiColour -> Rope + go as x = case x of + SFail -> error "Unhandled SFail" + SEmpty -> emptyRope + SChar c xs -> + singletonRope c <> go as xs + SText _ t xs -> + intoRope t <> go as xs + SLine len xs -> + singletonRope '\n' + <> intoRope (S.replicate len (S.singleton ' ')) + <> go as xs + SAnnPush a xs -> + intoRope (convert a) <> go (a : as) xs + SAnnPop xs -> + case as of + [] -> error "Popped an empty stack" + -- First discard the current one that's just been popped. Then look + -- at the next one: if it's the last one, we reset the console back + -- to normal mode. But if they're piled up, then return to the + -- previous formatting. + (_ : as') -> case as' of + [] -> reset <> go [] xs + (a : _) -> convert a <> go as' xs -{-| -Having gone to all the trouble to colourize your rendered types... -sometimes you don't want that. This function is like 'render', but removes -all the ANSI escape codes so it comes outformatted but as plain black & -white text. --} + convert :: AnsiColour -> Rope + convert (Escapes codes) = intoRope (setSGRCode codes) + + reset :: Rope + reset = intoRope (setSGRCode [Reset]) + +-- | +-- Having gone to all the trouble to colourize your rendered types... +-- sometimes you don't want that. This function is like 'render', but removes +-- all the ANSI escape codes so it comes outformatted but as plain black & +-- white text. renderNoAnsi :: Render α => Int -> α -> Rope renderNoAnsi columns (thing :: α) = - let - options = LayoutOptions (AvailablePerLine (columns - 1) 1.0) - in - intoRope . renderLazy . unAnnotateS - . layoutPretty options . intoDocA $ thing + let options = LayoutOptions (AvailablePerLine (columns - 1) 1.0) + in intoRope . renderLazy . unAnnotateS + . layoutPretty options + . highlight + $ 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 + let x = unRope text + in case F.viewl x of F.EmptyL -> text piece F.:< _ -> case S.uncons piece of - Nothing -> text - Just (c,_) -> if c `elem` ['A','E','I','O','U','a','e','i','o','u'] - then intoRope ("an " F.<| x) - else intoRope ("a " F.<| x) - -{-| -Often the input text represents a paragraph, but does not have any internal -newlines (representing word wrapping). This function takes a line of text -and inserts newlines to simulate such folding, keeping the line under -the supplied maximum width. - -A single word that is excessively long will be included as-is on its own -line (that line will exceed the desired maxium width). + 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) -Any trailing newlines will be removed. --} +-- | +-- Often the input text represents a paragraph, but does not have any internal +-- newlines (representing word wrapping). This function takes a line of text +-- and inserts newlines to simulate such folding, keeping the line under +-- the supplied maximum width. +-- +-- A single word that is excessively long will be included as-is on its own +-- line (that line will exceed the desired maxium width). +-- +-- Any trailing newlines will be removed. wrap :: Int -> Rope -> Rope wrap margin text = - let - built = wrapHelper margin (breakWords text) - in - built + let built = wrapHelper margin (breakWords text) + in built wrapHelper :: Int -> [Rope] -> Rope wrapHelper _ [] = "" -wrapHelper _ [x] = x -wrapHelper margin (x:xs) = - snd $ List.foldl' (wrapLine margin) (widthRope x, x) xs +wrapHelper _ [x] = x +wrapHelper margin (x : xs) = + snd $ List.foldl' (wrapLine margin) (widthRope x, x) xs wrapLine :: Int -> (Int, Rope) -> Rope -> (Int, Rope) -wrapLine margin (pos,builder) word = - let - wide = widthRope word - wide' = pos + wide + 1 - in - if wide' > margin - then (wide , builder <> "\n" <> word) - else (wide', builder <> " " <> word) - +wrapLine margin (pos, builder) word = + let wide = widthRope word + wide' = pos + wide + 1 + in if wide' > margin + then (wide, builder <> "\n" <> word) + else (wide', builder <> " " <> word) underline :: Char -> Rope -> Rope underline level text = - let - title = fromRope text - line = T.map (\_ -> level) title - in - intoRope line + let title = fromRope text + line = T.map (\_ -> level) title + in intoRope line -{-| -Pad a pieve of text on the left with a specified character to the desired -width. This function is named in homage to the famous result from Computer -Science known as @leftPad@ which has a glorious place in the history of the -world-wide web. --} +-- | +-- Pad a pieve of text on the left with a specified character to the desired +-- width. This function is named in homage to the famous result from Computer +-- Science known as @leftPad@ which has a glorious place in the history of the +-- world-wide web. leftPadWith :: Char -> Int -> Rope -> Rope leftPadWith c digits text = - intoRope pad <> text + intoRope pad <> text where pad = S.replicate len (S.singleton c) len = digits - widthRope text - -{-| -Right pad a text with the specified character. --} +-- | +-- Right pad a text with the specified character. rightPadWith :: Char -> Int -> Rope -> Rope rightPadWith c digits text = - text <> intoRope pad + text <> intoRope pad where pad = S.replicate len (S.singleton c) len = digits - widthRope text - -{-| -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. +-- | +-- 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 +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") @@ -379,8 +588,7 @@ trim = bot . top top [] = [] - top ('\n':cs) = cs + top ('\n' : cs) = cs top str = str bot = List.dropWhileEnd (== ' ') -