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

-- |
-- Useful tools for working with 'Rope's. Support for pretty printing,
-- multi-line strings, and...
--
-- ![ANSI colours](AnsiColours.png)
module Core.Text.Utilities
  ( -- * Pretty printing
    Render (..),
    AnsiColour,
    bold,
    render,
    renderNoAnsi,
    dullRed,
    brightRed,
    pureRed,
    dullGreen,
    brightGreen,
    pureGreen,
    dullBlue,
    brightBlue,
    pureBlue,
    dullCyan,
    brightCyan,
    pureCyan,
    dullMagenta,
    brightMagenta,
    pureMagenta,
    dullYellow,
    brightYellow,
    pureYellow,
    pureBlack,
    dullGrey,
    brightGrey,
    pureGrey,
    pureWhite,
    dullWhite,
    brightWhite,

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

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

import Core.Text.Breaking
import Core.Text.Bytes
import Core.Text.Parsing
import Core.Text.Rope
import Data.Bits (Bits (..))
import qualified Data.ByteString as B (ByteString, length, splitAt, unpack)
import Data.Char (intToDigit)
import Data.Colour.SRGB (sRGB, sRGB24read)
import qualified Data.FingerTree as F (ViewL (..), viewl, (<|))
import qualified Data.List as List (dropWhileEnd, foldl', splitAt)
import qualified Data.Text as T
import Data.Text.Prettyprint.Doc
  ( Doc,
    LayoutOptions (LayoutOptions),
    PageWidth (AvailablePerLine),
    Pretty (..),
    SimpleDocStream (..),
    annotate,
    emptyDoc,
    flatAlt,
    group,
    hsep,
    layoutPretty,
    pretty,
    reAnnotateS,
    softline',
    unAnnotateS,
    vcat,
  )
import Data.Text.Prettyprint.Doc.Render.Text (renderLazy)
import qualified Data.Text.Short as S
  ( ShortText,
    replicate,
    singleton,
    toText,
    uncons,
  )
import Data.Word (Word8)
import Language.Haskell.TH (litE, stringL)
import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))
import 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.
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
-- <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 α :: *

  -- |
  -- 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." #-}

-- | Medium \"Scarlet Red\" (@#cc0000@ from the Tango color palette).
dullRed :: AnsiColour
dullRed :: AnsiColour
dullRed =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#CC0000")]

-- | Highlighted \"Scarlet Red\" (@#ef2929@ from the Tango color palette).
brightRed :: AnsiColour
brightRed :: AnsiColour
brightRed =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#EF2929")]

-- | Pure \"Red\" (full RGB red channel only).
pureRed :: AnsiColour
pureRed :: AnsiColour
pureRed =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground (Float -> Float -> Float -> Colour Float
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Float
1 Float
0 Float
0)]

-- | Shadowed \"Chameleon\" (@#4e9a06@ from the Tango color palette).
dullGreen :: AnsiColour
dullGreen :: AnsiColour
dullGreen =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#4E9A06")]

-- | Highlighted \"Chameleon\" (@#8ae234@ from the Tango color palette).
brightGreen :: AnsiColour
brightGreen :: AnsiColour
brightGreen =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#8AE234")]

-- | Pure \"Green\" (full RGB green channel only).
pureGreen :: AnsiColour
pureGreen :: AnsiColour
pureGreen =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground (Float -> Float -> Float -> Colour Float
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Float
0 Float
1 Float
0)]

-- | Medium \"Sky Blue\" (@#3465a4@ from the Tango color palette).
dullBlue :: AnsiColour
dullBlue :: AnsiColour
dullBlue =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#3465A4")]

-- | Highlighted \"Sky Blue\" (@#729fcf@ from the Tango color palette).
brightBlue :: AnsiColour
brightBlue :: AnsiColour
brightBlue =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#729FCF")]

-- | Pure \"Blue\" (full RGB blue channel only).
pureBlue :: AnsiColour
pureBlue :: AnsiColour
pureBlue =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground (Float -> Float -> Float -> Colour Float
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Float
0 Float
0 Float
1)]

-- | Dull \"Cyan\" (from the __gnome-terminal__ console theme).
dullCyan :: AnsiColour
dullCyan :: AnsiColour
dullCyan =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#06989A")]

-- | Bright \"Cyan\" (from the __gnome-terminal__ console theme).
brightCyan :: AnsiColour
brightCyan :: AnsiColour
brightCyan =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#34E2E2")]

-- | Pure \"Cyan\" (full RGB blue + green channels).
pureCyan :: AnsiColour
pureCyan :: AnsiColour
pureCyan =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground (Float -> Float -> Float -> Colour Float
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Float
0 Float
1 Float
1)]

-- | Medium \"Plum\" (@#75507b@ from the Tango color palette).
dullMagenta :: AnsiColour
dullMagenta :: AnsiColour
dullMagenta =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#75507B")]

-- | Highlighted \"Plum\" (@#ad7fa8@ from the Tango color palette).
brightMagenta :: AnsiColour
brightMagenta :: AnsiColour
brightMagenta =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#AD7FA8")]

-- | Pure \"Magenta\" (full RGB red + blue channels).
pureMagenta :: AnsiColour
pureMagenta :: AnsiColour
pureMagenta =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground (Float -> Float -> Float -> Colour Float
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Float
1 Float
0 Float
1)]

-- | Shadowed \"Butter\" (@#c4a000@ from the Tango color palette).
dullYellow :: AnsiColour
dullYellow :: AnsiColour
dullYellow =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#C4A000")]

-- | Highlighted \"Butter\" (@#fce94f@ from the Tango color palette).
brightYellow :: AnsiColour
brightYellow :: AnsiColour
brightYellow =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#FCE94F")]

-- | Pure \"Yellow\" (full RGB red + green channels).
pureYellow :: AnsiColour
pureYellow :: AnsiColour
pureYellow =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground (Float -> Float -> Float -> Colour Float
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Float
1 Float
1 Float
0)]

-- | Pure \"Black\" (zero in all RGB channels).
pureBlack :: AnsiColour
pureBlack :: AnsiColour
pureBlack =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground (Float -> Float -> Float -> Colour Float
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Float
0 Float
0 Float
0)]

-- | Shadowed \"Deep Aluminium\" (@#2e3436@ from the Tango color palette).
dullGrey :: AnsiColour
dullGrey :: AnsiColour
dullGrey =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#2E3436")]

-- | Medium \"Dark Aluminium\" (from the Tango color palette).
brightGrey :: AnsiColour
brightGrey :: AnsiColour
brightGrey =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#555753")]

-- | Pure \"Grey\" (set at @#999999@, being just over half in all RGB channels).
pureGrey :: AnsiColour
pureGrey :: AnsiColour
pureGrey =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#999999")]

-- | Pure \"White\" (fully on in all RGB channels).
pureWhite :: AnsiColour
pureWhite :: AnsiColour
pureWhite =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground (Float -> Float -> Float -> Colour Float
forall b. (Ord b, Floating b) => b -> b -> b -> Colour b
sRGB Float
1 Float
1 Float
1)]

-- | Medium \"Light Aluminium\" (@#d3d7cf@ from the Tango color palette).
dullWhite :: AnsiColour
dullWhite :: AnsiColour
dullWhite =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#D3D7CF")]

-- | Highlighted \"Light Aluminium\" (@#eeeeec@ from the Tango color palette).
brightWhite :: AnsiColour
brightWhite :: AnsiColour
brightWhite =
  [SGR] -> AnsiColour
Escapes [ConsoleLayer -> Colour Float -> SGR
SetRGBColor ConsoleLayer
Foreground ([Char] -> Colour Float
forall b. (Ord b, Floating b) => [Char] -> Colour b
sRGB24read [Char]
"#EEEEEC")]

-- |
-- Given an 'AnsiColour', lift it to bold intensity.
--
-- Note that many console fonts do /not/ have a bold face variant, and
-- terminal emulators that "support bold" do so by doubling the thickness of
-- the lines in the glyphs. This may or may not be desirable from a
-- readibility standpoint but really there's only so much you can do to keep
-- users who make poor font choices from making poor font choices.
bold :: AnsiColour -> AnsiColour
bold :: AnsiColour -> AnsiColour
bold (Escapes [SGR]
list) =
  [SGR] -> AnsiColour
Escapes (ConsoleIntensity -> SGR
SetConsoleIntensity ConsoleIntensity
BoldIntensity SGR -> [SGR] -> [SGR]
forall a. a -> [a] -> [a]
: [SGR]
list)

instance Semigroup AnsiColour where
  <> :: AnsiColour -> AnsiColour -> AnsiColour
(<>) (Escapes [SGR]
list1) (Escapes [SGR]
list2) = [SGR] -> AnsiColour
Escapes ([SGR]
list1 [SGR] -> [SGR] -> [SGR]
forall a. Semigroup a => a -> a -> a
<> [SGR]
list2)

instance Monoid AnsiColour where
  mempty :: AnsiColour
mempty = [SGR] -> AnsiColour
Escapes []

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 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 =
      let (Doc ann
one : Doc ann
two : [], [Doc ann]
remainder) = Int -> [Doc ann] -> ([Doc ann], [Doc ann])
forall a. Int -> [a] -> ([a], [a])
List.splitAt Int
2 [Doc ann]
xs
       in 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

    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 Rope -> Rope
forall α. Textual α => α -> Rope
intoRope (Rope -> Rope) -> (α -> Rope) -> α -> Rope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [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
<> ShortText -> Rope
forall α. Textual α => α -> Rope
intoRope (Int -> ShortText -> ShortText
S.replicate Int
len (Char -> ShortText
S.singleton 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 (Escapes [SGR]
codes) = [Char] -> Rope
forall α. Textual α => α -> Rope
intoRope ([SGR] -> [Char]
setSGRCode [SGR]
codes)

    reset :: Rope
    reset :: Rope
reset = [Char] -> Rope
forall α. Textual α => α -> Rope
intoRope ([SGR] -> [Char]
setSGRCode [SGR
Reset])

-- |
-- Having gone to all the trouble to colourize your rendered types...
-- sometimes you don't want that. This function is like 'render', but removes
-- all the ANSI escape codes so it comes outformatted but as plain black &
-- white text.
renderNoAnsi :: Render α => Int -> α -> Rope
renderNoAnsi :: 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)

-- |
-- 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 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 :: 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
' ')