diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,32 +1,19 @@ -Opinionated Haskell Interoperability - -Copyright © 2018-2019 Athae Eredh Siniath 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: +Copyright © 2018-2021 Athae Eredh Siniath and Others - 1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the "Software"), +to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: - 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. +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. -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. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. 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.18 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: 32fe0043eab486639c92b9e8ea6c9c864fd2aa6c21f0861529c72898e51bc67a +-- hash: 5360f5729fffd35e21f13c06edbd41bdc1ffc7334f3f456b64bb16738bcc742d name: core-text -version: 0.3.0.0 +version: 0.3.2.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 @@ -29,10 +29,11 @@ bug-reports: https://github.com/aesiniath/unbeliever/issues author: Andrew Cowie maintainer: Andrew Cowie -copyright: © 2018-2020 Athae Eredh Siniath and Others -license: BSD3 +copyright: © 2018-2021 Athae Eredh Siniath and Others +license: MIT license-file: LICENSE -tested-with: GHC == 8.8.4 +tested-with: + GHC == 8.10.6 build-type: Simple extra-doc-files: AnsiColours.png 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 @@ -2,81 +2,84 @@ {-# OPTIONS_HADDOCK hide #-} -- This is an Internal module, hidden from Haddock -module Core.Text.Breaking - ( breakWords, +module Core.Text.Breaking ( + breakWords, breakLines, breakPieces, intoPieces, intoChunks, isNewline, - ) -where +) where import Core.Text.Rope import Data.Char (isSpace) import Data.List (uncons) import qualified Data.Text.Short as S (ShortText, break, empty, null, uncons) --- | --- 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__ --- [] --- @ +{- | +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 @@ -86,13 +89,13 @@ -- now for right fold intoPieces :: (Char -> Bool) -> S.ShortText -> (Maybe S.ShortText, [Rope]) -> (Maybe S.ShortText, [Rope]) intoPieces predicate piece (stream, list) = - let piece' = case stream of - Nothing -> piece - Just previous -> piece <> previous -- more rope, less text? - pieces = intoChunks predicate piece' - in case uncons pieces of - Nothing -> (Nothing, list) - Just (text, remainder) -> (Just (fromRope text), remainder ++ list) + let piece' = case stream of + Nothing -> piece + Just previous -> piece <> previous -- more rope, less text? + pieces = intoChunks predicate piece' + in case uncons pieces of + Nothing -> (Nothing, list) + Just (text, remainder) -> (Just (fromRope text), remainder ++ list) -- -- λ> S.break isSpace "a d" @@ -126,16 +129,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 - then intoRope chunk : emptyRope : [] - else intoRope chunk : intoChunks predicate remainder' + -- 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 @@ -6,136 +6,165 @@ {-# 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. -module Core.Text.Bytes - ( 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, + emptyBytes, + packBytes, Binary (fromBytes, intoBytes), hOutput, hInput, -- * Internals unBytes, - ) -where +) where -import qualified Data.ByteString as B - ( ByteString, +import qualified Data.ByteString as B ( + ByteString, + empty, hGetContents, hPut, pack, unpack, - ) + ) import qualified Data.ByteString.Builder as B (Builder, byteString, toLazyByteString) +import qualified Data.ByteString.Char8 as C ( + pack + ) import qualified Data.ByteString.Lazy as L (ByteString, fromStrict, toStrict) import Data.Hashable (Hashable) import Data.Word (Word8) import GHC.Generics (Generic) 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 + 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) --- @ --- --- on the assumption that the bytes in question are UTF-8 (or plain ASCII) --- encoded. +{- | +A zero-length 'Bytes'. +-} +emptyBytes :: Bytes +emptyBytes = StrictBytes B.empty + +{- | +For the annoyingly common case of needing to take an ASCII string literal in +your code and use it as a bunch of 'Bytes'. + +Done via "Data.ByteString.Char8" so all @Char@s will be truncated to 8 bits +(/i.e./ Latin-1 characters less than 255). You should probably consider this +to be unsafe. Also note that we deliberately do not have a @[Char]@ instance +of 'Binary'; if you need to come back to a textual representation use +'intoRope'. +-} +packBytes :: String -> Bytes +packBytes = StrictBytes . C.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) +@ + +on the assumption that the bytes in question are UTF-8 (or plain ASCII) +encoded. +-} hOutput :: Handle -> Bytes -> IO () hOutput handle (StrictBytes b') = B.hPut handle b' --- | --- Read the (entire) contents of a handle into a Bytes object. --- --- If you want to read the entire contents of a file, you can do: --- --- @ --- contents <- 'Core.System.Base.withFile' name 'Core.System.Base.ReadMode' 'hInput' --- @ --- --- At any kind of scale, Streaming I/O is almost always for better, but for --- small files you need to pick apart this is fine. -hInput :: Handle -> IO Bytes -hInput handle = do - contents <- B.hGetContents handle - return (StrictBytes contents) +{- | +Read the (entire) contents of a handle into a Bytes object. -{- -instance Show Bytes where - show x = case x of - StrictBytes b' -> +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) 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 @@ -12,12 +12,12 @@ import Data.Foldable (foldl') import qualified Data.Text.Short as S (ShortText, foldl') --- | --- 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) 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 @@ -8,70 +8,70 @@ {-# 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. --- --- 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 +{- | +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, @@ -79,6 +79,7 @@ replicateChar, widthRope, splitRope, + takeRope, insertRope, containsCharacter, findIndexRope, @@ -92,23 +93,22 @@ nullRope, unsafeIntoRope, Width (..), - ) -where +) where import Control.DeepSeq (NFData (..)) import Core.Text.Bytes import qualified Data.ByteString as B (ByteString) -import qualified Data.ByteString.Builder as B - ( hPutBuilder, +import qualified Data.ByteString.Builder as B ( + hPutBuilder, toLazyByteString, - ) -import qualified Data.ByteString.Lazy as L - ( ByteString, + ) +import qualified Data.ByteString.Lazy as L ( + ByteString, foldrChunks, toStrict, - ) -import qualified Data.FingerTree as F - ( FingerTree, + ) +import qualified Data.FingerTree as F ( + FingerTree, Measured (..), SearchResult (..), ViewL (..), @@ -120,25 +120,25 @@ (<|), (><), (|>), - ) + ) import Data.Foldable (foldl', foldr', toList) import Data.Hashable (Hashable, hashWithSalt) import Data.String (IsString (..)) import qualified Data.Text as T (Text) -import qualified Data.Text.Lazy as U - ( Text, +import qualified Data.Text.Lazy as U ( + Text, foldrChunks, fromChunks, toStrict, - ) -import qualified Data.Text.Lazy.Builder as U - ( Builder, + ) +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, +import qualified Data.Text.Short as S ( + ShortText, any, append, empty, @@ -154,156 +154,162 @@ toBuilder, toText, unpack, - ) + ) import qualified Data.Text.Short.Unsafe as S (fromByteStringUnsafe) import GHC.Generics (Generic) import System.IO (Handle) --- | --- A type for textual data. A rope is text backed by a tree data structure, --- rather than a single large continguous array, as is the case for strings. --- --- There are three use cases: --- --- /Referencing externally sourced data/ --- --- Often we interpret large blocks of data sourced from external systems as --- text. Ideally we would hold onto this without copying the memory, but (as --- in the case of @ByteString@ which is the most common source of data) before --- we can treat it as text we have to validate the UTF-8 content. Safety --- first. We also copy it out of pinned memory, allowing the Haskell runtime --- to manage the storage. --- --- /Interoperating with other libraries/ --- --- The only constant of the Haskell universe is that you won't have the right --- combination of {strict, lazy} × {@Text@, @ByteString@, @String@, @[Word8]@, --- etc} you need for the next function call. The 'Textual' typeclass provides --- for moving between different text representations. To convert between --- @Rope@ and something else use 'fromRope'; to construct a @Rope@ from --- textual content in another type use 'intoRope'. --- --- You can get at the underlying finger tree with the 'unRope' function. --- --- /Assembling text to go out/ --- --- This involves considerable appending of data, very very occaisionally --- inserting it. Often the pieces are tiny. To add text to a @Rope@ use the --- 'appendRope' method as below or the ('Data.Semigroup.<>') operator from --- "Data.Monoid" (like you would have with a @Builder@). --- --- Output to a @Handle@ can be done efficiently with 'hWrite'. +{- | +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 + 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 --- @ +{- | +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. +{- | +A 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 {-# 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' + 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/ --- --- 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 @@ -311,60 +317,75 @@ nullRope :: Rope -> Bool nullRope (Rope x) = case F.viewl x of - F.EmptyL -> True - (F.:<) piece _ -> S.null piece + F.EmptyL -> True + (F.:<) piece _ -> S.null piece --- | --- Break the text into two pieces at the specified offset. --- --- Examples: --- --- @ --- λ> __splitRope 0 \"abcdef\"__ --- (\"\", \"abcdef\") --- λ> __splitRope 3 \"abcdef\"__ --- (\"abc\", \"def\") --- λ> __splitRope 6 \"abcdef\"__ --- (\"abcdef\",\"\") --- @ --- --- Going off either end behaves sensibly: --- --- @ --- λ> __splitRope 7 \"abcdef\"__ --- (\"abcdef\",\"\") --- λ> __splitRope (-1) \"abcdef\"__ --- (\"\", \"abcdef\") --- @ +{- | +Break the text into two pieces at the specified offset. + +Examples: + +@ +λ> __splitRope 0 \"abcdef\"__ +(\"\", \"abcdef\") +λ> __splitRope 3 \"abcdef\"__ +(\"abc\", \"def\") +λ> __splitRope 6 \"abcdef\"__ +(\"abcdef\",\"\") +@ + +Going off either end behaves sensibly: + +@ +λ> __splitRope 7 \"abcdef\"__ +(\"abcdef\",\"\") +λ> __splitRope (-1) \"abcdef\"__ +(\"\", \"abcdef\") +@ +-} splitRope :: Int -> Rope -> (Rope, Rope) splitRope i text@(Rope x) = - let pos = Width i - result = F.search (\w1 _ -> w1 >= pos) x - in case result of - F.Position before piece after -> - let (Width w) = F.measure before - (one, two) = S.splitAt (i - w) piece - in (Rope ((F.|>) before one), Rope ((F.<|) two after)) - F.OnLeft -> (Rope F.empty, text) - F.OnRight -> (text, Rope F.empty) - F.Nowhere -> error "Position not found in split. Probable cause: predicate function given not monotonic. This is supposed to be unreachable" + let pos = Width i + result = F.search (\w1 _ -> w1 >= pos) x + in case result of + F.Position before piece after -> + let (Width w) = F.measure before + (one, two) = S.splitAt (i - w) piece + in (Rope ((F.|>) before one), Rope ((F.<|) two after)) + F.OnLeft -> (Rope F.empty, text) + F.OnRight -> (text, Rope F.empty) + F.Nowhere -> error "Position not found in split. Probable cause: predicate function given not monotonic. This is supposed to be unreachable" --- | --- Insert a new piece of text into an existing @Rope@ at the specified offset. --- --- Examples: --- --- @ --- λ> __insertRope 3 \"Con\" \"Def 1\"__ --- "DefCon 1" --- λ> __insertRope 0 \"United \" \"Nations\"__ --- "United Nations" --- @ +{- | +Take the first _n_ characters from the beginning of the Rope. + +@ +λ> __takeRope 3 \"123456789\"__ +\"123\" +@ +-} +takeRope :: Int -> Rope -> Rope +takeRope i text = + let (before, _) = splitRope i text + in before + +{- | +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 @@ -372,10 +393,10 @@ -- convert this to Maybe monad, maybe 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 @@ -390,174 +411,172 @@ -- 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 + 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/ --- --- 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. +{- | +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 -> α + -- | Convert a @Rope@ into another text-like type. + fromRope :: Rope -> α - -- | - -- Take another text-like type and convert it to a @Rope@. - intoRope :: α -> 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" 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 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" 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 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" 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" 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 + 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 --- --- 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 @@ -8,13 +8,14 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK prune #-} --- | --- 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 +{- | +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, @@ -65,8 +66,7 @@ intoChunks, byteChunk, intoDocA, - ) -where +) where import Core.Text.Breaking import Core.Text.Bytes @@ -79,8 +79,8 @@ import qualified Data.FingerTree as F (ViewL (..), viewl, (<|)) import qualified Data.List as List (dropWhileEnd, foldl', splitAt) import qualified Data.Text as T -import Data.Text.Prettyprint.Doc - ( Doc, +import Data.Text.Prettyprint.Doc ( + Doc, LayoutOptions (LayoutOptions), PageWidth (AvailablePerLine), Pretty (..), @@ -96,237 +96,240 @@ softline', unAnnotateS, vcat, - ) + ) import Data.Text.Prettyprint.Doc.Render.Text (renderLazy) -import qualified Data.Text.Short as S - ( ShortText, +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 System.Console.ANSI.Codes (setSGRCode) import System.Console.ANSI.Types (ConsoleIntensity (..), ConsoleLayer (..), SGR (..)) --- | --- An accumulation of ANSI escape codes used to add colour when pretty --- printing to console. +{- | +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. --- --- Use 'render' to build text object for later use or --- 's --- --- if you're writing directly to console now. +{- | +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 α :: * + -- | 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 α -> AnsiColour + -- | Convert semantic tokens to specific ANSI escape tokens + colourize :: Token α -> AnsiColour - -- | - -- Arrange your type as a 'Doc' @ann@, annotated with your semantic - -- tokens. - highlight :: α -> 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")] + Escapes [SetRGBColor Foreground (sRGB24read "#CC0000")] -- | Highlighted \"Scarlet Red\" (@#ef2929@ from the Tango color palette). brightRed :: AnsiColour brightRed = - Escapes [SetRGBColor Foreground (sRGB24read "#EF2929")] + Escapes [SetRGBColor Foreground (sRGB24read "#EF2929")] -- | Pure \"Red\" (full RGB red channel only). pureRed :: AnsiColour pureRed = - Escapes [SetRGBColor Foreground (sRGB 1 0 0)] + Escapes [SetRGBColor Foreground (sRGB 1 0 0)] -- | Shadowed \"Chameleon\" (@#4e9a06@ from the Tango color palette). dullGreen :: AnsiColour dullGreen = - Escapes [SetRGBColor Foreground (sRGB24read "#4E9A06")] + Escapes [SetRGBColor Foreground (sRGB24read "#4E9A06")] -- | Highlighted \"Chameleon\" (@#8ae234@ from the Tango color palette). brightGreen :: AnsiColour brightGreen = - Escapes [SetRGBColor Foreground (sRGB24read "#8AE234")] + Escapes [SetRGBColor Foreground (sRGB24read "#8AE234")] -- | Pure \"Green\" (full RGB green channel only). pureGreen :: AnsiColour pureGreen = - Escapes [SetRGBColor Foreground (sRGB 0 1 0)] + Escapes [SetRGBColor Foreground (sRGB 0 1 0)] -- | Medium \"Sky Blue\" (@#3465a4@ from the Tango color palette). dullBlue :: AnsiColour dullBlue = - Escapes [SetRGBColor Foreground (sRGB24read "#3465A4")] + Escapes [SetRGBColor Foreground (sRGB24read "#3465A4")] -- | Highlighted \"Sky Blue\" (@#729fcf@ from the Tango color palette). brightBlue :: AnsiColour brightBlue = - Escapes [SetRGBColor Foreground (sRGB24read "#729FCF")] + Escapes [SetRGBColor Foreground (sRGB24read "#729FCF")] -- | Pure \"Blue\" (full RGB blue channel only). pureBlue :: AnsiColour pureBlue = - Escapes [SetRGBColor Foreground (sRGB 0 0 1)] + Escapes [SetRGBColor Foreground (sRGB 0 0 1)] -- | Dull \"Cyan\" (from the __gnome-terminal__ console theme). dullCyan :: AnsiColour dullCyan = - Escapes [SetRGBColor Foreground (sRGB24read "#06989A")] + Escapes [SetRGBColor Foreground (sRGB24read "#06989A")] -- | Bright \"Cyan\" (from the __gnome-terminal__ console theme). brightCyan :: AnsiColour brightCyan = - Escapes [SetRGBColor Foreground (sRGB24read "#34E2E2")] + Escapes [SetRGBColor Foreground (sRGB24read "#34E2E2")] -- | Pure \"Cyan\" (full RGB blue + green channels). pureCyan :: AnsiColour pureCyan = - Escapes [SetRGBColor Foreground (sRGB 0 1 1)] + Escapes [SetRGBColor Foreground (sRGB 0 1 1)] -- | Medium \"Plum\" (@#75507b@ from the Tango color palette). dullMagenta :: AnsiColour dullMagenta = - Escapes [SetRGBColor Foreground (sRGB24read "#75507B")] + Escapes [SetRGBColor Foreground (sRGB24read "#75507B")] -- | Highlighted \"Plum\" (@#ad7fa8@ from the Tango color palette). brightMagenta :: AnsiColour brightMagenta = - Escapes [SetRGBColor Foreground (sRGB24read "#AD7FA8")] + Escapes [SetRGBColor Foreground (sRGB24read "#AD7FA8")] -- | Pure \"Magenta\" (full RGB red + blue channels). pureMagenta :: AnsiColour pureMagenta = - Escapes [SetRGBColor Foreground (sRGB 1 0 1)] + Escapes [SetRGBColor Foreground (sRGB 1 0 1)] -- | Shadowed \"Butter\" (@#c4a000@ from the Tango color palette). dullYellow :: AnsiColour dullYellow = - Escapes [SetRGBColor Foreground (sRGB24read "#C4A000")] + Escapes [SetRGBColor Foreground (sRGB24read "#C4A000")] -- | Highlighted \"Butter\" (@#fce94f@ from the Tango color palette). brightYellow :: AnsiColour brightYellow = - Escapes [SetRGBColor Foreground (sRGB24read "#FCE94F")] + Escapes [SetRGBColor Foreground (sRGB24read "#FCE94F")] -- | Pure \"Yellow\" (full RGB red + green channels). pureYellow :: AnsiColour pureYellow = - Escapes [SetRGBColor Foreground (sRGB 1 1 0)] + Escapes [SetRGBColor Foreground (sRGB 1 1 0)] -- | Pure \"Black\" (zero in all RGB channels). pureBlack :: AnsiColour pureBlack = - Escapes [SetRGBColor Foreground (sRGB 0 0 0)] + Escapes [SetRGBColor Foreground (sRGB 0 0 0)] -- | Shadowed \"Deep Aluminium\" (@#2e3436@ from the Tango color palette). dullGrey :: AnsiColour dullGrey = - Escapes [SetRGBColor Foreground (sRGB24read "#2E3436")] + Escapes [SetRGBColor Foreground (sRGB24read "#2E3436")] -- | Medium \"Dark Aluminium\" (from the Tango color palette). brightGrey :: AnsiColour brightGrey = - Escapes [SetRGBColor Foreground (sRGB24read "#555753")] + 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")] + Escapes [SetRGBColor Foreground (sRGB24read "#999999")] -- | Pure \"White\" (fully on in all RGB channels). pureWhite :: AnsiColour pureWhite = - Escapes [SetRGBColor Foreground (sRGB 1 1 1)] + Escapes [SetRGBColor Foreground (sRGB 1 1 1)] -- | Medium \"Light Aluminium\" (@#d3d7cf@ from the Tango color palette). dullWhite :: AnsiColour dullWhite = - Escapes [SetRGBColor Foreground (sRGB24read "#D3D7CF")] + Escapes [SetRGBColor Foreground (sRGB24read "#D3D7CF")] -- | Highlighted \"Light Aluminium\" (@#eeeeec@ from the Tango color palette). brightWhite :: AnsiColour brightWhite = - Escapes [SetRGBColor Foreground (sRGB24read "#EEEEEC")] + 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. +{- | +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) + Escapes (SetConsoleIntensity BoldIntensity : list) instance Semigroup AnsiColour where - (<>) (Escapes list1) (Escapes list2) = Escapes (list1 <> list2) + (<>) (Escapes list1) (Escapes list2) = Escapes (list1 <> list2) instance Monoid AnsiColour where - mempty = Escapes [] + mempty = Escapes [] instance Render Rope where - 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 + 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 - highlight 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 - highlight = mconcat . fmap highlight + type Token [a] = Token a + colourize = colourize @a + highlight = mconcat . fmap highlight +instance Render String where + type Token String = Token Char + colourize = colourize @Char + highlight = mconcat . fmap highlight + instance Render T.Text where - type Token T.Text = () - colourize = const mempty - highlight 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 brightGreen - highlight = prettyBytes + type Token Bytes = () + colourize = const brightGreen + highlight = prettyBytes prettyBytes :: Bytes -> Doc () prettyBytes = - annotate () . vcat . twoWords - . fmap wordToHex - . byteChunk - . unBytes + annotate () . vcat . twoWords + . fmap wordToHex + . byteChunk + . unBytes twoWords :: [Doc ann] -> [Doc ann] twoWords ds = go ds @@ -334,8 +337,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' " " @@ -343,17 +346,17 @@ byteChunk = 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 + 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 @@ -364,63 +367,64 @@ 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 --- @ --- --- which is able to pretty print the document text respecting the available --- width of the terminal. +{- | +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 . go [] . reAnnotateS (colourize @α) - . layoutPretty options - . highlight - $ thing + let options = LayoutOptions (AvailablePerLine (columns - 1) 1.0) + in 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 + 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' + <> replicateChar len ' ' + <> 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 convert :: AnsiColour -> Rope convert (Escapes codes) = intoRope (setSGRCode codes) @@ -428,161 +432,167 @@ 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. +{- | +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 - . highlight - $ 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. +{- | +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) + let x = unRope text + in case F.viewl x of + F.EmptyL -> text + piece F.:< _ -> case S.uncons piece of + Nothing -> text + Just (c, _) -> + if c `elem` ['A', 'E', 'I', 'O', 'U', 'a', 'e', 'i', 'o', 'u'] + then intoRope ("an " F.<| x) + else intoRope ("a " F.<| x) --- | --- Often the input text represents a paragraph, but does not have any internal --- newlines (representing word wrapping). This function takes a line of text --- and inserts newlines to simulate such folding, keeping the line under --- the supplied maximum width. --- --- A single word that is excessively long will be included as-is on its own --- line (that line will exceed the desired maxium width). --- --- Any trailing newlines will be removed. +{- | +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 + 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) + 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 - (error "Cannot use [quote| ... |] in a pattern") - (error "Cannot use [quote| ... |] as a type") - (error "Cannot use [quote| ... |] for a declaration") + 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