{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Text.Utilities (
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,
indefinite,
breakWords,
breakLines,
breakPieces,
isNewline,
wrap,
calculatePositionEnd,
underline,
leftPadWith,
rightPadWith,
quote,
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 (..))
newtype AnsiColour = Escapes [SGR]
class Render α where
type Token α :: *
colourize :: Token α -> AnsiColour
highlight :: α -> Doc (Token α)
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." #-}
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")]
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")]
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)]
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")]
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")]
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)]
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")]
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")]
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)]
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")]
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")]
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)]
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")]
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")]
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)]
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")]
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")]
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)]
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)]
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")]
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")]
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")]
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)]
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")]
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")]
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 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
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
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
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"
(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])
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
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)
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
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
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
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)
([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
' ')