core-text (empty) → 0.2.0.0

raw patch · 7 files changed

+1279/−0 lines, 7 filesdep +basedep +bytestringdep +deepseq

Dependencies added: base, bytestring, deepseq, fingertree, hashable, prettyprinter, prettyprinter-ansi-terminal, template-haskell, text, text-short

Files

• LICENCE +32/−0
• core-text.cabal +54/−0
• lib/Core/Text.hs +36/−0
• lib/Core/Text/Breaking.hs +147/−0
• lib/Core/Text/Bytes.hs +150/−0
• lib/Core/Text/Rope.hs +493/−0
• lib/Core/Text/Utilities.hs +367/−0

@@ -0,0 +1,32 @@+Opinionated Haskell Interoperability++Copyright © 2018-2019 Operational Dynamics Consulting, Pty Ltd and Others+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++    1. Redistributions of source code must retain the above copyright+       notice, this list of conditions and the following disclaimer.++    2. Redistributions in binary form must reproduce the above+       copyright notice, this list of conditions and the following+       disclaimer in the documentation and/or other materials provided+       with the distribution.+      +    3. Neither the name of the project nor the names of its contributors+       may be used to endorse or promote products derived from this +       software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,54 @@+cabal-version: 1.12+name: core-text+version: 0.2.0.0+license: BSD3+license-file: LICENCE+copyright: © 2018-2019 Operational Dynamics Consulting Pty Ltd, and Others+maintainer: Andrew Cowie <andrew@operationaldynamics.com>+author: Andrew Cowie <andrew@operationaldynamics.com>+stability: experimental+tested-with: ghc ==8.6.5+homepage: https://github.com/oprdyn/unbeliever#readme+bug-reports: https://github.com/oprdyn/unbeliever/issues+synopsis: A text type based on a finger tree over UTF-8 fragments+description:+    A data type for text, built as a finger tree over UTF-8 text fragments.+    .+    The main type and its usage are described at "Core.Text.Rope" in this+    package.+    .+    This is part of a library intended to ease interoperability and assist in+    building command-line programs, both tools and longer-running daemons.+    A list of features and some background to the library's design is contained+    in the+    <https://github.com/oprdyn/unbeliever/blob/master/README.markdown README>+    on GitHub.+category: System+build-type: Simple++source-repository head+    type: git+    location: https://github.com/oprdyn/unbeliever++library+    exposed-modules:+        Core.Text+        Core.Text.Bytes+        Core.Text.Rope+        Core.Text.Utilities+    hs-source-dirs: lib+    other-modules:+        Core.Text.Breaking+    default-language: Haskell2010+    ghc-options: -Wall -Wwarn -fwarn-tabs+    build-depends:+        base >=4.11 && <5,+        bytestring >=0.10.8.2 && <0.11,+        deepseq >=1.4.4.0 && <1.5,+        fingertree >=0.1.4.2 && <0.2,+        hashable >=1.2.7.0 && <1.3,+        prettyprinter >=1.2.1 && <1.3,+        prettyprinter-ansi-terminal >=1.1.1.2 && <1.2,+        template-haskell >=2.14.0.0 && <2.15,+        text >=1.2.3.1 && <1.3,+        text-short >=0.1.2 && <0.2

@@ -0,0 +1,36 @@+{-# OPTIONS_HADDOCK not-home #-}++{-|+A unified Text type providing interoperability between various text+back-ends present in the Haskell ecosystem.++This is intended to be used directly:++@+import "Core.Text"+@++as this module re-exports all of the various components making up this+library's text handling subsystem.+-}+module Core.Text+    (+        {-* Internal representation -}+{-|+Exposes 'Bytes', a wrapper around different types of binary data, and 'Rope',+a finger-tree over buffers containing text.+-}+        module Core.Text.Bytes+      , module Core.Text.Rope++        {-* Useful utilities -}+{-|+Useful functions for common use cases.+-}+      , module Core.Text.Utilities+    ) where++import Core.Text.Bytes+import Core.Text.Rope+import Core.Text.Utilities+

@@ -0,0 +1,147 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_HADDOCK hide #-}++-- This is an Internal module, hidden from Haddock+module Core.Text.Breaking+    ( breakWords+    , breakLines+    , breakPieces+    , intoPieces+    , intoChunks+    )+where++import Data.Char (isSpace)+import Data.Foldable (foldr)+import Data.List (uncons)+import qualified Data.Text.Short as S (ShortText, null, break, uncons,empty)++import Core.Text.Rope++{-|+Split a passage of text into a list of words. A line is broken wherever+there is one or more whitespace characters, as defined by "Data.Char"'s+'Data.Char.isSpace'.++Examples:++@+λ> __breakWords \"This is a test\"__+[\"This\",\"is\",\"a\",\"test\"]+λ> __breakWords (\"St\" <> \"op and \" <> \"go left\")__+[\"Stop\",\"and\",\"go\",\"left\"]+λ> __breakWords emptyRope__+[]+@+-}+breakWords :: Rope -> [Rope]+breakWords = filter (not . nullRope) . breakPieces isSpace++{-|+Split a paragraph of text into a list of its individual lines. The+paragraph will be broken wherever there is a @'\n'@ character.++Blank lines will be preserved. Note that as a special case you do /not/ get+a blank entry at the end of the a list of newline terminated strings.++@+λ> __breakLines \"Hello\\n\\nWorld\\n\"__+[\"Hello\",\"\",\"World\"]+@+-}+breakLines :: Rope -> [Rope]+breakLines text =+  let+    result = breakPieces isNewline text+    n = length result - 1+    (fore,aft) = splitAt n result+  in case result of+    [] -> []+    [p] -> [p]+    _ -> if aft == [""]+        then fore+        else result++isNewline :: Char -> Bool+isNewline c = c == '\n'++{-|+Break a Rope into pieces whereever the given predicate function returns+@True@. If found, that character will not be included on either side. Empty+runs, however, *will* be preserved.+-}+breakPieces :: (Char -> Bool) -> Rope -> [Rope]+breakPieces predicate text =+  let+    x = unRope text+    (final,result) = foldr (intoPieces predicate) (Nothing,[]) x+  in+    case final of+       Nothing -> result+       Just piece -> intoRope piece : result++{-+Was the previous piece a match, or are we in the middle of a run of+characters? If we were, then join the previous run to the current piece+before processing into chunks.+-}+-- now for right fold+intoPieces :: (Char -> Bool) -> S.ShortText -> (Maybe S.ShortText,[Rope]) -> (Maybe S.ShortText,[Rope])+intoPieces predicate piece (stream,list) =+  let+    piece' = case stream of+        Nothing -> piece+        Just previous -> piece <> previous       -- more rope, less text?++    pieces = intoChunks predicate piece'+  in+    case uncons pieces of+        Nothing -> (Nothing,list)+        Just (text,remainder) -> (Just (fromRope text),remainder ++ list)++--+-- λ> S.break isSpace "a d"+-- ("a"," d")+--+-- λ> S.break isSpace " and"+-- (""," and")+--+-- λ> S.break isSpace "and "+-- ("and"," ")+--+-- λ> S.break isSpace ""+-- ("","")+--+-- λ> S.break isSpace " "+-- (""," ")+--++{-+This was more easily expressed as ++  let+    remainder' = S.drop 1 remainder+  in+    if remainder == " "++for the case when we were breaking on spaces. But generalized to a predicate+we have to strip off the leading character and test that its the only character;+this is cheaper than S.length etc.+-}+intoChunks :: (Char -> Bool) -> S.ShortText -> [Rope]+intoChunks _ piece | S.null piece = []+intoChunks predicate piece =+  let+    (chunk,remainder) = S.break predicate piece++    -- Handle the special case that a trailing " " (generalized to predicate)+    -- is the only character left.+    (trailing,remainder') = case S.uncons remainder of+        Nothing -> (False,S.empty)+        Just (c,remaining) -> if S.null remaining+            then (predicate c,S.empty)+            else (False,remaining)+  in+    if trailing+        then intoRope chunk : emptyRope : []+        else intoRope chunk : intoChunks predicate remainder'

@@ -0,0 +1,150 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}        -- FIXME+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}   -- FIXME+{-# OPTIONS_HADDOCK prune #-}++{-|+Binary (as opposed to textual) data is encountered in weird corners of the+Haskell ecosystem. We tend to forget (for example) that the content+recieved from a web server is /not/ text until we convert it from UTF-8 (if+that's what it is); and of course that glosses over the fact that something+of content-type @image/jpeg@ is not text in any way, shape, or form.++Bytes also show up when working with crypto algorithms, taking hashes, and+when doing serialization to external binary formats. Although we frequently+display these in terminals (and in URLs!) as text, but we take for granted+that we have actually deserialized the data or rendered the it in+hexidecimal or base64 or...++This module presents a simple wrapper around various representations of+binary data to make it easier to interoperate with libraries supplying+or consuming bytes.+-}+module Core.Text.Bytes+    ( Bytes+    , Binary(fromBytes, intoBytes)+    , hOutput+    , hInput+      {-* Internals -}+    , unBytes+    ) where++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)+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.+-}+data Bytes+    = StrictBytes B.ByteString+    deriving (Show, Eq, Ord, Generic)++{-|+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.+-}+class Binary α where+    fromBytes :: Bytes -> α+    intoBytes :: α -> Bytes++instance Binary Bytes where+    fromBytes = id+    intoBytes = id++{-| from "Data.ByteString" Strict -}+instance Binary B.ByteString where+    fromBytes (StrictBytes b') = b'+    intoBytes b' = StrictBytes b'++{-| from "Data.ByteString.Lazy" -}+instance Binary L.ByteString where+    fromBytes (StrictBytes b') = L.fromStrict b'+    intoBytes b' = StrictBytes (L.toStrict b')      -- expensive++instance Binary B.Builder where+    fromBytes (StrictBytes b') = B.byteString b'+    intoBytes b' = StrictBytes (L.toStrict (B.toLazyByteString b'))++{-| 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)+@++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)++{-+instance Show Bytes where+    show x = case x of+        StrictBytes b' -> +-}

@@ -0,0 +1,493 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-|+If you're accustomed to working with text in almost any other programming+language, you'd be aware that a \"string\" typically refers to an in-memory+/array/ of characters. Traditionally this was a single ASCII byte per+character; more recently UTF-8 variable byte encodings which dramatically+complicates finding offsets but which gives efficient support for the+entire Unicode character space. In Haskell, the original text type,+'String', is implemented as a list of 'Char' which, because a Haskell list+is implemented as a /linked-list of boxed values/, is wildly inefficient at+any kind of scale.++In modern Haskell there are two primary ways to represent text.++First is via the [rather poorly named] @ByteString@ from the __bytestring__+package (which is an array of bytes in pinned memory). The+"Data.ByteString.Char8" submodule gives you ways to manipulate those arrays+as if they were ASCII characters. Confusingly there are both strict+(@Data.ByteString@) and lazy (@Data.ByteString.Lazy@) variants which are+often hard to tell the difference between when reading function signatures+or haddock documentation. The performance problem an immutable array backed+data type runs into is that appending a character (that is, ASCII byte) or+concatonating a string (that is, another array of ASCII bytes) is very+expensive and requires allocating a new larger array and copying the whole+thing into it. This led to the development of \"builders\" which amortize+this reallocation cost over time, but it can be cumbersome to switch+between @Builder@, the lazy @ByteString@ that results, and then having to+inevitably convert to a strict @ByteString@ because that's what the next+function in your sequence requires.++The second way is through the opaque @Text@ type of "Data.Text" from the+__text__ package, which is well tuned and high-performing but suffers from+the same design; it is likewise backed by arrays. Rather surprisingly, the+storage backing Text objects are encoded in UTF-16, meaning every time you+want to work with unicode characters that came in from /anywhere/ else and+which inevitably are UTF-8 encoded you have to convert to UTF-16 and copy+into a new array, wasting time and memory.++In this package we introduce 'Rope', a text type backed by the 2-3+'Data.FingerTree.FingerTree' data structure from the __fingertree__+package. This is not an uncommon solution in many languages as finger trees+support exceptionally efficient appending to either end and good+performance inserting anywhere else (you often find them as the backing+data type underneath text editors for this reason). Rather than 'Char' the+pieces of the rope are 'Data.Text.Short.ShortText' from the __text-short__+package, which are UTF-8 encoded and in normal memory managed by the+Haskell runtime. Conversion from other Haskell text types is not /O(1)/+(UTF-8 validity must be checked, or UTF-16 decoded, or...), but in our+benchmarking the performance has been comparable to the established types+and you may find the resultant interface for combining chunks is comparable+to using a Builder, without being forced to use a Builder.++'Rope' is used as the text type throughout this library. If you use the+functions within this package (rather than converting to other text types)+operations are quite efficient. When you do need to convert to another type+you can use 'fromRope' or 'intoRope' from the 'Textual' typeclass.++Note that we haven't tried to cover the entire gamut of operations or+customary convenience functions you would find in the other libraries; so+far 'Rope' is concentrated on aiding interoperation, being good at+appending (lots of) small pieces, and then efficiently taking the resultant+text object out to a file handle, be that the terminal console, a file, or+a network socket.++-}+module Core.Text.Rope+    ( {-* Rope type -}+      Rope+    , emptyRope+    , widthRope+    , splitRope+    , insertRope+    , containsCharacter+      {-* Interoperation and Output -}+    , Textual(fromRope, intoRope, appendRope)+    , hWrite+      {-* Internals -}+    , unRope+    , nullRope+    , unsafeIntoRope+    , Width(..)+    ) where++import Control.DeepSeq (NFData(..))+import qualified Data.ByteString as B (ByteString)+import qualified Data.ByteString.Builder as B (toLazyByteString+    , hPutBuilder)+import qualified Data.ByteString.Lazy as L (ByteString, toStrict+    , foldrChunks)+import qualified Data.FingerTree as F (FingerTree, Measured(..), empty+    , singleton, (><), (<|), (|>), search, SearchResult(..), null+    , viewl, ViewL(..))+import Data.Foldable (foldr, foldr', foldMap, toList, any)+import Data.Hashable (Hashable, hashWithSalt)+import Data.String (IsString(..))+import qualified Data.Text as T (Text)+import qualified Data.Text.Lazy as U (Text, fromChunks, foldrChunks+    , toStrict)+import qualified Data.Text.Lazy.Builder as U (Builder, toLazyText+    , fromText)+import Data.Text.Prettyprint.Doc (Pretty(..), emptyDoc)+import qualified Data.Text.Short as S (ShortText, length, any, null+    , fromText, toText, fromByteString, pack, unpack+    , append, empty, toBuilder, splitAt)+import qualified Data.Text.Short.Unsafe as S (fromByteStringUnsafe)+import GHC.Generics (Generic)+import System.IO (Handle)++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'.+-}+data Rope+    = Rope (F.FingerTree Width S.ShortText)+    deriving Generic++instance NFData Rope where+    rnf (Rope x) = foldMap (\piece -> rnf piece) x++instance Show Rope where+    show text = "\"" ++ fromRope text ++ "\""++instance Eq Rope where+    (==) (Rope x1) (Rope x2) = (==) (stream x1) (stream x2)+      where+        stream x = foldMap S.unpack x++instance Ord Rope where+    compare (Rope x1) (Rope x2) = compare x1 x2++instance Pretty Rope where+    pretty (Rope x) = foldr ((<>) . pretty . S.toText) emptyDoc x ++{-|+Access the finger tree underlying the @Rope@. You'll want the following+imports:++@+import qualified "Data.FingerTree" as F  -- from the __fingertree__ package+import qualified "Data.Text.Short" as S  -- from the __text-short__ package+@+-}+unRope :: Rope -> F.FingerTree Width S.ShortText+unRope (Rope x) = x+{-# INLINE unRope #-}+++{-|+The length of the @Rope@, in characters. This is the monoid used to+structure the finger tree underlying the @Rope@.+-}+newtype Width = Width Int+    deriving (Eq, Ord, Show, Num, Generic)++instance F.Measured Width S.ShortText where+    measure :: S.ShortText -> Width+    measure piece = Width (S.length piece)++instance Semigroup Width where+    (<>) (Width w1) (Width w2) = Width (w1 + w2)++instance Monoid Width where+    mempty = Width 0+    mappend = (<>)++-- here Maybe we just need type Strand = ShortText and then Rope is+-- FingerTree Strand or Builder (Strand)++instance IsString Rope where+    fromString "" = emptyRope+    fromString xs = Rope . F.singleton . S.pack $ xs++instance Semigroup Rope where+    (<>) text1@(Rope x1) text2@(Rope x2) =+        if F.null x2+            then text1+            else if F.null x1+                then text2+                else Rope ((F.><) x1 x2) -- god I hate these operators++instance Monoid Rope where+    mempty = emptyRope+    mappend = (<>)++{-|+An zero-length 'Rope'. You can also use @\"\"@ presuming the+__@OverloadedStrings@__ language extension is turned on in your source+file.+-}+emptyRope :: Rope+emptyRope = Rope F.empty+{-# INLINABLE emptyRope #-}++{-|+Get the length of this text, in characters.+-}+widthRope :: Rope -> Int+widthRope = foldr' f 0 . unRope+  where+    f piece count = S.length piece + count++nullRope :: Rope -> Bool+nullRope (Rope x) = case F.viewl x of+    F.EmptyL        -> True+    (F.:<) piece _  -> S.null piece++{-|+Break the text into two pieces at the specified offset.++Examples:++@+λ> __splitRope 0 \"abcdef\"__+(\"\", \"abcdef\")+λ> __splitRope 3 \"abcdef\"__+(\"abc\", \"def\")+λ> __splitRope 6 \"abcdef\"__+(\"abcdef\",\"\")+@++Going off either end behaves sensibly:++@+λ> __splitRope 7 \"abcdef\"__+(\"abcdef\",\"\")+λ> __splitRope (-1) \"abcdef\"__+(\"\", \"abcdef\")+@+-}+splitRope :: Int -> Rope -> (Rope,Rope)+splitRope i text@(Rope x) =+  let+    pos = Width i+    result = F.search (\w1 _ -> w1 >= pos) x+  in+    case result of+        F.Position before piece after ->+          let+            (Width w) = F.measure before+            (one,two) = S.splitAt (i - w) piece+          in+            (Rope ((F.|>) before one),Rope ((F.<|) two after))+        F.OnLeft -> (Rope F.empty, text)+        F.OnRight -> (text, Rope F.empty)+        F.Nowhere -> error "Position not found in split. Probable cause: predicate function given not monotonic. This is supposed to be unreachable"++{-|+Insert a new piece of text into an existing @Rope@ at the specified offset.++Examples:++@+λ> __insertRope 3 \"Con\" \"Def 1\"__+"DefCon 1"+λ> __insertRope 0 \"United \" \"Nations\"__+"United Nations"+@+-}+insertRope :: Int -> Rope -> Rope -> Rope+insertRope 0 (Rope new) (Rope x) = Rope ((F.><) new x)+insertRope i (Rope new) text =+  let+    (Rope before,Rope after) = splitRope i text+  in+    Rope (mconcat [before, new, after])++--+-- Manual instance to get around the fact that FingerTree doesn't have a+-- Hashable instance. If this were ever to become a hotspot we could+-- potentially use the Hashed caching type in the finger tree as+--+-- FingerTree Width (Hashed S.ShortText)+--+-- at the cost of endless unwrapping.+--+instance Hashable Rope where+    hashWithSalt salt (Rope x) = foldr f salt x+      where+        f :: S.ShortText -> Int -> Int+        f piece num = hashWithSalt num piece++{-|+Machinery to interpret a type as containing valid Unicode that can be+represented as a @Rope@ object.++/Implementation notes/++Given that @Rope@ is backed by a finger tree, 'append' is relatively+inexpensive, plus whatever the cost of conversion is. There is a subtle+trap, however: if adding small fragments of that were obtained by slicing+(for example) a large ByteString we would end up holding on to a reference+to the entire underlying block of memory. This module is optimized to+reduce heap fragmentation by letting the Haskell runtime and garbage+collector manage the memory, so instances are expected to /copy/ these+substrings out of pinned memory.++The @ByteString@ instance requires that its content be valid UTF-8. If not+an empty @Rope@ will be returned.++Several of the 'fromRope' implementations are expensive and involve a lot+of intermediate allocation and copying. If you're ultimately writing to a+handle prefer 'hWrite' which will write directly to the output buffer.+-}+class Textual α where+    {-|+Convert a @Rope@ into another text-like type.+    -}+    fromRope :: Rope -> α+    {-|+Take another text-like type and convert it to a @Rope@.+    -}+    intoRope :: α -> Rope+    {-|+Append some text to this @Rope@. The default implementation is basically a+convenience wrapper around calling 'intoRope' and 'mappend'ing it to your+text (which will work just fine, but for some types more efficient+implementations are possible).+    -}+    appendRope :: α -> Rope -> Rope+    appendRope thing text = text <> intoRope thing++instance Textual (F.FingerTree Width S.ShortText) where+    fromRope = unRope+    intoRope = Rope++instance Textual Rope where+    fromRope = id+    intoRope = id+    appendRope (Rope x2) (Rope x1) = Rope ((F.><) x1 x2)++{-| from "Data.Text.Short" -}+instance Textual S.ShortText where+    fromRope = foldr S.append S.empty . unRope+    intoRope = Rope . F.singleton+    appendRope piece (Rope x) = Rope ((F.|>) x piece)++{-| from "Data.Text" Strict -}+instance Textual T.Text where+    fromRope = U.toStrict . U.toLazyText . foldr f mempty . unRope+      where+        f :: S.ShortText -> U.Builder -> U.Builder+        f piece built = (<>) (U.fromText (S.toText piece)) built++    intoRope t = Rope (F.singleton (S.fromText t))+    appendRope chunk (Rope x) = Rope ((F.|>) x (S.fromText chunk))++{-| from "Data.Text.Lazy" -}+instance Textual U.Text where+    fromRope (Rope x) = U.fromChunks . fmap S.toText . toList $ x+    intoRope t = Rope (U.foldrChunks ((F.<|) . S.fromText) F.empty t)++{-| from "Data.ByteString" Strict -}+instance Textual B.ByteString where+    fromRope = L.toStrict . B.toLazyByteString . foldr g mempty . unRope+      where+        g piece built = (<>) (S.toBuilder piece) built++    -- If the input ByteString does not contain valid UTF-8 then an empty+    -- Rope will be returned. That's not ideal.+    intoRope b' = case S.fromByteString b' of+        Just piece -> Rope (F.singleton piece)+        Nothing -> Rope F.empty         -- bad++    -- ditto+    appendRope b' (Rope x) = case S.fromByteString b' of+        Just piece -> Rope ((F.|>) x piece)+        Nothing -> (Rope x)             -- bad++{-| from "Data.ByteString.Lazy" -}+instance Textual L.ByteString where+    fromRope = B.toLazyByteString . foldr g mempty . unRope+      where+        g piece built = (<>) (S.toBuilder piece) built++    intoRope b' = Rope (L.foldrChunks ((F.<|) . check) F.empty b')+      where+        check chunk = case S.fromByteString chunk of+            Just piece -> piece+            Nothing -> S.empty          -- very bad++instance Textual Bytes where+    fromRope = intoBytes . (fromRope :: Rope -> B.ByteString)+    intoRope = intoRope . unBytes++instance Binary Rope where+    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@.+-}+unsafeIntoRope :: B.ByteString -> Rope+unsafeIntoRope = Rope . F.singleton . S.fromByteStringUnsafe++{-| from "Data.String" -}+instance Textual [Char] where+    fromRope (Rope x) = foldr h [] x+      where+        h piece string = (S.unpack piece) ++ string -- ugh+    intoRope = Rope . F.singleton . S.pack++{-|+Write the 'Rope' to the given 'Handle'.++@+import "Core.Text"+import "Core.System" -- re-exports stdout++main :: IO ()+main =+  let+    text :: 'Rope'+    text = "Hello World"+  in+    'hWrite' 'System.IO.stdout' text+@+because it's tradition.++Uses 'Data.ByteString.Builder.hPutBuilder' internally which saves all kinds+of intermediate allocation and copying because we can go from the+'Data.Text.Short.ShortText's in the finger tree to+'Data.ByteString.Short.ShortByteString' to+'Data.ByteString.Builder.Builder' to the 'System.IO.Handle''s output buffer+in one go.++If you're working in the 'Core.Program.Execute.Program' monad, then+'Core.Program.Execute.write' provides an efficient way to write a @Rope@ to+@stdout@.+-}+hWrite :: Handle -> Rope -> IO ()+hWrite handle (Rope x) = B.hPutBuilder handle (foldr j mempty x)+  where+    j piece built = (<>) (S.toBuilder piece) built++{-|+Does the text contain this character?++We've used it to ask whether there are newlines present in a @Rope@, for+example:++@+    if 'containsCharacter' \'\\n\' text+        then handleComplexCase+        else keepItSimple+@+-}+containsCharacter :: Char -> Rope -> Bool+containsCharacter q (Rope x) = any j x+  where+    j piece = S.any (\c -> c == q) piece

@@ -0,0 +1,367 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_HADDOCK prune #-}++{-|+Useful tools for working with 'Rope's. Support for pretty printing,+multi-line strings, and...+-}+module Core.Text.Utilities (+      {-* Pretty printing -}+      Render(..)+    , render+      {-* Helpers -}+    , indefinite+    , breakWords+    , breakLines+    , breakPieces+    , wrap+    , underline+    , leftPadWith+    , rightPadWith+      {-* Multi-line strings -}+    , quote++    -- for testing+    , intoPieces+    , intoChunks++    , byteChunk+) where++import Data.Bits (Bits (..))+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 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+    , 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.Word (Word8)+import Language.Haskell.TH (litE, stringL)+import Language.Haskell.TH.Quote (QuasiQuoter(QuasiQuoter))++import Core.Text.Bytes+import Core.Text.Breaking+import Core.Text.Rope++-- change AnsiStyle to a custom token type, perhaps Ansi, which+-- has the escape codes already converted to Rope.++{-|+Types which can be rendered "prettily", that is, formatted by a pretty+printer and embossed with beautiful ANSI colours when printed to the+terminal.++Use 'render' to build text object for later use or "Core.Program.Execute"'s+'Core.Program.Execute.writeR' if you're writing directly to console now.+-}++class Render α where+    {-|+Which type are the annotations of your Doc going to be expressed in?+    -}+    type Token α :: *+    {-|+Convert semantic tokens to specific ANSI escape tokens+    -}+    colourize :: Token α -> AnsiStyle+    {-|+Arrange your type as a 'Doc' @ann@, annotated with your semantic+tokens.+    -}+    intoDocA :: α -> Doc (Token α)++instance Render Rope where+    type Token Rope = ()+    colourize = const mempty+    intoDocA = foldr f emptyDoc . unRope+      where+        f :: S.ShortText -> Doc () -> Doc ()+        f piece built = (<>) (pretty (S.toText piece)) built++instance Render Char where+    type Token Char = ()+    colourize = const mempty+    intoDocA c = pretty c++instance (Render a) => Render [a] where+    type Token [a] = Token a+    colourize = const mempty+    intoDocA = mconcat . fmap intoDocA++instance Render T.Text where+    type Token T.Text = ()+    colourize = const mempty+    intoDocA t = pretty t+++-- (), aka Unit, aka **1**, aka something with only one inhabitant++instance Render Bytes where+    type Token Bytes = ()+    colourize = const (color Green)+    intoDocA = prettyBytes++prettyBytes :: Bytes -> Doc ()+prettyBytes = annotate () . vcat . twoWords+    . fmap wordToHex . byteChunk . unBytes++twoWords :: [Doc ann] -> [Doc ann]+twoWords ds = go ds+  where+    go [] = []+    go [x] = [softline' <> x]+    go xs =+      let+        (one:two:[], remainder) = List.splitAt 2 xs+      in+        group (one <> spacer <> two) : go remainder++    spacer = flatAlt softline' "  "++byteChunk :: B.ByteString -> [B.ByteString]+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++-- Take an [up to] 8 byte (64 bit) word+wordToHex :: B.ByteString -> Doc ann+wordToHex eight =+  let+    ws = B.unpack eight+    ds = fmap byteToHex ws+  in+    hsep ds++byteToHex :: Word8 -> Doc ann+byteToHex c = pretty hi <> pretty low+  where+    !low      = byteToDigit $ c .&. 0xf+    !hi       = byteToDigit $ (c .&. 0xf0) `shiftR` 4++    byteToDigit :: Word8 -> Char+    byteToDigit = intToDigit . fromIntegral++{-|+Given an object of a type with a 'Render' instance, transform it into a+Rope saturated with ANSI escape codes representing syntax highlighting or+similar colouring, wrapping at the specified @width@.++The obvious expectation is that the next thing you're going to do is send+the Rope to console with:++@+    'Core.Program.Execute.write' ('render' 80 thing)+@++However, the /better/ thing to do is to instead use:++@+    'Core.Program.Execute.writeR' thing+@++which is able to pretty print the document text respecting the available+width of the terminal.+-}+-- the annotation (_ :: α) of the parameter is to bring type a into scope+-- at term level so that it can be used by TypedApplications. Which then+-- needed AllowAmbiguousTypes, but with all that finally it works:+-- colourize no longer needs a in its type signature.+render :: Render α => Int -> α -> Rope+render columns (thing :: α) =+  let+    options = LayoutOptions (AvailablePerLine (columns - 1) 1.0)+  in+    intoRope . renderLazy . reAnnotateS (colourize @α)+                . layoutPretty options . intoDocA $ thing++--+-- | Render "a" or "an" in front of a word depending on English's idea of+-- whether it's a vowel or not.+--+indefinite :: Rope -> Rope+indefinite text =+  let+    x = unRope text+  in+    case F.viewl x of+        F.EmptyL -> text+        piece F.:< _ -> case S.uncons piece of+            Nothing -> text+            Just (c,_)  -> if c `elem` ['A','E','I','O','U','a','e','i','o','u']+                then intoRope ("an " F.<| x)+                else intoRope ("a " F.<| x)++{-|+Often the input text represents a paragraph, but does not have any internal+newlines (representing word wrapping). This function takes a line of text+and inserts newlines to simulate such folding, keeping the line under+the supplied maximum width.++A single word that is excessively long will be included as-is on its own+line (that line will exceed the desired maxium width).++Any trailing newlines will be removed.+-}+wrap :: Int -> Rope -> Rope+wrap margin text =+  let+    built = wrapHelper margin (breakWords text)+  in+    built++wrapHelper :: Int -> [Rope] -> Rope+wrapHelper _ [] = ""+wrapHelper _ [x]  = x+wrapHelper margin (x:xs) =+    snd $ List.foldl' (wrapLine margin) (widthRope x, x) xs++wrapLine :: Int -> (Int, Rope) -> Rope -> (Int, Rope)+wrapLine margin (pos,builder) word =+  let+    wide = widthRope word+    wide' = pos + wide + 1+  in+    if wide' > margin+        then (wide , builder <> "\n" <> word)+        else (wide', builder <> " "  <> word)+++underline :: Char -> Rope -> Rope+underline level text =+  let+    title = fromRope text+    line = T.map (\_ -> level) title+  in+    intoRope line++{-|+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+  where+    pad = S.replicate len (S.singleton c)+    len = digits - widthRope text+++{-|+Right pad a text with the specified character.+-}+rightPadWith :: Char -> Int -> Rope -> Rope+rightPadWith c digits text =+    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.++-}+-- I thought this was going to be more complicated.+quote :: QuasiQuoter+quote = QuasiQuoter+    (litE . stringL . trim)        -- in an expression+    (error "Cannot use [quote| ... |] in a pattern")+    (error "Cannot use [quote| ... |] as a type")+    (error "Cannot use [quote| ... |] for a declaration")+  where+    trim :: String -> String+    trim = bot . top++    top [] = []+    top ('\n':cs) = cs+    top str = str++    bot = List.dropWhileEnd (== ' ')+