{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK prune #-}
module Core.Text.Utilities (
Render(..)
, render
, indefinite
, breakWords
, breakLines
, breakPieces
, wrap
, underline
, leftPadWith
, rightPadWith
, quote
, intoPieces
, intoChunks
, byteChunk
) where
import Data.Bits (Bits (..))
import Data.Char (intToDigit)
import qualified Data.ByteString as B (ByteString, splitAt, length, unpack)
import qualified Data.FingerTree as F ((<|), ViewL(..), viewl)
import qualified Data.List as List (foldl', dropWhileEnd, splitAt)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.Short as S (ShortText, uncons, toText, replicate
, singleton)
import Data.Text.Prettyprint.Doc (Doc, layoutPretty , annotate, reAnnotateS
, Pretty(..), pretty, emptyDoc
, LayoutOptions(LayoutOptions)
, PageWidth(AvailablePerLine)
, hsep, vcat, group, flatAlt
, softline'
)
import Data.Text.Prettyprint.Doc.Render.Terminal (renderLazy, AnsiStyle
, color, Color(..))
import Data.Word (Word8)
import Language.Haskell.TH (litE, stringL)
import Language.Haskell.TH.Quote (QuasiQuoter(QuasiQuoter))
import Core.Text.Bytes
import Core.Text.Breaking
import Core.Text.Rope
class Render α where
type Token α :: *
colourize :: Token α -> AnsiStyle
intoDocA :: α -> Doc (Token α)
instance Render Rope where
type Token Rope = ()
colourize = const mempty
intoDocA = foldr f emptyDoc . unRope
where
f :: S.ShortText -> Doc () -> Doc ()
f piece built = (<>) (pretty (S.toText piece)) built
instance Render Char where
type Token Char = ()
colourize = const mempty
intoDocA c = pretty c
instance (Render a) => Render [a] where
type Token [a] = Token a
colourize = const mempty
intoDocA = mconcat . fmap intoDocA
instance Render T.Text where
type Token T.Text = ()
colourize = const mempty
intoDocA t = pretty t
instance Render Bytes where
type Token Bytes = ()
colourize = const (color Green)
intoDocA = prettyBytes
prettyBytes :: Bytes -> Doc ()
prettyBytes = annotate () . vcat . twoWords
. fmap wordToHex . byteChunk . unBytes
twoWords :: [Doc ann] -> [Doc ann]
twoWords ds = go ds
where
go [] = []
go [x] = [softline' <> x]
go xs =
let
(one:two:[], remainder) = List.splitAt 2 xs
in
group (one <> spacer <> two) : go remainder
spacer = flatAlt softline' " "
byteChunk :: B.ByteString -> [B.ByteString]
byteChunk = reverse . go []
where
go acc blob =
let
(eight, remainder) = B.splitAt 8 blob
in
if B.length remainder == 0
then eight : acc
else go (eight : acc) remainder
wordToHex :: B.ByteString -> Doc ann
wordToHex eight =
let
ws = B.unpack eight
ds = fmap byteToHex ws
in
hsep ds
byteToHex :: Word8 -> Doc ann
byteToHex c = pretty hi <> pretty low
where
!low = byteToDigit $ c .&. 0xf
!hi = byteToDigit $ (c .&. 0xf0) `shiftR` 4
byteToDigit :: Word8 -> Char
byteToDigit = intToDigit . fromIntegral
render :: Render α => Int -> α -> Rope
render columns (thing :: α) =
let
options = LayoutOptions (AvailablePerLine (columns - 1) 1.0)
in
intoRope . renderLazy . reAnnotateS (colourize @α)
. layoutPretty options . intoDocA $ thing
indefinite :: Rope -> Rope
indefinite text =
let
x = unRope text
in
case F.viewl x of
F.EmptyL -> text
piece F.:< _ -> case S.uncons piece of
Nothing -> text
Just (c,_) -> if c `elem` ['A','E','I','O','U','a','e','i','o','u']
then intoRope ("an " F.<| x)
else intoRope ("a " F.<| x)
wrap :: Int -> Rope -> Rope
wrap margin text =
let
built = wrapHelper margin (breakWords text)
in
built
wrapHelper :: Int -> [Rope] -> Rope
wrapHelper _ [] = ""
wrapHelper _ [x] = x
wrapHelper margin (x:xs) =
snd $ List.foldl' (wrapLine margin) (widthRope x, x) xs
wrapLine :: Int -> (Int, Rope) -> Rope -> (Int, Rope)
wrapLine margin (pos,builder) word =
let
wide = widthRope word
wide' = pos + wide + 1
in
if wide' > margin
then (wide , builder <> "\n" <> word)
else (wide', builder <> " " <> word)
underline :: Char -> Rope -> Rope
underline level text =
let
title = fromRope text
line = T.map (\_ -> level) title
in
intoRope line
leftPadWith :: Char -> Int -> Rope -> Rope
leftPadWith c digits text =
intoRope pad <> text
where
pad = S.replicate len (S.singleton c)
len = digits - widthRope text
rightPadWith :: Char -> Int -> Rope -> Rope
rightPadWith c digits text =
text <> intoRope pad
where
pad = S.replicate len (S.singleton c)
len = digits - widthRope text
quote :: QuasiQuoter
quote = QuasiQuoter
(litE . stringL . trim)
(error "Cannot use [quote| ... |] in a pattern")
(error "Cannot use [quote| ... |] as a type")
(error "Cannot use [quote| ... |] for a declaration")
where
trim :: String -> String
trim = bot . top
top [] = []
top ('\n':cs) = cs
top str = str
bot = List.dropWhileEnd (== ' ')