{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Text.DocLayout (
render
, cr
, blankline
, blanklines
, space
, literal
, text
, char
, prefixed
, flush
, nest
, hang
, beforeNonBlank
, nowrap
, afterBreak
, lblock
, cblock
, rblock
, vfill
, nestle
, chomp
, inside
, braces
, brackets
, parens
, quotes
, doubleQuotes
, empty
, (<+>)
, ($$)
, ($+$)
, hcat
, hsep
, vcat
, vsep
, isEmpty
, offset
, minOffset
, updateColumn
, height
, charWidth
, realLength
, Doc(..)
, HasChars(..)
)
where
import Prelude
import Safe (lastMay, initSafe)
import Control.Monad
import Control.Monad.State.Strict
import GHC.Generics
import Data.Char (isSpace)
import Data.List (intersperse)
import Data.Data (Data, Typeable)
import Data.String
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.Text (Text)
#if MIN_VERSION_base(4,11,0)
#else
import Data.Semigroup
#endif
class (IsString a, Semigroup a, Monoid a, Show a) => HasChars a where
foldrChar :: (Char -> b -> b) -> b -> a -> b
replicateChar :: Int -> Char -> a
replicateChar n c = fromString (replicate n c)
isNull :: a -> Bool
isNull = foldrChar (\_ _ -> False) True
splitLines :: a -> [a]
splitLines s = (fromString firstline : otherlines)
where
(firstline, otherlines) = foldrChar go ([],[]) s
go '\n' (cur,lns) = ([], fromString cur : lns)
go c (cur,lns) = (c:cur, lns)
instance HasChars Text where
foldrChar = T.foldr
splitLines = T.splitOn "\n"
replicateChar n c = T.replicate n (T.singleton c)
isNull = T.null
instance HasChars String where
foldrChar = foldr
splitLines = lines . (++"\n")
replicateChar = replicate
isNull = null
instance HasChars TL.Text where
foldrChar = TL.foldr
splitLines = TL.splitOn "\n"
replicateChar n c = TL.replicate (fromIntegral n) (TL.singleton c)
isNull = TL.null
data Doc a = Text Int a
| Block Int [a]
| VFill Int a
| Prefixed Text (Doc a)
| BeforeNonBlank (Doc a)
| Flush (Doc a)
| BreakingSpace
| AfterBreak Text
| CarriageReturn
| NewLine
| BlankLines Int
| Concat (Doc a) (Doc a)
| Empty
deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable,
Data, Typeable, Generic)
instance Semigroup (Doc a) where
x <> Empty = x
Empty <> x = x
x <> y = Concat x y
instance Monoid (Doc a) where
mappend = (<>)
mempty = Empty
instance HasChars a => IsString (Doc a) where
fromString = text
unfoldD :: Doc a -> [Doc a]
unfoldD Empty = []
unfoldD (Concat x@Concat{} y) = unfoldD x <> unfoldD y
unfoldD (Concat x y) = x : unfoldD y
unfoldD x = [x]
isEmpty :: Doc a -> Bool
isEmpty Empty = True
isEmpty _ = False
empty :: Doc a
empty = mempty
hcat :: [Doc a] -> Doc a
hcat = mconcat
infixr 6 <+>
(<+>) :: Doc a -> Doc a -> Doc a
(<+>) x y
| isEmpty x = y
| isEmpty y = x
| otherwise = x <> space <> y
hsep :: [Doc a] -> Doc a
hsep = foldr (<+>) empty
infixr 5 $$
($$) :: Doc a -> Doc a -> Doc a
($$) x y
| isEmpty x = y
| isEmpty y = x
| otherwise = x <> cr <> y
infixr 5 $+$
($+$) :: Doc a -> Doc a -> Doc a
($+$) x y
| isEmpty x = y
| isEmpty y = x
| otherwise = x <> blankline <> y
vcat :: [Doc a] -> Doc a
vcat = foldr ($$) empty
vsep :: [Doc a] -> Doc a
vsep = foldr ($+$) empty
nestle :: Doc a -> Doc a
nestle d =
case d of
BlankLines _ -> Empty
NewLine -> Empty
Concat (Concat x y) z -> nestle (Concat x (Concat y z))
Concat BlankLines{} x -> nestle x
Concat NewLine x -> nestle x
_ -> d
chomp :: Doc a -> Doc a
chomp d =
case d of
BlankLines _ -> Empty
NewLine -> Empty
CarriageReturn -> Empty
BreakingSpace -> Empty
Prefixed s d' -> Prefixed s (chomp d')
Concat (Concat x y) z -> chomp (Concat x (Concat y z))
Concat x y ->
case chomp y of
Empty -> chomp x
z -> x <> z
_ -> d
type DocState a = State (RenderState a) ()
data RenderState a = RenderState{
output :: [a]
, prefix :: Text
, usePrefix :: Bool
, lineLength :: Maybe Int
, column :: Int
, newlines :: Int
}
newline :: HasChars a => DocState a
newline = do
st' <- get
let rawpref = prefix st'
when (column st' == 0 && usePrefix st' && not (T.null rawpref)) $ do
let pref = fromString $ T.unpack $ T.dropWhileEnd isSpace rawpref
modify $ \st -> st{ output = pref : output st
, column = column st + realLength pref }
modify $ \st -> st { output = "\n" : output st
, column = 0
, newlines = newlines st + 1
}
outp :: HasChars a => Int -> a -> DocState a
outp off s = do
st' <- get
let pref = fromString $ T.unpack $ prefix st'
when (column st' == 0 && usePrefix st' && not (isNull pref)) $
modify $ \st -> st{ output = pref : output st
, column = column st + realLength pref }
modify $ \st -> st{ output = s : output st
, column = column st + off
, newlines = 0 }
render :: HasChars a => Maybe Int -> Doc a -> a
render linelen doc = mconcat . reverse . output $
execState (renderDoc doc) startingState
where startingState = RenderState{
output = mempty
, prefix = mempty
, usePrefix = True
, lineLength = linelen
, column = 0
, newlines = 2 }
renderDoc :: HasChars a => Doc a -> DocState a
renderDoc = renderList . normalize . unfoldD
normalize :: HasChars a => [Doc a] -> [Doc a]
normalize [] = []
normalize (Concat{} : xs) = normalize xs
normalize (Empty : xs) = normalize xs
normalize [NewLine] = normalize [CarriageReturn]
normalize [BlankLines _] = normalize [CarriageReturn]
normalize [BreakingSpace] = []
normalize (BlankLines m : BlankLines n : xs) =
normalize (BlankLines (max m n) : xs)
normalize (BlankLines num : BreakingSpace : xs) =
normalize (BlankLines num : xs)
normalize (BlankLines m : CarriageReturn : xs) = normalize (BlankLines m : xs)
normalize (BlankLines m : NewLine : xs) = normalize (BlankLines m : xs)
normalize (NewLine : BlankLines m : xs) = normalize (BlankLines m : xs)
normalize (NewLine : BreakingSpace : xs) = normalize (NewLine : xs)
normalize (NewLine : CarriageReturn : xs) = normalize (NewLine : xs)
normalize (CarriageReturn : CarriageReturn : xs) =
normalize (CarriageReturn : xs)
normalize (CarriageReturn : NewLine : xs) = normalize (NewLine : xs)
normalize (CarriageReturn : BlankLines m : xs) = normalize (BlankLines m : xs)
normalize (CarriageReturn : BreakingSpace : xs) =
normalize (CarriageReturn : xs)
normalize (BreakingSpace : CarriageReturn : xs) =
normalize (CarriageReturn:xs)
normalize (BreakingSpace : NewLine : xs) = normalize (NewLine:xs)
normalize (BreakingSpace : BlankLines n : xs) = normalize (BlankLines n:xs)
normalize (BreakingSpace : BreakingSpace : xs) = normalize (BreakingSpace:xs)
normalize (x:xs) = x : normalize xs
mergeBlocks :: HasChars a => Int -> (Int, [a]) -> (Int, [a]) -> (Int, [a])
mergeBlocks h (w1,lns1) (w2,lns2) =
(w, zipWith (\l1 l2 -> pad w1 l1 <> l2) lns1' lns2')
where
w = w1 + w2
len1 = length $ take h lns1
len2 = length $ take h lns2
lns1' = if len1 < h
then lns1 ++ replicate (h - len1) mempty
else take h lns1
lns2' = if len2 < h
then lns2 ++ replicate (h - len2) mempty
else take h lns2
pad n s = s <> replicateChar (n - realLength s) ' '
renderList :: HasChars a => [Doc a] -> DocState a
renderList [] = return ()
renderList (Text off s : xs) = do
outp off s
renderList xs
renderList (Prefixed pref d : xs) = do
st <- get
let oldPref = prefix st
put st{ prefix = prefix st <> pref }
renderDoc d
modify $ \s -> s{ prefix = oldPref }
renderList xs
renderList (Flush d : xs) = do
st <- get
let oldUsePrefix = usePrefix st
put st{ usePrefix = False }
renderDoc d
modify $ \s -> s{ usePrefix = oldUsePrefix }
renderList xs
renderList (BeforeNonBlank d : xs) =
case xs of
(x:_) | startsBlank x -> renderList xs
| otherwise -> renderDoc d >> renderList xs
[] -> renderList xs
renderList (BlankLines num : xs) = do
st <- get
case output st of
_ | newlines st > num -> return ()
| otherwise -> replicateM_ (1 + num - newlines st) newline
renderList xs
renderList (CarriageReturn : xs) = do
st <- get
if newlines st > 0
then renderList xs
else do
newline
renderList xs
renderList (NewLine : xs) = do
newline
renderList xs
renderList (BreakingSpace : xs) = do
let isBreakingSpace BreakingSpace = True
isBreakingSpace _ = False
let xs' = dropWhile isBreakingSpace xs
let next = takeWhile (not . isBlank) xs'
st <- get
let off = foldr ((+) . offsetOf) 0 next
case lineLength st of
Just l | column st + 1 + off > l -> newline
_ -> when (column st > 0) $ outp 1 " "
renderList xs'
renderList (AfterBreak t : xs) = do
st <- get
if newlines st > 0
then renderList (fromString (T.unpack t) : xs)
else renderList xs
renderList (b : xs) | isBlock b = do
let (bs, rest) = span isBlock xs
let heightOf (Block _ ls) = length ls
heightOf _ = 1
let maxheight = maximum $ map heightOf (b:bs)
let toBlockSpec (Block w ls) = (w, ls)
toBlockSpec (VFill w t) = (w, take maxheight $ repeat t)
toBlockSpec _ = (0, [])
let (_, lns') = foldl (mergeBlocks maxheight) (toBlockSpec b)
(map toBlockSpec bs)
st <- get
let oldPref = prefix st
case column st - realLength oldPref of
n | n > 0 -> modify $ \s -> s{ prefix = oldPref <> T.replicate n " " }
_ -> return ()
renderList $ intersperse CarriageReturn (map literal lns')
modify $ \s -> s{ prefix = oldPref }
renderList rest
renderList (x:_) = error $ "renderList encountered " ++ show x
isBlank :: HasChars a => Doc a -> Bool
isBlank (Text _ t) = isAllSpace t
isBlank (Block _ ls) = all isAllSpace ls
isBlank (VFill _ t) = isAllSpace t
isBlank (Prefixed _ x) = isBlank x
isBlank (BeforeNonBlank x) = isBlank x
isBlank (Flush x) = isBlank x
isBlank BreakingSpace = True
isBlank (AfterBreak t) = isAllSpace t
isBlank CarriageReturn = True
isBlank NewLine = True
isBlank (BlankLines _) = True
isBlank (Concat x y) = isBlank x && isBlank y
isBlank Empty = True
startsBlank :: HasChars a => Doc a -> Bool
startsBlank (Text _ t) = foldrChar (const . isSpace) False t
startsBlank x = isBlank x
isAllSpace :: HasChars a => a -> Bool
isAllSpace = foldrChar ((&&) . isSpace) False
isBlock :: Doc a -> Bool
isBlock Block{} = True
isBlock VFill{} = True
isBlock _ = False
offsetOf :: Doc a -> Int
offsetOf (Text o _) = o
offsetOf (Block w _) = w
offsetOf (VFill w _) = w
offsetOf BreakingSpace = 1
offsetOf _ = 0
literal :: HasChars a => a -> Doc a
literal x =
mconcat $
intersperse NewLine $
map (\s -> if isNull s
then Empty
else Text (realLength s) s) $
splitLines x
text :: HasChars a => String -> Doc a
text = literal . fromString
char :: HasChars a => Char -> Doc a
char c = text $ fromString [c]
space :: Doc a
space = BreakingSpace
cr :: Doc a
cr = CarriageReturn
blankline :: Doc a
blankline = BlankLines 1
blanklines :: Int -> Doc a
blanklines = BlankLines
prefixed :: IsString a => String -> Doc a -> Doc a
prefixed pref doc
| isEmpty doc = Empty
| otherwise = Prefixed (fromString pref) doc
flush :: Doc a -> Doc a
flush doc
| isEmpty doc = Empty
| otherwise = Flush doc
nest :: IsString a => Int -> Doc a -> Doc a
nest ind = prefixed (replicate ind ' ')
hang :: IsString a => Int -> Doc a -> Doc a -> Doc a
hang ind start doc = start <> nest ind doc
beforeNonBlank :: Doc a -> Doc a
beforeNonBlank = BeforeNonBlank
nowrap :: IsString a => Doc a -> Doc a
nowrap = mconcat . map replaceSpace . unfoldD
where replaceSpace BreakingSpace = Text 1 $ fromString " "
replaceSpace x = x
afterBreak :: Text -> Doc a
afterBreak = AfterBreak
offset :: (IsString a, HasChars a) => Doc a -> Int
offset (Text n _) = n
offset (Block n _) = n
offset (VFill n _) = n
offset Empty = 0
offset CarriageReturn = 0
offset NewLine = 0
offset (BlankLines _) = 0
offset d = maximum (0 : map realLength (splitLines (render Nothing d)))
minOffset :: HasChars a => Doc a -> Int
minOffset (Text n _) = n
minOffset (Block n _) = n
minOffset (VFill n _) = n
minOffset Empty = 0
minOffset CarriageReturn = 0
minOffset NewLine = 0
minOffset (BlankLines _) = 0
minOffset d = maximum (0 : map realLength (splitLines (render (Just 0) d)))
updateColumn :: HasChars a => Doc a -> Int -> Int
updateColumn (Text n _) = (+ n)
updateColumn (Block n _) = (+ n)
updateColumn (VFill n _) = (+ n)
updateColumn Empty = const 0
updateColumn CarriageReturn = const 0
updateColumn NewLine = const 0
updateColumn (BlankLines _) = const 0
updateColumn d =
case map realLength (splitLines (render Nothing d)) of
[] -> id
[n] -> (+ n)
xs -> const (last xs)
lblock :: HasChars a => Int -> Doc a -> Doc a
lblock = block id
rblock :: HasChars a => Int -> Doc a -> Doc a
rblock w = block (\s -> replicateChar (w - realLength s) ' ' <> s) w
cblock :: HasChars a => Int -> Doc a -> Doc a
cblock w = block (\s -> replicateChar ((w - realLength s) `div` 2) ' ' <> s) w
height :: HasChars a => Doc a -> Int
height = length . splitLines . render Nothing
block :: HasChars a => (a -> a) -> Int -> Doc a -> Doc a
block filler width d
| width < 1 && not (isEmpty d) = block filler 1 d
| otherwise = Block width ls
where
ls = map filler $ chop width $ render (Just width) d
vfill :: HasChars a => a -> Doc a
vfill t = VFill (realLength t) t
chop :: HasChars a => Int -> a -> [a]
chop n =
concatMap chopLine . removeFinalEmpty . map addRealLength . splitLines
where
removeFinalEmpty xs = case lastMay xs of
Just (0, _) -> initSafe xs
_ -> xs
addRealLength l = (realLength l, l)
chopLine (len, l)
| len <= n = [l]
| otherwise = map snd $
foldrChar
(\c ls ->
let clen = charWidth c
cs = replicateChar 1 c
in case ls of
(len', l'):rest
| len' + clen > n ->
(clen, cs):(len', l'):rest
| otherwise ->
(len' + clen, cs <> l'):rest
[] -> [(clen, cs)]) [] l
inside :: Doc a -> Doc a -> Doc a -> Doc a
inside start end contents =
start <> contents <> end
braces :: HasChars a => Doc a -> Doc a
braces = inside (char '{') (char '}')
brackets :: HasChars a => Doc a -> Doc a
brackets = inside (char '[') (char ']')
parens :: HasChars a => Doc a -> Doc a
parens = inside (char '(') (char ')')
quotes :: HasChars a => Doc a -> Doc a
quotes = inside (char '\'') (char '\'')
doubleQuotes :: HasChars a => Doc a -> Doc a
doubleQuotes = inside (char '"') (char '"')
charWidth :: Char -> Int
charWidth c =
case c of
_ | c < '\x0300' -> 1
| c >= '\x0300' && c <= '\x036F' -> 0
| c >= '\x0370' && c <= '\x10FC' -> 1
| c >= '\x1100' && c <= '\x115F' -> 2
| c >= '\x1160' && c <= '\x11A2' -> 1
| c >= '\x11A3' && c <= '\x11A7' -> 2
| c >= '\x11A8' && c <= '\x11F9' -> 1
| c >= '\x11FA' && c <= '\x11FF' -> 2
| c >= '\x1200' && c <= '\x2328' -> 1
| c >= '\x2329' && c <= '\x232A' -> 2
| c >= '\x232B' && c <= '\x2E31' -> 1
| c >= '\x2E80' && c <= '\x303E' -> 2
| c == '\x303F' -> 1
| c >= '\x3041' && c <= '\x3247' -> 2
| c >= '\x3248' && c <= '\x324F' -> 1
| c >= '\x3250' && c <= '\x4DBF' -> 2
| c >= '\x4DC0' && c <= '\x4DFF' -> 1
| c >= '\x4E00' && c <= '\xA4C6' -> 2
| c >= '\xA4D0' && c <= '\xA95F' -> 1
| c >= '\xA960' && c <= '\xA97C' -> 2
| c >= '\xA980' && c <= '\xABF9' -> 1
| c >= '\xAC00' && c <= '\xD7FB' -> 2
| c >= '\xD800' && c <= '\xDFFF' -> 1
| c >= '\xE000' && c <= '\xF8FF' -> 1
| c >= '\xF900' && c <= '\xFAFF' -> 2
| c >= '\xFB00' && c <= '\xFDFD' -> 1
| c >= '\xFE00' && c <= '\xFE0F' -> 1
| c >= '\xFE10' && c <= '\xFE19' -> 2
| c >= '\xFE20' && c <= '\xFE26' -> 1
| c >= '\xFE30' && c <= '\xFE6B' -> 2
| c >= '\xFE70' && c <= '\xFEFF' -> 1
| c >= '\xFF01' && c <= '\xFF60' -> 2
| c >= '\xFF61' && c <= '\x16A38' -> 1
| c >= '\x1B000' && c <= '\x1B001' -> 2
| c >= '\x1D000' && c <= '\x1F1FF' -> 1
| c >= '\x1F200' && c <= '\x1F251' -> 2
| c >= '\x1F300' && c <= '\x1F773' -> 1
| c >= '\x20000' && c <= '\x3FFFD' -> 2
| otherwise -> 1
realLength :: HasChars a => a -> Int
realLength s = case foldrChar go (0, False) s of
(n, True) -> n + 1
(n, False) -> n
where
go c (tot, _combiningChar) =
case charWidth c of
0 -> (tot, True)
n -> (tot + n, False)