{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK prune, not-home #-}

{- |
Useful tools for working with 'Rope's. Support for pretty printing, multi-line
strings, and...
-}
module Core.Text.Utilities (
    -- * Pretty printing
    Render (..),
    render,
    renderNoAnsi,

    -- * Helpers
    indefinite,
    oxford,
    breakRope,
    breakWords,
    breakLines,
    breakPieces,
    isNewline,
    wrap,
    calculatePositionEnd,
    underline,
    leftPadWith,
    rightPadWith,

    -- * Multi-line strings
    quote,
    -- for testing
    intoPieces,
    intoChunks,
    byteChunk,

    -- * Deprecated
    intoDocA,
    module Core.Text.Colour,
    bold,
    -- | AnsiColour and colour constants moved to this module.
) where

import Core.Text.Breaking
import Core.Text.Bytes
import Core.Text.Colour
import Core.Text.Parsing
import Core.Text.Rope
import Data.Bits (Bits (..))
import Data.ByteString qualified as B (ByteString, length, splitAt, unpack)
import Data.Char (intToDigit)
import Data.FingerTree qualified as F (ViewL (..), viewl, (<|))
import Data.Kind (Type)
import Data.List qualified as List (dropWhileEnd, foldl', splitAt)
import Data.Text qualified as T
import Data.Text.Short qualified 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 Prettyprinter (
    Doc,
    LayoutOptions (LayoutOptions),
    PageWidth (AvailablePerLine),
    Pretty (..),
    SimpleDocStream (..),
    annotate,
    emptyDoc,
    flatAlt,
    group,
    hsep,
    layoutPretty,
    pretty,
    reAnnotateS,
    softline',
    unAnnotateS,
    vcat,
 )
import Prettyprinter.Render.Text (renderLazy)

{- |
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
<https://hackage.haskell.org/package/core-program/docs/Core-Program-Logging.html
Control.Program.Logging>'s
<https://hackage.haskell.org/package/core-program/docs/Core-Program-Logging.html#v:writeR
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 α :: Type

    -- | 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 α)

-- | Nothing should be invoking 'intoDocA'.
intoDocA :: α -> Doc (Token α)
intoDocA :: α -> Doc (Token α)
intoDocA = [Char] -> α -> Doc (Token α)
forall a. HasCallStack => [Char] -> a
error [Char]
"Nothing should be invoking this method directly."
{-# DEPRECATED intoDocA "method'intoDocA' has been renamed 'highlight'; implement that instead." #-}

bold :: AnsiColour -> AnsiColour
bold :: AnsiColour -> AnsiColour
bold = AnsiColour -> AnsiColour
boldColour
{-# DEPRECATED bold "Import Core.Text.Colour and use 'boldColour' instead" #-}

instance Render Rope where
    type Token Rope = ()
    colourize :: Token Rope -> AnsiColour
colourize = AnsiColour -> () -> AnsiColour
forall a b. a -> b -> a
const AnsiColour
forall a. Monoid a => a
mempty
    highlight :: Rope -> Doc (Token Rope)
highlight = (ShortText -> Doc () -> Doc ())
-> Doc () -> FingerTree Width ShortText -> Doc ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ShortText -> Doc () -> Doc ()
f Doc ()
forall ann. Doc ann
emptyDoc (FingerTree Width ShortText -> Doc ())
-> (Rope -> FingerTree Width ShortText) -> Rope -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rope -> FingerTree Width ShortText
unRope
      where
        f :: S.ShortText -> Doc () -> Doc ()
        f :: ShortText -> Doc () -> Doc ()
f ShortText
piece Doc ()
built = Doc () -> Doc () -> Doc ()
forall a. Semigroup a => a -> a -> a
(<>) (Text -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty (ShortText -> Text
S.toText ShortText
piece)) Doc ()
built

instance Render Char where
    type Token Char = ()
    colourize :: Token Char -> AnsiColour
colourize = AnsiColour -> () -> AnsiColour
forall a b. a -> b -> a
const AnsiColour
forall a. Monoid a => a
mempty
    highlight :: Char -> Doc (Token Char)
highlight Char
c = Char -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty Char
c

instance (Render a) => Render [a] where
    type Token [a] = Token a
    colourize :: Token [a] -> AnsiColour
colourize = Render a => Token a -> AnsiColour
forall α. Render α => Token α -> AnsiColour
colourize @a
    highlight :: [a] -> Doc (Token [a])
highlight = [Doc (Token a)] -> Doc (Token a)
forall a. Monoid a => [a] -> a
mconcat ([Doc (Token a)] -> Doc (Token a))
-> ([a] -> [Doc (Token a)]) -> [a] -> Doc (Token a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Doc (Token a)) -> [a] -> [Doc (Token a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Doc (Token a)
forall α. Render α => α -> Doc (Token α)
highlight

instance Render String where
    type Token String = Token Char
    colourize :: Token [Char] -> AnsiColour
colourize = Render Char => Token Char -> AnsiColour
forall α. Render α => Token α -> AnsiColour
colourize @Char
    highlight :: [Char] -> Doc (Token [Char])
highlight = [Doc ()] -> Doc ()
forall a. Monoid a => [a] -> a
mconcat ([Doc ()] -> Doc ()) -> ([Char] -> [Doc ()]) -> [Char] -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Doc ()) -> [Char] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Doc ()
forall α. Render α => α -> Doc (Token α)
highlight

instance Render T.Text where
    type Token T.Text = ()
    colourize :: Token Text -> AnsiColour
colourize = AnsiColour -> () -> AnsiColour
forall a b. a -> b -> a
const AnsiColour
forall a. Monoid a => a
mempty
    highlight :: Text -> Doc (Token Text)
highlight Text
t = Text -> Doc ()
forall a ann. Pretty a => a -> Doc ann
pretty Text
t

-- (), aka Unit, aka **1**, aka something with only one inhabitant

instance Render Bytes where
    type Token Bytes = ()
    colourize :: Token Bytes -> AnsiColour
colourize = AnsiColour -> () -> AnsiColour
forall a b. a -> b -> a
const AnsiColour
brightGreen
    highlight :: Bytes -> Doc (Token Bytes)
highlight = Bytes -> Doc ()
Bytes -> Doc (Token Bytes)
prettyBytes

prettyBytes :: Bytes -> Doc ()
prettyBytes :: Bytes -> Doc ()
prettyBytes =
    () -> Doc () -> Doc ()
forall ann. ann -> Doc ann -> Doc ann
annotate () (Doc () -> Doc ()) -> (Bytes -> Doc ()) -> Bytes -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ()] -> Doc ()
forall ann. [Doc ann] -> Doc ann
vcat ([Doc ()] -> Doc ()) -> (Bytes -> [Doc ()]) -> Bytes -> Doc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc ()] -> [Doc ()]
forall ann. [Doc ann] -> [Doc ann]
twoWords
        ([Doc ()] -> [Doc ()]) -> (Bytes -> [Doc ()]) -> Bytes -> [Doc ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Doc ()) -> [ByteString] -> [Doc ()]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Doc ()
forall ann. ByteString -> Doc ann
wordToHex
        ([ByteString] -> [Doc ()])
-> (Bytes -> [ByteString]) -> Bytes -> [Doc ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
byteChunk
        (ByteString -> [ByteString])
-> (Bytes -> ByteString) -> Bytes -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> ByteString
unBytes

twoWords :: [Doc ann] -> [Doc ann]
twoWords :: [Doc ann] -> [Doc ann]
twoWords [Doc ann]
ds = [Doc ann] -> [Doc ann]
forall ann. [Doc ann] -> [Doc ann]
go [Doc ann]
ds
  where
    go :: [Doc ann] -> [Doc ann]
go [] = []
    go [Doc ann
x] = [Doc ann
forall ann. Doc ann
softline' Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
x]
    go [Doc ann]
xs = case Int -> [Doc ann] -> ([Doc ann], [Doc ann])
forall a. Int -> [a] -> ([a], [a])
List.splitAt Int
2 [Doc ann]
xs of
        (Doc ann
one : Doc ann
two : [], [Doc ann]
remainder) -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
group (Doc ann
one Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
spacer Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
two) Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
: [Doc ann] -> [Doc ann]
go [Doc ann]
remainder
        ([Doc ann], [Doc ann])
_ -> [] -- unreachable
    spacer :: Doc ann
spacer = Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
flatAlt Doc ann
forall ann. Doc ann
softline' Doc ann
"  "

byteChunk :: B.ByteString -> [B.ByteString]
byteChunk :: ByteString -> [ByteString]
byteChunk = [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString -> [ByteString]
go []
  where
    go :: [ByteString] -> ByteString -> [ByteString]
go [ByteString]
acc ByteString
blob =
        let (ByteString
eight, ByteString
remainder) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
8 ByteString
blob
         in if ByteString -> Int
B.length ByteString
remainder Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                then ByteString
eight ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
acc
                else [ByteString] -> ByteString -> [ByteString]
go (ByteString
eight ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
acc) ByteString
remainder

-- Take an [up to] 8 byte (64 bit) word
wordToHex :: B.ByteString -> Doc ann
wordToHex :: ByteString -> Doc ann
wordToHex ByteString
eight =
    let ws :: [Word8]
ws = ByteString -> [Word8]
B.unpack ByteString
eight
        ds :: [Doc ann]
ds = (Word8 -> Doc ann) -> [Word8] -> [Doc ann]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word8 -> Doc ann
forall ann. Word8 -> Doc ann
byteToHex [Word8]
ws
     in [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep [Doc ann]
ds

byteToHex :: Word8 -> Doc ann
byteToHex :: Word8 -> Doc ann
byteToHex Word8
c = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
hi Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Char
low
  where
    !low :: Char
low = Word8 -> Char
byteToDigit (Word8 -> Char) -> Word8 -> Char
forall a b. (a -> b) -> a -> b
$ Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xf
    !hi :: Char
hi = Word8 -> Char
byteToDigit (Word8 -> Char) -> Word8 -> Char
forall a b. (a -> b) -> a -> b
$ (Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0xf0) Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` Int
4

    byteToDigit :: Word8 -> Char
    byteToDigit :: Word8 -> Char
byteToDigit = Int -> Char
intToDigit (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
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 :: Int -> α -> Rope
render Int
columns (α
thing :: α) =
    let options :: LayoutOptions
options = PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine (Int
columns Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Double
1.0)
     in [AnsiColour] -> SimpleDocStream AnsiColour -> Rope
go [] (SimpleDocStream AnsiColour -> Rope)
-> (α -> SimpleDocStream AnsiColour) -> α -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Token α -> AnsiColour)
-> SimpleDocStream (Token α) -> SimpleDocStream AnsiColour
forall ann ann'.
(ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann'
reAnnotateS (Render α => Token α -> AnsiColour
forall α. Render α => Token α -> AnsiColour
colourize @α)
            (SimpleDocStream (Token α) -> SimpleDocStream AnsiColour)
-> (α -> SimpleDocStream (Token α))
-> α
-> SimpleDocStream AnsiColour
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc (Token α) -> SimpleDocStream (Token α)
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
options
            (Doc (Token α) -> SimpleDocStream (Token α))
-> (α -> Doc (Token α)) -> α -> SimpleDocStream (Token α)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. α -> Doc (Token α)
forall α. Render α => α -> Doc (Token α)
highlight
            (α -> Rope) -> α -> Rope
forall a b. (a -> b) -> a -> b
$ α
thing
  where
    go :: [AnsiColour] -> SimpleDocStream AnsiColour -> Rope
    go :: [AnsiColour] -> SimpleDocStream AnsiColour -> Rope
go [AnsiColour]
as SimpleDocStream AnsiColour
x = case SimpleDocStream AnsiColour
x of
        SimpleDocStream AnsiColour
SFail -> [Char] -> Rope
forall a. HasCallStack => [Char] -> a
error [Char]
"Unhandled SFail"
        SimpleDocStream AnsiColour
SEmpty -> Rope
emptyRope
        SChar Char
c SimpleDocStream AnsiColour
xs ->
            Char -> Rope
singletonRope Char
c Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> [AnsiColour] -> SimpleDocStream AnsiColour -> Rope
go [AnsiColour]
as SimpleDocStream AnsiColour
xs
        SText Int
_ Text
t SimpleDocStream AnsiColour
xs ->
            Text -> Rope
forall α. Textual α => α -> Rope
intoRope Text
t Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> [AnsiColour] -> SimpleDocStream AnsiColour -> Rope
go [AnsiColour]
as SimpleDocStream AnsiColour
xs
        SLine Int
len SimpleDocStream AnsiColour
xs ->
            Char -> Rope
singletonRope Char
'\n'
                Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Int -> Char -> Rope
replicateChar Int
len Char
' '
                Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> [AnsiColour] -> SimpleDocStream AnsiColour -> Rope
go [AnsiColour]
as SimpleDocStream AnsiColour
xs
        SAnnPush AnsiColour
a SimpleDocStream AnsiColour
xs ->
            Rope -> Rope
forall α. Textual α => α -> Rope
intoRope (AnsiColour -> Rope
convert AnsiColour
a) Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> [AnsiColour] -> SimpleDocStream AnsiColour -> Rope
go (AnsiColour
a AnsiColour -> [AnsiColour] -> [AnsiColour]
forall a. a -> [a] -> [a]
: [AnsiColour]
as) SimpleDocStream AnsiColour
xs
        SAnnPop SimpleDocStream AnsiColour
xs ->
            case [AnsiColour]
as of
                [] -> [Char] -> Rope
forall a. HasCallStack => [Char] -> a
error [Char]
"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.
                (AnsiColour
_ : [AnsiColour]
as') -> case [AnsiColour]
as' of
                    [] -> Rope
reset Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> [AnsiColour] -> SimpleDocStream AnsiColour -> Rope
go [] SimpleDocStream AnsiColour
xs
                    (AnsiColour
a : [AnsiColour]
_) -> AnsiColour -> Rope
convert AnsiColour
a Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> [AnsiColour] -> SimpleDocStream AnsiColour -> Rope
go [AnsiColour]
as' SimpleDocStream AnsiColour
xs

    convert :: AnsiColour -> Rope
    convert :: AnsiColour -> Rope
convert = AnsiColour -> Rope
intoEscapes

    reset :: Rope
    reset :: Rope
reset = AnsiColour -> Rope
intoEscapes AnsiColour
resetColour

{- |
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 :: Int -> α -> Rope
renderNoAnsi Int
columns (α
thing :: α) =
    let options :: LayoutOptions
options = PageWidth -> LayoutOptions
LayoutOptions (Int -> Double -> PageWidth
AvailablePerLine (Int
columns Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Double
1.0)
     in Text -> Rope
forall α. Textual α => α -> Rope
intoRope (Text -> Rope) -> (α -> Text) -> α -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
renderLazy (SimpleDocStream Any -> Text)
-> (α -> SimpleDocStream Any) -> α -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDocStream (Token α) -> SimpleDocStream Any
forall ann xxx. SimpleDocStream ann -> SimpleDocStream xxx
unAnnotateS
            (SimpleDocStream (Token α) -> SimpleDocStream Any)
-> (α -> SimpleDocStream (Token α)) -> α -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc (Token α) -> SimpleDocStream (Token α)
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
options
            (Doc (Token α) -> SimpleDocStream (Token α))
-> (α -> Doc (Token α)) -> α -> SimpleDocStream (Token α)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. α -> Doc (Token α)
forall α. Render α => α -> Doc (Token α)
highlight
            (α -> Rope) -> α -> Rope
forall a b. (a -> b) -> a -> b
$ α
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 :: Rope -> Rope
indefinite Rope
text =
    let x :: FingerTree Width ShortText
x = Rope -> FingerTree Width ShortText
unRope Rope
text
     in case FingerTree Width ShortText -> ViewL (FingerTree Width) ShortText
forall v a.
Measured v a =>
FingerTree v a -> ViewL (FingerTree v) a
F.viewl FingerTree Width ShortText
x of
            ViewL (FingerTree Width) ShortText
F.EmptyL -> Rope
text
            ShortText
piece F.:< FingerTree Width ShortText
_ -> case ShortText -> Maybe (Char, ShortText)
S.uncons ShortText
piece of
                Maybe (Char, ShortText)
Nothing -> Rope
text
                Just (Char
c, ShortText
_) ->
                    if Char
c Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'A', Char
'E', Char
'I', Char
'O', Char
'U', Char
'a', Char
'e', Char
'i', Char
'o', Char
'u']
                        then FingerTree Width ShortText -> Rope
forall α. Textual α => α -> Rope
intoRope (ShortText
"an " ShortText
-> FingerTree Width ShortText -> FingerTree Width ShortText
forall v a. Measured v a => a -> FingerTree v a -> FingerTree v a
F.<| FingerTree Width ShortText
x)
                        else FingerTree Width ShortText -> Rope
forall α. Textual α => α -> Rope
intoRope (ShortText
"a " ShortText
-> FingerTree Width ShortText -> FingerTree Width ShortText
forall v a. Measured v a => a -> FingerTree v a -> FingerTree v a
F.<| FingerTree Width ShortText
x)

{- |
Given a list of items (one word per Rope in the list) enumerate them with commas and
an Oxford comma before the last item. As you'd expect:

@
λ> __oxford ["one", "two", "three"]__
"one, two, and three"
@

Because English is ridiculous, however, and we can't have nice things, two
items are a special case:

@
λ> __oxford ["four", "five"]__
"four and five"
@

Sadly if there is only one item you don't get an Oxford comma, either:

@
λ> __oxford ["six"]__
"six"
λ> __oxford []__
""
@
-}
oxford :: [Rope] -> Rope
oxford :: [Rope] -> Rope
oxford [] = Rope
emptyRope
oxford (Rope
first : []) = Rope
first
oxford (Rope
first : Rope
second : []) = Rope
first Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
" and " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
second
oxford (Rope
first : [Rope]
remainder) = Rope
first Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> [Rope] -> Rope
series [Rope]
remainder
  where
    series :: [Rope] -> Rope
series [] = Rope
emptyRope
    series (Rope
item : []) = Rope
", and " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
item
    series (Rope
item : [Rope]
items) = Rope
", " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
item Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> [Rope] -> Rope
series [Rope]
items

{- |
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 :: Int -> Rope -> Rope
wrap Int
margin Rope
text =
    let built :: Rope
built = Int -> [Rope] -> Rope
wrapHelper Int
margin (Rope -> [Rope]
breakWords Rope
text)
     in Rope
built

wrapHelper :: Int -> [Rope] -> Rope
wrapHelper :: Int -> [Rope] -> Rope
wrapHelper Int
_ [] = Rope
""
wrapHelper Int
_ [Rope
x] = Rope
x
wrapHelper Int
margin (Rope
x : [Rope]
xs) =
    (Int, Rope) -> Rope
forall a b. (a, b) -> b
snd ((Int, Rope) -> Rope) -> (Int, Rope) -> Rope
forall a b. (a -> b) -> a -> b
$ ((Int, Rope) -> Rope -> (Int, Rope))
-> (Int, Rope) -> [Rope] -> (Int, Rope)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Int -> (Int, Rope) -> Rope -> (Int, Rope)
wrapLine Int
margin) (Rope -> Int
widthRope Rope
x, Rope
x) [Rope]
xs

wrapLine :: Int -> (Int, Rope) -> Rope -> (Int, Rope)
wrapLine :: Int -> (Int, Rope) -> Rope -> (Int, Rope)
wrapLine Int
margin (Int
pos, Rope
builder) Rope
word =
    let wide :: Int
wide = Rope -> Int
widthRope Rope
word
        wide' :: Int
wide' = Int
pos Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
wide Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
     in if Int
wide' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
margin
            then (Int
wide, Rope
builder Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
"\n" Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
word)
            else (Int
wide', Rope
builder Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
" " Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
word)

underline :: Char -> Rope -> Rope
underline :: Char -> Rope -> Rope
underline Char
level Rope
text =
    let title :: Text
title = Rope -> Text
forall α. Textual α => Rope -> α
fromRope Rope
text
        line :: Text
line = (Char -> Char) -> Text -> Text
T.map (\Char
_ -> Char
level) Text
title
     in Text -> Rope
forall α. Textual α => α -> Rope
intoRope Text
line

{- |
Pad a piece 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 :: Char -> Int -> Rope -> Rope
leftPadWith Char
c Int
digits Rope
text =
    ShortText -> Rope
forall α. Textual α => α -> Rope
intoRope ShortText
pad Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> Rope
text
  where
    pad :: ShortText
pad = Int -> ShortText -> ShortText
S.replicate Int
len (Char -> ShortText
S.singleton Char
c)
    len :: Int
len = Int
digits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Rope -> Int
widthRope Rope
text

{- |
Right pad a text with the specified character.
-}
rightPadWith :: Char -> Int -> Rope -> Rope
rightPadWith :: Char -> Int -> Rope -> Rope
rightPadWith Char
c Int
digits Rope
text =
    Rope
text Rope -> Rope -> Rope
forall a. Semigroup a => a -> a -> a
<> ShortText -> Rope
forall α. Textual α => α -> Rope
intoRope ShortText
pad
  where
    pad :: ShortText
pad = Int -> ShortText -> ShortText
S.replicate Int
len (Char -> ShortText
S.singleton Char
c)
    len :: Int
len = Int
digits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Rope -> Int
widthRope Rope
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
quote =
    ([Char] -> Q Exp)
-> ([Char] -> Q Pat)
-> ([Char] -> Q Type)
-> ([Char] -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
        (Lit -> Q Exp
litE (Lit -> Q Exp) -> ([Char] -> Lit) -> [Char] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Lit
stringL ([Char] -> Lit) -> ([Char] -> [Char]) -> [Char] -> Lit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
trim) -- in an expression
        ([Char] -> [Char] -> Q Pat
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use [quote| ... |] in a pattern")
        ([Char] -> [Char] -> Q Type
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use [quote| ... |] as a type")
        ([Char] -> [Char] -> Q [Dec]
forall a. HasCallStack => [Char] -> a
error [Char]
"Cannot use [quote| ... |] for a declaration")
  where
    trim :: String -> String
    trim :: [Char] -> [Char]
trim = [Char] -> [Char]
bot ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
top

    top :: [Char] -> [Char]
top [] = []
    top (Char
'\n' : [Char]
cs) = [Char]
cs
    top [Char]
str = [Char]
str

    bot :: [Char] -> [Char]
bot = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
List.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')