{-# LANGUAGE BangPatterns       #-}
{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable     #-}
{-# LANGUAGE DeriveFunctor      #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE DeriveTraversable  #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE MultiWayIf         #-}
{-# LANGUAGE NoImplicitPrelude  #-}
{-# LANGUAGE OverloadedStrings  #-}
{- |
   Module      : Text.DocLayout
   Copyright   : Copyright (C) 2010-2019 John MacFarlane
   License     : BSD 3

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : portable

A prettyprinting library for the production of text documents,
including wrapped text, indentation and other prefixes, and
blocks for tables.
-}

module Text.DocLayout (
     -- * Rendering
       render
     -- * Doc constructors
     , 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
     -- * Functions for concatenating documents
     , (<+>)
     , ($$)
     , ($+$)
     , hcat
     , hsep
     , vcat
     , vsep
     -- * Functions for querying documents
     , isEmpty
     , offset
     , minOffset
     , updateColumn
     , height
     , charWidth
     , realLength
     , realLengthNarrowContext
     , realLengthWideContext
     , realLengthNarrowContextNoShortcut
     , realLengthWideContextNoShortcut
     -- * Char properties
     , isSkinToneModifier
     , isEmojiVariation
     , isZWJ
     -- * Utility functions
     , unfoldD
     -- * Types
     , Doc(..)
     , HasChars(..)
     )

where
import Prelude
import Data.Maybe (fromMaybe, isJust, mapMaybe)
import Safe (lastMay, initSafe)
import Control.Monad
import Control.Monad.State.Strict
import GHC.Generics
import Data.Bifunctor (second)
import Data.Char (isSpace, ord)
import Data.List (foldl', intersperse)
import qualified Data.IntMap.Strict as IM
import qualified Data.Map.Strict as M
import qualified Data.Map.Internal as MInt
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
import Text.Emoji (baseEmojis)


-- | Class abstracting over various string types that
-- can fold over characters.  Minimal definition is 'foldrChar'
-- and 'foldlChar', but defining the other methods can give better
-- performance.
class (IsString a, Semigroup a, Monoid a, Show a) => HasChars a where
  foldrChar     :: (Char -> b -> b) -> b -> a -> b
  foldlChar     :: (b -> Char -> b) -> b -> a -> b
  replicateChar :: Int -> Char -> a
  replicateChar Int
n Char
c = forall a. IsString a => String -> a
fromString (forall a. Int -> a -> [a]
replicate Int
n Char
c)
  isNull        :: a -> Bool
  isNull = forall a b. HasChars a => (Char -> b -> b) -> b -> a -> b
foldrChar (\Char
_ Bool
_ -> Bool
False) Bool
True
  splitLines    :: a -> [a]
  splitLines a
s = (forall a. IsString a => String -> a
fromString String
firstline forall a. a -> [a] -> [a]
: [a]
otherlines)
   where
    (String
firstline, [a]
otherlines) = forall a b. HasChars a => (Char -> b -> b) -> b -> a -> b
foldrChar forall {a}. IsString a => Char -> (String, [a]) -> (String, [a])
go ([],[]) a
s
    go :: Char -> (String, [a]) -> (String, [a])
go Char
'\n' (String
cur,[a]
lns) = ([], forall a. IsString a => String -> a
fromString String
cur forall a. a -> [a] -> [a]
: [a]
lns)
    go Char
c    (String
cur,[a]
lns) = (Char
cforall a. a -> [a] -> [a]
:String
cur, [a]
lns)

instance HasChars Text where
  foldrChar :: forall b. (Char -> b -> b) -> b -> Text -> b
foldrChar         = forall b. (Char -> b -> b) -> b -> Text -> b
T.foldr
  foldlChar :: forall b. (b -> Char -> b) -> b -> Text -> b
foldlChar         = forall b. (b -> Char -> b) -> b -> Text -> b
T.foldl'
  splitLines :: Text -> [Text]
splitLines        = Text -> Text -> [Text]
T.splitOn Text
"\n"
  replicateChar :: Int -> Char -> Text
replicateChar Int
n Char
c = Int -> Text -> Text
T.replicate Int
n (Char -> Text
T.singleton Char
c)
  isNull :: Text -> Bool
isNull            = Text -> Bool
T.null

instance HasChars String where
  foldrChar :: forall b. (Char -> b -> b) -> b -> String -> b
foldrChar     = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
  foldlChar :: forall b. (b -> Char -> b) -> b -> String -> b
foldlChar     = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
  splitLines :: String -> [String]
splitLines    = String -> [String]
lines forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
++String
"\n")
  replicateChar :: Int -> Char -> String
replicateChar = forall a. Int -> a -> [a]
replicate
  isNull :: String -> Bool
isNull        = forall (t :: * -> *) a. Foldable t => t a -> Bool
null

instance HasChars TL.Text where
  foldrChar :: forall b. (Char -> b -> b) -> b -> Text -> b
foldrChar         = forall b. (Char -> b -> b) -> b -> Text -> b
TL.foldr
  foldlChar :: forall b. (b -> Char -> b) -> b -> Text -> b
foldlChar         = forall b. (b -> Char -> b) -> b -> Text -> b
TL.foldl'
  splitLines :: Text -> [Text]
splitLines        = Text -> Text -> [Text]
TL.splitOn Text
"\n"
  replicateChar :: Int -> Char -> Text
replicateChar Int
n Char
c = Int64 -> Text -> Text
TL.replicate (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n) (Char -> Text
TL.singleton Char
c)
  isNull :: Text -> Bool
isNull            = Text -> Bool
TL.null

-- | Document, including structure relevant for layout.
data Doc a = Text Int a            -- ^ Text with specified width.
         | Block Int [a]           -- ^ A block with a width and lines.
         | VFill Int a             -- ^ A vertically expandable block;
                 -- when concatenated with a block, expands to height
                 -- of block, with each line containing the specified text.
         | Prefixed Text (Doc a)   -- ^ Doc with each line prefixed with text.
                 -- Note that trailing blanks are omitted from the prefix
                 -- when the line after it is empty.
         | BeforeNonBlank (Doc a)  -- ^ Doc that renders only before nonblank.
         | Flush (Doc a)           -- ^ Doc laid out flush to left margin.
         | BreakingSpace           -- ^ A space or line break, in context.
         | AfterBreak Text         -- ^ Text printed only at start of line.
         | CarriageReturn          -- ^ Newline unless we're at start of line.
         | NewLine                 -- ^ newline.
         | BlankLines Int          -- ^ Ensure a number of blank lines.
         | Concat (Doc a) (Doc a)  -- ^ Two documents concatenated.
         | Empty
         deriving (Int -> Doc a -> String -> String
forall a. Show a => Int -> Doc a -> String -> String
forall a. Show a => [Doc a] -> String -> String
forall a. Show a => Doc a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Doc a] -> String -> String
$cshowList :: forall a. Show a => [Doc a] -> String -> String
show :: Doc a -> String
$cshow :: forall a. Show a => Doc a -> String
showsPrec :: Int -> Doc a -> String -> String
$cshowsPrec :: forall a. Show a => Int -> Doc a -> String -> String
Show, ReadPrec [Doc a]
ReadPrec (Doc a)
ReadS [Doc a]
forall a. Read a => ReadPrec [Doc a]
forall a. Read a => ReadPrec (Doc a)
forall a. Read a => Int -> ReadS (Doc a)
forall a. Read a => ReadS [Doc a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Doc a]
$creadListPrec :: forall a. Read a => ReadPrec [Doc a]
readPrec :: ReadPrec (Doc a)
$creadPrec :: forall a. Read a => ReadPrec (Doc a)
readList :: ReadS [Doc a]
$creadList :: forall a. Read a => ReadS [Doc a]
readsPrec :: Int -> ReadS (Doc a)
$creadsPrec :: forall a. Read a => Int -> ReadS (Doc a)
Read, Doc a -> Doc a -> Bool
forall a. Eq a => Doc a -> Doc a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Doc a -> Doc a -> Bool
$c/= :: forall a. Eq a => Doc a -> Doc a -> Bool
== :: Doc a -> Doc a -> Bool
$c== :: forall a. Eq a => Doc a -> Doc a -> Bool
Eq, Doc a -> Doc a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Doc a)
forall a. Ord a => Doc a -> Doc a -> Bool
forall a. Ord a => Doc a -> Doc a -> Ordering
forall a. Ord a => Doc a -> Doc a -> Doc a
min :: Doc a -> Doc a -> Doc a
$cmin :: forall a. Ord a => Doc a -> Doc a -> Doc a
max :: Doc a -> Doc a -> Doc a
$cmax :: forall a. Ord a => Doc a -> Doc a -> Doc a
>= :: Doc a -> Doc a -> Bool
$c>= :: forall a. Ord a => Doc a -> Doc a -> Bool
> :: Doc a -> Doc a -> Bool
$c> :: forall a. Ord a => Doc a -> Doc a -> Bool
<= :: Doc a -> Doc a -> Bool
$c<= :: forall a. Ord a => Doc a -> Doc a -> Bool
< :: Doc a -> Doc a -> Bool
$c< :: forall a. Ord a => Doc a -> Doc a -> Bool
compare :: Doc a -> Doc a -> Ordering
$ccompare :: forall a. Ord a => Doc a -> Doc a -> Ordering
Ord, forall a b. a -> Doc b -> Doc a
forall a b. (a -> b) -> Doc a -> Doc b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Doc b -> Doc a
$c<$ :: forall a b. a -> Doc b -> Doc a
fmap :: forall a b. (a -> b) -> Doc a -> Doc b
$cfmap :: forall a b. (a -> b) -> Doc a -> Doc b
Functor, forall a. Eq a => a -> Doc a -> Bool
forall a. Num a => Doc a -> a
forall a. Ord a => Doc a -> a
forall m. Monoid m => Doc m -> m
forall a. Doc a -> Bool
forall a. Doc a -> Int
forall a. Doc a -> [a]
forall a. (a -> a -> a) -> Doc a -> a
forall m a. Monoid m => (a -> m) -> Doc a -> m
forall b a. (b -> a -> b) -> b -> Doc a -> b
forall a b. (a -> b -> b) -> b -> Doc a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Doc a -> a
$cproduct :: forall a. Num a => Doc a -> a
sum :: forall a. Num a => Doc a -> a
$csum :: forall a. Num a => Doc a -> a
minimum :: forall a. Ord a => Doc a -> a
$cminimum :: forall a. Ord a => Doc a -> a
maximum :: forall a. Ord a => Doc a -> a
$cmaximum :: forall a. Ord a => Doc a -> a
elem :: forall a. Eq a => a -> Doc a -> Bool
$celem :: forall a. Eq a => a -> Doc a -> Bool
length :: forall a. Doc a -> Int
$clength :: forall a. Doc a -> Int
null :: forall a. Doc a -> Bool
$cnull :: forall a. Doc a -> Bool
toList :: forall a. Doc a -> [a]
$ctoList :: forall a. Doc a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Doc a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Doc a -> a
foldr1 :: forall a. (a -> a -> a) -> Doc a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Doc a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Doc a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Doc a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Doc a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Doc a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Doc a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Doc a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Doc a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Doc a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Doc a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Doc a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Doc a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Doc a -> m
fold :: forall m. Monoid m => Doc m -> m
$cfold :: forall m. Monoid m => Doc m -> m
Foldable, Functor Doc
Foldable Doc
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => Doc (m a) -> m (Doc a)
forall (f :: * -> *) a. Applicative f => Doc (f a) -> f (Doc a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Doc a -> m (Doc b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Doc a -> f (Doc b)
sequence :: forall (m :: * -> *) a. Monad m => Doc (m a) -> m (Doc a)
$csequence :: forall (m :: * -> *) a. Monad m => Doc (m a) -> m (Doc a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Doc a -> m (Doc b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Doc a -> m (Doc b)
sequenceA :: forall (f :: * -> *) a. Applicative f => Doc (f a) -> f (Doc a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Doc (f a) -> f (Doc a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Doc a -> f (Doc b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Doc a -> f (Doc b)
Traversable,
                  Doc a -> DataType
Doc a -> Constr
forall {a}. Data a => Typeable (Doc a)
forall a. Data a => Doc a -> DataType
forall a. Data a => Doc a -> Constr
forall a. Data a => (forall b. Data b => b -> b) -> Doc a -> Doc a
forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Doc a -> u
forall a u. Data a => (forall d. Data d => d -> u) -> Doc a -> [u]
forall a r r'.
Data a =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Doc a -> r
forall a r r'.
Data a =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Doc a -> r
forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Doc a -> m (Doc a)
forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Doc a -> m (Doc a)
forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Doc a)
forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Doc a -> c (Doc a)
forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Doc a))
forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Doc a))
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Doc a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Doc a -> c (Doc a)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Doc a))
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Doc a -> m (Doc a)
$cgmapMo :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Doc a -> m (Doc a)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Doc a -> m (Doc a)
$cgmapMp :: forall a (m :: * -> *).
(Data a, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Doc a -> m (Doc a)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Doc a -> m (Doc a)
$cgmapM :: forall a (m :: * -> *).
(Data a, Monad m) =>
(forall d. Data d => d -> m d) -> Doc a -> m (Doc a)
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Doc a -> u
$cgmapQi :: forall a u.
Data a =>
Int -> (forall d. Data d => d -> u) -> Doc a -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Doc a -> [u]
$cgmapQ :: forall a u. Data a => (forall d. Data d => d -> u) -> Doc a -> [u]
gmapQr :: forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Doc a -> r
$cgmapQr :: forall a r r'.
Data a =>
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Doc a -> r
gmapQl :: forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Doc a -> r
$cgmapQl :: forall a r r'.
Data a =>
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Doc a -> r
gmapT :: (forall b. Data b => b -> b) -> Doc a -> Doc a
$cgmapT :: forall a. Data a => (forall b. Data b => b -> b) -> Doc a -> Doc a
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Doc a))
$cdataCast2 :: forall a (t :: * -> * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Doc a))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Doc a))
$cdataCast1 :: forall a (t :: * -> *) (c :: * -> *).
(Data a, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Doc a))
dataTypeOf :: Doc a -> DataType
$cdataTypeOf :: forall a. Data a => Doc a -> DataType
toConstr :: Doc a -> Constr
$ctoConstr :: forall a. Data a => Doc a -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Doc a)
$cgunfold :: forall a (c :: * -> *).
Data a =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Doc a)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Doc a -> c (Doc a)
$cgfoldl :: forall a (c :: * -> *).
Data a =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Doc a -> c (Doc a)
Data, Typeable, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Doc a) x -> Doc a
forall a x. Doc a -> Rep (Doc a) x
$cto :: forall a x. Rep (Doc a) x -> Doc a
$cfrom :: forall a x. Doc a -> Rep (Doc a) x
Generic)

instance Semigroup (Doc a) where
  Doc a
x <> :: Doc a -> Doc a -> Doc a
<> Doc a
Empty = Doc a
x
  Doc a
Empty <> Doc a
x = Doc a
x
  Doc a
x <> Doc a
y     = forall a. Doc a -> Doc a -> Doc a
Concat Doc a
x Doc a
y

instance Monoid (Doc a) where
  mappend :: Doc a -> Doc a -> Doc a
mappend = forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: Doc a
mempty = forall a. Doc a
Empty

instance HasChars a => IsString (Doc a) where
  fromString :: String -> Doc a
fromString = forall a. HasChars a => String -> Doc a
text

-- | Unfold a 'Doc' into a flat list.
unfoldD :: Doc a -> [Doc a]
unfoldD :: forall a. Doc a -> [Doc a]
unfoldD Doc a
Empty = []
unfoldD (Concat x :: Doc a
x@Concat{} Doc a
y) = forall a. Doc a -> [Doc a]
unfoldD Doc a
x forall a. Semigroup a => a -> a -> a
<> forall a. Doc a -> [Doc a]
unfoldD Doc a
y
unfoldD (Concat Doc a
x Doc a
y)          = Doc a
x forall a. a -> [a] -> [a]
: forall a. Doc a -> [Doc a]
unfoldD Doc a
y
unfoldD Doc a
x                     = [Doc a
x]

-- | True if the document is empty.
isEmpty :: Doc a -> Bool
isEmpty :: forall a. Doc a -> Bool
isEmpty Doc a
Empty = Bool
True
isEmpty Doc a
_     = Bool
False

-- | The empty document.
empty :: Doc a
empty :: forall a. Doc a
empty = forall a. Monoid a => a
mempty

-- | Concatenate documents horizontally.
hcat :: [Doc a] -> Doc a
hcat :: forall a. [Doc a] -> Doc a
hcat = forall a. Monoid a => [a] -> a
mconcat

-- | Concatenate a list of 'Doc's, putting breakable spaces
-- between them.
infixr 6 <+>
(<+>) :: Doc a -> Doc a -> Doc a
<+> :: forall a. Doc a -> Doc a -> Doc a
(<+>) Doc a
x Doc a
y
  | forall a. Doc a -> Bool
isEmpty Doc a
x = Doc a
y
  | forall a. Doc a -> Bool
isEmpty Doc a
y = Doc a
x
  | Bool
otherwise = Doc a
x forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
space forall a. Semigroup a => a -> a -> a
<> Doc a
y

-- | Same as 'hcat', but putting breakable spaces between the
-- 'Doc's.
hsep :: [Doc a] -> Doc a
hsep :: forall a. [Doc a] -> Doc a
hsep = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Doc a -> Doc a -> Doc a
(<+>) forall a. Doc a
empty

infixr 5 $$
-- | @a $$ b@ puts @a@ above @b@.
($$) :: Doc a -> Doc a -> Doc a
$$ :: forall a. Doc a -> Doc a -> Doc a
($$) Doc a
x Doc a
y
  | forall a. Doc a -> Bool
isEmpty Doc a
x = Doc a
y
  | forall a. Doc a -> Bool
isEmpty Doc a
y = Doc a
x
  | Bool
otherwise = Doc a
x forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
cr forall a. Semigroup a => a -> a -> a
<> Doc a
y

infixr 5 $+$
-- | @a $+$ b@ puts @a@ above @b@, with a blank line between.
($+$) :: Doc a -> Doc a -> Doc a
$+$ :: forall a. Doc a -> Doc a -> Doc a
($+$) Doc a
x Doc a
y
  | forall a. Doc a -> Bool
isEmpty Doc a
x = Doc a
y
  | forall a. Doc a -> Bool
isEmpty Doc a
y = Doc a
x
  | Bool
otherwise = Doc a
x forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
blankline forall a. Semigroup a => a -> a -> a
<> Doc a
y

-- | List version of '$$'.
vcat :: [Doc a] -> Doc a
vcat :: forall a. [Doc a] -> Doc a
vcat = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Doc a -> Doc a -> Doc a
($$) forall a. Doc a
empty

-- | List version of '$+$'.
vsep :: [Doc a] -> Doc a
vsep :: forall a. [Doc a] -> Doc a
vsep = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a. Doc a -> Doc a -> Doc a
($+$) forall a. Doc a
empty

-- | Removes leading blank lines from a 'Doc'.
nestle :: Doc a -> Doc a
nestle :: forall a. Doc a -> Doc a
nestle Doc a
d =
  case Doc a
d of
    BlankLines Int
_              -> forall a. Doc a
Empty
    Doc a
NewLine                   -> forall a. Doc a
Empty
    Concat (Concat Doc a
x Doc a
y) Doc a
z     -> forall a. Doc a -> Doc a
nestle (forall a. Doc a -> Doc a -> Doc a
Concat Doc a
x (forall a. Doc a -> Doc a -> Doc a
Concat Doc a
y Doc a
z))
    Concat BlankLines{} Doc a
x     -> forall a. Doc a -> Doc a
nestle Doc a
x
    Concat Doc a
NewLine Doc a
x          -> forall a. Doc a -> Doc a
nestle Doc a
x
    Doc a
_                         -> Doc a
d

-- | Chomps trailing blank space off of a 'Doc'.
chomp :: Doc a -> Doc a
chomp :: forall a. Doc a -> Doc a
chomp Doc a
d =
    case Doc a
d of
    BlankLines Int
_              -> forall a. Doc a
Empty
    Doc a
NewLine                   -> forall a. Doc a
Empty
    Doc a
CarriageReturn            -> forall a. Doc a
Empty
    Doc a
BreakingSpace             -> forall a. Doc a
Empty
    Prefixed Text
s Doc a
d'             -> forall a. Text -> Doc a -> Doc a
Prefixed Text
s (forall a. Doc a -> Doc a
chomp Doc a
d')
    Concat (Concat Doc a
x Doc a
y) Doc a
z     -> forall a. Doc a -> Doc a
chomp (forall a. Doc a -> Doc a -> Doc a
Concat Doc a
x (forall a. Doc a -> Doc a -> Doc a
Concat Doc a
y Doc a
z))
    Concat Doc a
x Doc a
y                ->
        case forall a. Doc a -> Doc a
chomp Doc a
y of
          Doc a
Empty -> forall a. Doc a -> Doc a
chomp Doc a
x
          Doc a
z     -> Doc a
x forall a. Semigroup a => a -> a -> a
<> Doc a
z
    Doc a
_                         -> Doc a
d

type DocState a = State (RenderState a) ()

data RenderState a = RenderState{
         forall a. RenderState a -> [a]
output     :: [a]        -- ^ In reverse order
       , forall a. RenderState a -> Text
prefix     :: Text
       , forall a. RenderState a -> Bool
usePrefix  :: Bool
       , forall a. RenderState a -> Maybe Int
lineLength :: Maybe Int  -- ^ 'Nothing' means no wrapping
       , forall a. RenderState a -> Int
column     :: Int
       , forall a. RenderState a -> Int
newlines   :: Int        -- ^ Number of preceding newlines
       }

newline :: HasChars a => DocState a
newline :: forall a. HasChars a => DocState a
newline = do
  RenderState a
st' <- forall s (m :: * -> *). MonadState s m => m s
get
  let rawpref :: Text
rawpref = forall a. RenderState a -> Text
prefix RenderState a
st'
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. RenderState a -> Int
column RenderState a
st' forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& forall a. RenderState a -> Bool
usePrefix RenderState a
st' Bool -> Bool -> Bool
&& Bool -> Bool
not (Text -> Bool
T.null Text
rawpref)) forall a b. (a -> b) -> a -> b
$ do
     let pref :: a
pref = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isSpace Text
rawpref
     forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \RenderState a
st -> RenderState a
st{ output :: [a]
output = a
pref forall a. a -> [a] -> [a]
: forall a. RenderState a -> [a]
output RenderState a
st
                       , column :: Int
column = forall a. RenderState a -> Int
column RenderState a
st forall a. Num a => a -> a -> a
+ forall a. HasChars a => a -> Int
realLength a
pref }
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \RenderState a
st -> RenderState a
st { output :: [a]
output = a
"\n" forall a. a -> [a] -> [a]
: forall a. RenderState a -> [a]
output RenderState a
st
                     , column :: Int
column = Int
0
                     , newlines :: Int
newlines = forall a. RenderState a -> Int
newlines RenderState a
st forall a. Num a => a -> a -> a
+ Int
1
                     }

outp :: HasChars a => Int -> a -> DocState a
outp :: forall a. HasChars a => Int -> a -> DocState a
outp Int
off a
s = do           -- offset >= 0 (0 might be combining char)
  RenderState a
st' <- forall s (m :: * -> *). MonadState s m => m s
get
  let pref :: a
pref = forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall a. RenderState a -> Text
prefix RenderState a
st'
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. RenderState a -> Int
column RenderState a
st' forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& forall a. RenderState a -> Bool
usePrefix RenderState a
st' Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. HasChars a => a -> Bool
isNull a
pref)) forall a b. (a -> b) -> a -> b
$
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \RenderState a
st -> RenderState a
st{ output :: [a]
output = a
pref forall a. a -> [a] -> [a]
: forall a. RenderState a -> [a]
output RenderState a
st
                    , column :: Int
column = forall a. RenderState a -> Int
column RenderState a
st forall a. Num a => a -> a -> a
+ forall a. HasChars a => a -> Int
realLength a
pref }
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \RenderState a
st -> RenderState a
st{ output :: [a]
output = a
s forall a. a -> [a] -> [a]
: forall a. RenderState a -> [a]
output RenderState a
st
                    , column :: Int
column = forall a. RenderState a -> Int
column RenderState a
st forall a. Num a => a -> a -> a
+ Int
off
                    , newlines :: Int
newlines = Int
0 }

-- | Render a 'Doc'.  @render (Just n)@ will use
-- a line length of @n@ to reflow text on breakable spaces.
-- @render Nothing@ will not reflow text.
render :: HasChars a => Maybe Int -> Doc a -> a
render :: forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
linelen Doc a
doc = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. RenderState a -> [a]
output forall a b. (a -> b) -> a -> b
$
  forall s a. State s a -> s -> s
execState (forall a. HasChars a => Doc a -> DocState a
renderDoc Doc a
doc) forall {a}. RenderState a
startingState
   where startingState :: RenderState a
startingState = RenderState{
                            output :: [a]
output = forall a. Monoid a => a
mempty
                          , prefix :: Text
prefix = forall a. Monoid a => a
mempty
                          , usePrefix :: Bool
usePrefix = Bool
True
                          , lineLength :: Maybe Int
lineLength = Maybe Int
linelen
                          , column :: Int
column = Int
0
                          , newlines :: Int
newlines = Int
2 }

renderDoc :: HasChars a => Doc a -> DocState a
renderDoc :: forall a. HasChars a => Doc a -> DocState a
renderDoc = forall a. HasChars a => [Doc a] -> DocState a
renderList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasChars a => [Doc a] -> [Doc a]
normalize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> [Doc a]
unfoldD


normalize :: HasChars a => [Doc a] -> [Doc a]
normalize :: forall a. HasChars a => [Doc a] -> [Doc a]
normalize [] = []
normalize (Concat{} : [Doc a]
xs) = forall a. HasChars a => [Doc a] -> [Doc a]
normalize [Doc a]
xs -- should not happen after unfoldD
normalize (Doc a
Empty : [Doc a]
xs) = forall a. HasChars a => [Doc a] -> [Doc a]
normalize [Doc a]
xs -- should not happen after unfoldD
normalize [Doc a
NewLine] = forall a. HasChars a => [Doc a] -> [Doc a]
normalize [forall a. Doc a
CarriageReturn]
normalize [BlankLines Int
_] = forall a. HasChars a => [Doc a] -> [Doc a]
normalize [forall a. Doc a
CarriageReturn]
normalize [Doc a
BreakingSpace] = []
normalize (BlankLines Int
m : BlankLines Int
n : [Doc a]
xs) =
  forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Int -> Doc a
BlankLines (forall a. Ord a => a -> a -> a
max Int
m Int
n) forall a. a -> [a] -> [a]
: [Doc a]
xs)
normalize (BlankLines Int
num : Doc a
BreakingSpace : [Doc a]
xs) =
  forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Int -> Doc a
BlankLines Int
num forall a. a -> [a] -> [a]
: [Doc a]
xs)
normalize (BlankLines Int
m : Doc a
CarriageReturn : [Doc a]
xs) = forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Int -> Doc a
BlankLines Int
m forall a. a -> [a] -> [a]
: [Doc a]
xs)
normalize (BlankLines Int
m : Doc a
NewLine : [Doc a]
xs) = forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Int -> Doc a
BlankLines Int
m forall a. a -> [a] -> [a]
: [Doc a]
xs)
normalize (Doc a
NewLine : BlankLines Int
m : [Doc a]
xs) = forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Int -> Doc a
BlankLines Int
m forall a. a -> [a] -> [a]
: [Doc a]
xs)
normalize (Doc a
NewLine : Doc a
BreakingSpace : [Doc a]
xs) = forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Doc a
NewLine forall a. a -> [a] -> [a]
: [Doc a]
xs)
normalize (Doc a
NewLine : Doc a
CarriageReturn : [Doc a]
xs) = forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Doc a
NewLine forall a. a -> [a] -> [a]
: [Doc a]
xs)
normalize (Doc a
CarriageReturn : Doc a
CarriageReturn : [Doc a]
xs) =
  forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Doc a
CarriageReturn forall a. a -> [a] -> [a]
: [Doc a]
xs)
normalize (Doc a
CarriageReturn : BlankLines Int
m : [Doc a]
xs) = forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Int -> Doc a
BlankLines Int
m forall a. a -> [a] -> [a]
: [Doc a]
xs)
normalize (Doc a
CarriageReturn : Doc a
BreakingSpace : [Doc a]
xs) =
  forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Doc a
CarriageReturn forall a. a -> [a] -> [a]
: [Doc a]
xs)
normalize (Doc a
BreakingSpace : Doc a
CarriageReturn : [Doc a]
xs) =
  forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Doc a
CarriageReturnforall a. a -> [a] -> [a]
:[Doc a]
xs)
normalize (Doc a
BreakingSpace : Doc a
NewLine : [Doc a]
xs) = forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Doc a
NewLineforall a. a -> [a] -> [a]
:[Doc a]
xs)
normalize (Doc a
BreakingSpace : BlankLines Int
n : [Doc a]
xs) = forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Int -> Doc a
BlankLines Int
nforall a. a -> [a] -> [a]
:[Doc a]
xs)
normalize (Doc a
BreakingSpace : Doc a
BreakingSpace : [Doc a]
xs) = forall a. HasChars a => [Doc a] -> [Doc a]
normalize (forall a. Doc a
BreakingSpaceforall a. a -> [a] -> [a]
:[Doc a]
xs)
normalize (Doc a
x:[Doc a]
xs) = Doc a
x forall a. a -> [a] -> [a]
: forall a. HasChars a => [Doc a] -> [Doc a]
normalize [Doc a]
xs

mergeBlocks :: HasChars a => Int -> (Int, [a]) -> (Int, [a]) -> (Int, [a])
mergeBlocks :: forall a.
HasChars a =>
Int -> (Int, [a]) -> (Int, [a]) -> (Int, [a])
mergeBlocks Int
h (Int
w1,[a]
lns1) (Int
w2,[a]
lns2) =
  (Int
w, forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\a
l1 a
l2 -> forall {a}. HasChars a => Int -> a -> a
pad Int
w1 a
l1 forall a. Semigroup a => a -> a -> a
<> a
l2) [a]
lns1' [a]
lns2')
 where
  w :: Int
w  = Int
w1 forall a. Num a => a -> a -> a
+ Int
w2
  len1 :: Int
len1 = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
h [a]
lns1  -- note lns1 might be infinite
  len2 :: Int
len2 = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
h [a]
lns2
  lns1' :: [a]
lns1' = if Int
len1 forall a. Ord a => a -> a -> Bool
< Int
h
             then [a]
lns1 forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
h forall a. Num a => a -> a -> a
- Int
len1) forall a. Monoid a => a
mempty
             else forall a. Int -> [a] -> [a]
take Int
h [a]
lns1
  lns2' :: [a]
lns2' = if Int
len2 forall a. Ord a => a -> a -> Bool
< Int
h
             then [a]
lns2 forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
h forall a. Num a => a -> a -> a
- Int
len2) forall a. Monoid a => a
mempty
             else forall a. Int -> [a] -> [a]
take Int
h [a]
lns2
  pad :: Int -> a -> a
pad Int
n a
s = a
s forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Int -> Char -> a
replicateChar (Int
n forall a. Num a => a -> a -> a
- forall a. HasChars a => a -> Int
realLength a
s) Char
' '

renderList :: HasChars a => [Doc a] -> DocState a
renderList :: forall a. HasChars a => [Doc a] -> DocState a
renderList [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()

renderList (Doc a
Empty : [Doc a]
xs) = forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs

renderList (Text Int
off a
s : [Doc a]
xs) = do
  forall a. HasChars a => Int -> a -> DocState a
outp Int
off a
s
  forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs

renderList (Prefixed Text
pref Doc a
d : [Doc a]
xs) = do
  RenderState a
st <- forall s (m :: * -> *). MonadState s m => m s
get
  let oldPref :: Text
oldPref = forall a. RenderState a -> Text
prefix RenderState a
st
  forall s (m :: * -> *). MonadState s m => s -> m ()
put RenderState a
st{ prefix :: Text
prefix = forall a. RenderState a -> Text
prefix RenderState a
st forall a. Semigroup a => a -> a -> a
<> Text
pref }
  forall a. HasChars a => Doc a -> DocState a
renderDoc Doc a
d
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \RenderState a
s -> RenderState a
s{ prefix :: Text
prefix = Text
oldPref }
  -- renderDoc CarriageReturn
  forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs

renderList (Flush Doc a
d : [Doc a]
xs) = do
  RenderState a
st <- forall s (m :: * -> *). MonadState s m => m s
get
  let oldUsePrefix :: Bool
oldUsePrefix = forall a. RenderState a -> Bool
usePrefix RenderState a
st
  forall s (m :: * -> *). MonadState s m => s -> m ()
put RenderState a
st{ usePrefix :: Bool
usePrefix = Bool
False }
  forall a. HasChars a => Doc a -> DocState a
renderDoc Doc a
d
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \RenderState a
s -> RenderState a
s{ usePrefix :: Bool
usePrefix = Bool
oldUsePrefix }
  forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs

renderList (BeforeNonBlank Doc a
d : [Doc a]
xs) =
  case [Doc a]
xs of
    (Doc a
x:[Doc a]
_) | forall a. HasChars a => Doc a -> Bool
startsBlank Doc a
x -> forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs
          | Bool
otherwise     -> forall a. HasChars a => Doc a -> DocState a
renderDoc Doc a
d forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs
    []                    -> forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs
renderList (BlankLines Int
num : [Doc a]
xs) = do
  RenderState a
st <- forall s (m :: * -> *). MonadState s m => m s
get
  case forall a. RenderState a -> [a]
output RenderState a
st of
     [a]
_ | forall a. RenderState a -> Int
newlines RenderState a
st forall a. Ord a => a -> a -> Bool
> Int
num -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
       | Bool
otherwise -> forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (Int
1 forall a. Num a => a -> a -> a
+ Int
num forall a. Num a => a -> a -> a
- forall a. RenderState a -> Int
newlines RenderState a
st) forall a. HasChars a => DocState a
newline
  forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs

renderList (Doc a
CarriageReturn : [Doc a]
xs) = do
  RenderState a
st <- forall s (m :: * -> *). MonadState s m => m s
get
  if forall a. RenderState a -> Int
newlines RenderState a
st forall a. Ord a => a -> a -> Bool
> Int
0
     then forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs
     else do
       forall a. HasChars a => DocState a
newline
       forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs

renderList (Doc a
NewLine : [Doc a]
xs) = do
  forall a. HasChars a => DocState a
newline
  forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs

renderList (Doc a
BreakingSpace : [Doc a]
xs) = do
  let isBreakingSpace :: Doc a -> Bool
isBreakingSpace Doc a
BreakingSpace = Bool
True
      isBreakingSpace Doc a
_ = Bool
False
  let xs' :: [Doc a]
xs' = forall a. (a -> Bool) -> [a] -> [a]
dropWhile forall a. Doc a -> Bool
isBreakingSpace [Doc a]
xs
  let next :: [Doc a]
next = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasChars a => Doc a -> Bool
isBreakable) [Doc a]
xs'
  RenderState a
st <- forall s (m :: * -> *). MonadState s m => m s
get
  let off :: Int
off = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Int
tot Doc a
t -> Int
tot forall a. Num a => a -> a -> a
+ forall a. Doc a -> Int
offsetOf Doc a
t) Int
0 [Doc a]
next
  case forall a. RenderState a -> Maybe Int
lineLength RenderState a
st of
        Just Int
l | forall a. RenderState a -> Int
column RenderState a
st forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
+ Int
off forall a. Ord a => a -> a -> Bool
> Int
l -> forall a. HasChars a => DocState a
newline
        Maybe Int
_  -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. RenderState a -> Int
column RenderState a
st forall a. Ord a => a -> a -> Bool
> Int
0) forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => Int -> a -> DocState a
outp Int
1 a
" "
  forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs'

renderList (AfterBreak Text
t : [Doc a]
xs) = do
  RenderState a
st <- forall s (m :: * -> *). MonadState s m => m s
get
  if forall a. RenderState a -> Int
newlines RenderState a
st forall a. Ord a => a -> a -> Bool
> Int
0
     then forall a. HasChars a => [Doc a] -> DocState a
renderList (forall a. IsString a => String -> a
fromString (Text -> String
T.unpack Text
t) forall a. a -> [a] -> [a]
: [Doc a]
xs)
     else forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
xs

renderList (Doc a
b : [Doc a]
xs) | forall a. Doc a -> Bool
isBlock Doc a
b = do
  let ([Doc a]
bs, [Doc a]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span forall a. Doc a -> Bool
isBlock [Doc a]
xs
  -- ensure we have right padding unless end of line
  let heightOf :: Doc a -> Int
heightOf (Block Int
_ [a]
ls) = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
ls
      heightOf Doc a
_            = Int
1
  let maxheight :: Int
maxheight = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Doc a -> Int
heightOf (Doc a
bforall a. a -> [a] -> [a]
:[Doc a]
bs)
  let toBlockSpec :: Doc a -> (Int, [a])
toBlockSpec (Block Int
w [a]
ls) = (Int
w, [a]
ls)
      toBlockSpec (VFill Int
w a
t)  = (Int
w, forall a. Int -> [a] -> [a]
take Int
maxheight forall a b. (a -> b) -> a -> b
$ forall a. a -> [a]
repeat a
t)
      toBlockSpec Doc a
_            = (Int
0, [])
  let (Int
_, [a]
lns') = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (forall a.
HasChars a =>
Int -> (Int, [a]) -> (Int, [a]) -> (Int, [a])
mergeBlocks Int
maxheight) (forall {a}. Doc a -> (Int, [a])
toBlockSpec Doc a
b)
                             (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Doc a -> (Int, [a])
toBlockSpec [Doc a]
bs)
  RenderState a
st <- forall s (m :: * -> *). MonadState s m => m s
get
  let oldPref :: Text
oldPref = forall a. RenderState a -> Text
prefix RenderState a
st
  case forall a. RenderState a -> Int
column RenderState a
st forall a. Num a => a -> a -> a
- forall a. HasChars a => a -> Int
realLength Text
oldPref of
        Int
n | Int
n forall a. Ord a => a -> a -> Bool
> Int
0 -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \RenderState a
s -> RenderState a
s{ prefix :: Text
prefix = Text
oldPref forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
n Text
" " }
        Int
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  forall a. HasChars a => [Doc a] -> DocState a
renderList forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse forall a. Doc a
CarriageReturn (forall a b. (a -> b) -> [a] -> [b]
map forall a. HasChars a => a -> Doc a
literal [a]
lns')
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \RenderState a
s -> RenderState a
s{ prefix :: Text
prefix = Text
oldPref }
  forall a. HasChars a => [Doc a] -> DocState a
renderList [Doc a]
rest

renderList (Doc a
x:[Doc a]
_) = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"renderList encountered " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Doc a
x

isBreakable :: HasChars a => Doc a -> Bool
isBreakable :: forall a. HasChars a => Doc a -> Bool
isBreakable Doc a
BreakingSpace      = Bool
True
isBreakable Doc a
CarriageReturn     = Bool
True
isBreakable Doc a
NewLine            = Bool
True
isBreakable (BlankLines Int
_)     = Bool
True
isBreakable (Concat Doc a
Empty Doc a
y)   = forall a. HasChars a => Doc a -> Bool
isBreakable Doc a
y
isBreakable (Concat Doc a
x Doc a
_)       = forall a. HasChars a => Doc a -> Bool
isBreakable Doc a
x
isBreakable Doc a
_                  = Bool
False

startsBlank' :: HasChars a => a -> Bool
startsBlank' :: forall a. HasChars a => a -> Bool
startsBlank' a
t = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ forall a b. HasChars a => (b -> Char -> b) -> b -> a -> b
foldlChar Maybe Bool -> Char -> Maybe Bool
go forall a. Maybe a
Nothing a
t
  where
   go :: Maybe Bool -> Char -> Maybe Bool
go Maybe Bool
Nothing  Char
c = forall a. a -> Maybe a
Just (Char -> Bool
isSpace Char
c)
   go (Just Bool
b) Char
_ = forall a. a -> Maybe a
Just Bool
b

startsBlank :: HasChars a => Doc a -> Bool
startsBlank :: forall a. HasChars a => Doc a -> Bool
startsBlank (Text Int
_ a
t)         = forall a. HasChars a => a -> Bool
startsBlank' a
t
startsBlank (Block Int
n [a]
ls)       = Int
n forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. HasChars a => a -> Bool
startsBlank' [a]
ls
startsBlank (VFill Int
n a
t)        = Int
n forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& forall a. HasChars a => a -> Bool
startsBlank' a
t
startsBlank (BeforeNonBlank Doc a
x) = forall a. HasChars a => Doc a -> Bool
startsBlank Doc a
x
startsBlank (Prefixed Text
_ Doc a
x)     = forall a. HasChars a => Doc a -> Bool
startsBlank Doc a
x
startsBlank (Flush Doc a
x)          = forall a. HasChars a => Doc a -> Bool
startsBlank Doc a
x
startsBlank Doc a
BreakingSpace      = Bool
True
startsBlank (AfterBreak Text
t)     = forall a. HasChars a => Doc a -> Bool
startsBlank (forall a. Int -> a -> Doc a
Text Int
0 Text
t)
startsBlank Doc a
CarriageReturn     = Bool
True
startsBlank Doc a
NewLine            = Bool
True
startsBlank (BlankLines Int
_)     = Bool
True
startsBlank (Concat Doc a
Empty Doc a
y)   = forall a. HasChars a => Doc a -> Bool
startsBlank Doc a
y
startsBlank (Concat Doc a
x Doc a
_)       = forall a. HasChars a => Doc a -> Bool
startsBlank Doc a
x
startsBlank Doc a
Empty              = Bool
True

isBlock :: Doc a -> Bool
isBlock :: forall a. Doc a -> Bool
isBlock Block{} = Bool
True
isBlock VFill{} = Bool
True
isBlock Doc a
_       = Bool
False

offsetOf :: Doc a -> Int
offsetOf :: forall a. Doc a -> Int
offsetOf (Text Int
o a
_)      = Int
o
offsetOf (Block Int
w [a]
_)     = Int
w
offsetOf (VFill Int
w a
_)     = Int
w
offsetOf Doc a
BreakingSpace   = Int
1
offsetOf Doc a
_               = Int
0

-- | Create a 'Doc' from a stringlike value.
literal :: HasChars a => a -> Doc a
literal :: forall a. HasChars a => a -> Doc a
literal a
x =
  forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
    forall a. a -> [a] -> [a]
intersperse forall a. Doc a
NewLine forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map (\a
s -> if forall a. HasChars a => a -> Bool
isNull a
s
                    then forall a. Doc a
Empty
                    else let !len :: Int
len = forall a. HasChars a => a -> Int
realLength a
s
                          in forall a. Int -> a -> Doc a
Text Int
len a
s) forall a b. (a -> b) -> a -> b
$
        forall a. HasChars a => a -> [a]
splitLines a
x
{-# NOINLINE literal #-}

-- | A literal string.  (Like 'literal', but restricted to String.)
text :: HasChars a => String -> Doc a
text :: forall a. HasChars a => String -> Doc a
text = forall a. HasChars a => a -> Doc a
literal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

-- | A character.
char :: HasChars a => Char -> Doc a
char :: forall a. HasChars a => Char -> Doc a
char Char
c = forall a. HasChars a => String -> Doc a
text forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString [Char
c]

-- | A breaking (reflowable) space.
space :: Doc a
space :: forall a. Doc a
space = forall a. Doc a
BreakingSpace

-- | A carriage return.  Does nothing if we're at the beginning of
-- a line; otherwise inserts a newline.
cr :: Doc a
cr :: forall a. Doc a
cr = forall a. Doc a
CarriageReturn

-- | Inserts a blank line unless one exists already.
-- (@blankline <> blankline@ has the same effect as @blankline@.
blankline :: Doc a
blankline :: forall a. Doc a
blankline = forall a. Int -> Doc a
BlankLines Int
1

-- | Inserts blank lines unless they exist already.
-- (@blanklines m <> blanklines n@ has the same effect as @blanklines (max m n)@.
blanklines :: Int -> Doc a
blanklines :: forall a. Int -> Doc a
blanklines = forall a. Int -> Doc a
BlankLines

-- | Uses the specified string as a prefix for every line of
-- the inside document (except the first, if not at the beginning
-- of the line).
prefixed :: IsString a => String -> Doc a -> Doc a
prefixed :: forall a. IsString a => String -> Doc a -> Doc a
prefixed String
pref Doc a
doc
  | forall a. Doc a -> Bool
isEmpty Doc a
doc = forall a. Doc a
Empty
  | Bool
otherwise   = forall a. Text -> Doc a -> Doc a
Prefixed (forall a. IsString a => String -> a
fromString String
pref) Doc a
doc

-- | Makes a 'Doc' flush against the left margin.
flush :: Doc a -> Doc a
flush :: forall a. Doc a -> Doc a
flush Doc a
doc
  | forall a. Doc a -> Bool
isEmpty Doc a
doc = forall a. Doc a
Empty
  | Bool
otherwise   = forall a. Doc a -> Doc a
Flush Doc a
doc

-- | Indents a 'Doc' by the specified number of spaces.
nest :: IsString a => Int -> Doc a -> Doc a
nest :: forall a. IsString a => Int -> Doc a -> Doc a
nest Int
ind = forall a. IsString a => String -> Doc a -> Doc a
prefixed (forall a. Int -> a -> [a]
replicate Int
ind Char
' ')

-- | A hanging indent. @hang ind start doc@ prints @start@,
-- then @doc@, leaving an indent of @ind@ spaces on every
-- line but the first.
hang :: IsString a => Int -> Doc a -> Doc a -> Doc a
hang :: forall a. IsString a => Int -> Doc a -> Doc a -> Doc a
hang Int
ind Doc a
start Doc a
doc = Doc a
start forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => Int -> Doc a -> Doc a
nest Int
ind Doc a
doc

-- | @beforeNonBlank d@ conditionally includes @d@ unless it is
-- followed by blank space.
beforeNonBlank :: Doc a -> Doc a
beforeNonBlank :: forall a. Doc a -> Doc a
beforeNonBlank = forall a. Doc a -> Doc a
BeforeNonBlank

-- | Makes a 'Doc' non-reflowable.
nowrap :: IsString a => Doc a -> Doc a
nowrap :: forall a. IsString a => Doc a -> Doc a
nowrap = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. IsString a => Doc a -> Doc a
replaceSpace forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> [Doc a]
unfoldD
  where replaceSpace :: Doc a -> Doc a
replaceSpace Doc a
BreakingSpace = forall a. Int -> a -> Doc a
Text Int
1 forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString String
" "
        replaceSpace Doc a
x             = Doc a
x

-- | Content to print only if it comes at the beginning of a line,
-- to be used e.g. for escaping line-initial `.` in roff man.
afterBreak :: Text -> Doc a
afterBreak :: forall a. Text -> Doc a
afterBreak = forall a. Text -> Doc a
AfterBreak

-- | Returns the width of a 'Doc'.
offset :: (IsString a, HasChars a) => Doc a -> Int
offset :: forall a. (IsString a, HasChars a) => Doc a -> Int
offset = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Ord a => a -> a -> a
max forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(IsString a, HasChars a) =>
(Int -> Bool) -> (Int, Int) -> Doc a -> (Int, Int)
getOffset (forall a b. a -> b -> a
const Bool
False) (Int
0, Int
0)

-- | Returns the minimal width of a 'Doc' when reflowed at breakable spaces.
minOffset :: HasChars a => Doc a -> Int
minOffset :: forall a. HasChars a => Doc a -> Int
minOffset = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Ord a => a -> a -> a
max forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(IsString a, HasChars a) =>
(Int -> Bool) -> (Int, Int) -> Doc a -> (Int, Int)
getOffset (forall a. Ord a => a -> a -> Bool
> Int
0) (Int
0,Int
0)

-- l = longest, c = current
getOffset :: (IsString a, HasChars a)
          => (Int -> Bool) -> (Int, Int) -> Doc a -> (Int, Int)
getOffset :: forall a.
(IsString a, HasChars a) =>
(Int -> Bool) -> (Int, Int) -> Doc a -> (Int, Int)
getOffset Int -> Bool
breakWhen (!Int
l, !Int
c) Doc a
x =
  case Doc a
x of
    Text Int
n a
_ -> (Int
l, Int
c forall a. Num a => a -> a -> a
+ Int
n)
    Block Int
n [a]
_ -> (Int
l, Int
c forall a. Num a => a -> a -> a
+ Int
n)
    VFill Int
n a
_ -> (Int
l, Int
c forall a. Num a => a -> a -> a
+ Int
n)
    Doc a
Empty -> (Int
l, Int
c)
    Doc a
CarriageReturn -> (forall a. Ord a => a -> a -> a
max Int
l Int
c, Int
0)
    Doc a
NewLine -> (forall a. Ord a => a -> a -> a
max Int
l Int
c, Int
0)
    BlankLines Int
_ -> (forall a. Ord a => a -> a -> a
max Int
l Int
c, Int
0)
    Prefixed Text
t Doc a
d ->
      let (Int
l',Int
c') = forall a.
(IsString a, HasChars a) =>
(Int -> Bool) -> (Int, Int) -> Doc a -> (Int, Int)
getOffset Int -> Bool
breakWhen (Int
0, Int
0) Doc a
d
       in (forall a. Ord a => a -> a -> a
max Int
l (Int
l' forall a. Num a => a -> a -> a
+ forall a. HasChars a => a -> Int
realLength Text
t), Int
c' forall a. Num a => a -> a -> a
+ forall a. HasChars a => a -> Int
realLength Text
t)
    BeforeNonBlank Doc a
_ -> (Int
l, Int
c)
    Flush Doc a
d -> forall a.
(IsString a, HasChars a) =>
(Int -> Bool) -> (Int, Int) -> Doc a -> (Int, Int)
getOffset Int -> Bool
breakWhen (Int
l, Int
c) Doc a
d
    Doc a
BreakingSpace
      | Int -> Bool
breakWhen Int
c -> (forall a. Ord a => a -> a -> a
max Int
l Int
c, Int
0)
      | Bool
otherwise -> (Int
l, Int
c forall a. Num a => a -> a -> a
+ Int
1)
    AfterBreak Text
t -> if Int
c forall a. Eq a => a -> a -> Bool
== Int
0
                       then (Int
l, Int
c forall a. Num a => a -> a -> a
+ forall a. HasChars a => a -> Int
realLength Text
t)
                       else (Int
l, Int
c)
    Concat (Concat Doc a
d Doc a
y) Doc a
z ->
      forall a.
(IsString a, HasChars a) =>
(Int -> Bool) -> (Int, Int) -> Doc a -> (Int, Int)
getOffset Int -> Bool
breakWhen (Int
l, Int
c) (forall a. Doc a -> Doc a -> Doc a
Concat Doc a
d (forall a. Doc a -> Doc a -> Doc a
Concat Doc a
y Doc a
z))
    Concat (BeforeNonBlank Doc a
d) Doc a
y ->
      if forall a. Doc a -> Bool
isNonBlank Doc a
y
         then forall a.
(IsString a, HasChars a) =>
(Int -> Bool) -> (Int, Int) -> Doc a -> (Int, Int)
getOffset Int -> Bool
breakWhen (Int
l, Int
c) (forall a. Doc a -> Doc a -> Doc a
Concat Doc a
d Doc a
y)
         else forall a.
(IsString a, HasChars a) =>
(Int -> Bool) -> (Int, Int) -> Doc a -> (Int, Int)
getOffset Int -> Bool
breakWhen (Int
l, Int
c) Doc a
y
    Concat Doc a
d Doc a
y ->
      let (Int
l', Int
c') = forall a.
(IsString a, HasChars a) =>
(Int -> Bool) -> (Int, Int) -> Doc a -> (Int, Int)
getOffset Int -> Bool
breakWhen (Int
l, Int
c) Doc a
d
       in forall a.
(IsString a, HasChars a) =>
(Int -> Bool) -> (Int, Int) -> Doc a -> (Int, Int)
getOffset Int -> Bool
breakWhen (Int
l', Int
c') Doc a
y

isNonBlank :: Doc a -> Bool
isNonBlank :: forall a. Doc a -> Bool
isNonBlank (Text Int
_ a
_) = Bool
True
isNonBlank (BeforeNonBlank Doc a
d) = forall a. Doc a -> Bool
isNonBlank Doc a
d
isNonBlank (Flush Doc a
d) = forall a. Doc a -> Bool
isNonBlank Doc a
d
isNonBlank (Concat Doc a
d Doc a
_) = forall a. Doc a -> Bool
isNonBlank Doc a
d
isNonBlank Doc a
_ = Bool
False

-- | Returns the column that would be occupied by the last
-- laid out character (assuming no wrapping).
updateColumn :: HasChars a => Doc a -> Int -> Int
updateColumn :: forall a. HasChars a => Doc a -> Int -> Int
updateColumn Doc a
d Int
k = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a.
(IsString a, HasChars a) =>
(Int -> Bool) -> (Int, Int) -> Doc a -> (Int, Int)
getOffset (forall a b. a -> b -> a
const Bool
False) (Int
0,Int
k) forall a b. (a -> b) -> a -> b
$ Doc a
d

-- | @lblock n d@ is a block of width @n@ characters, with
-- text derived from @d@ and aligned to the left.
lblock :: HasChars a => Int -> Doc a -> Doc a
lblock :: forall a. HasChars a => Int -> Doc a -> Doc a
lblock = forall a. HasChars a => (a -> a) -> Int -> Doc a -> Doc a
block forall a. a -> a
id

-- | Like 'lblock' but aligned to the right.
rblock :: HasChars a => Int -> Doc a -> Doc a
rblock :: forall a. HasChars a => Int -> Doc a -> Doc a
rblock Int
w = forall a. HasChars a => (a -> a) -> Int -> Doc a -> Doc a
block (\a
s -> forall a. HasChars a => Int -> Char -> a
replicateChar (Int
w forall a. Num a => a -> a -> a
- forall a. HasChars a => a -> Int
realLength a
s) Char
' ' forall a. Semigroup a => a -> a -> a
<> a
s) Int
w

-- | Like 'lblock' but aligned centered.
cblock :: HasChars a => Int -> Doc a -> Doc a
cblock :: forall a. HasChars a => Int -> Doc a -> Doc a
cblock Int
w = forall a. HasChars a => (a -> a) -> Int -> Doc a -> Doc a
block (\a
s -> forall a. HasChars a => Int -> Char -> a
replicateChar ((Int
w forall a. Num a => a -> a -> a
- forall a. HasChars a => a -> Int
realLength a
s) forall a. Integral a => a -> a -> a
`div` Int
2) Char
' ' forall a. Semigroup a => a -> a -> a
<> a
s) Int
w

-- | Returns the height of a block or other 'Doc'.
height :: HasChars a => Doc a -> Int
height :: forall a. HasChars a => Doc a -> Int
height = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasChars a => a -> [a]
splitLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasChars a => Maybe Int -> Doc a -> a
render forall a. Maybe a
Nothing

block :: HasChars a => (a -> a) -> Int -> Doc a -> Doc a
block :: forall a. HasChars a => (a -> a) -> Int -> Doc a -> Doc a
block a -> a
filler Int
width Doc a
d
  | Int
width forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. Doc a -> Bool
isEmpty Doc a
d) = forall a. HasChars a => (a -> a) -> Int -> Doc a -> Doc a
block a -> a
filler Int
1 Doc a
d
  | Bool
otherwise                    = forall a. Int -> [a] -> Doc a
Block Int
width [a]
ls
     where
       ls :: [a]
ls = forall a b. (a -> b) -> [a] -> [b]
map a -> a
filler forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => Int -> a -> [a]
chop Int
width forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => Maybe Int -> Doc a -> a
render (forall a. a -> Maybe a
Just Int
width) Doc a
d

-- | An expandable border that, when placed next to a box,
-- expands to the height of the box.  Strings cycle through the
-- list provided.
vfill :: HasChars a => a -> Doc a
vfill :: forall a. HasChars a => a -> Doc a
vfill a
t = forall a. Int -> a -> Doc a
VFill (forall a. HasChars a => a -> Int
realLength a
t) a
t

chop :: HasChars a => Int -> a -> [a]
chop :: forall a. HasChars a => Int -> a -> [a]
chop Int
n =
   forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. HasChars a => (Int, a) -> [a]
chopLine forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b}. (Eq a, Num a) => [(a, b)] -> [(a, b)]
removeFinalEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {b}. HasChars b => b -> (Int, b)
addRealLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasChars a => a -> [a]
splitLines
 where
   removeFinalEmpty :: [(a, b)] -> [(a, b)]
removeFinalEmpty [(a, b)]
xs = case forall a. [a] -> Maybe a
lastMay [(a, b)]
xs of
                           Just (a
0, b
_) -> forall a. [a] -> [a]
initSafe [(a, b)]
xs
                           Maybe (a, b)
_           -> [(a, b)]
xs
   addRealLength :: b -> (Int, b)
addRealLength b
l = (forall a. HasChars a => a -> Int
realLength b
l, b
l)
   chopLine :: (Int, a) -> [a]
chopLine (Int
len, a
l)
     | Int
len forall a. Ord a => a -> a -> Bool
<= Int
n  = [a
l]
     | Bool
otherwise = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$
                    forall a b. HasChars a => (Char -> b -> b) -> b -> a -> b
foldrChar
                     (\Char
c [(Int, a)]
ls ->
                       let clen :: Int
clen = Char -> Int
charWidth Char
c
                           cs :: a
cs = forall a. HasChars a => Int -> Char -> a
replicateChar Int
1 Char
c
                        in case [(Int, a)]
ls of
                             (Int
len', a
l'):[(Int, a)]
rest
                               | Int
len' forall a. Num a => a -> a -> a
+ Int
clen forall a. Ord a => a -> a -> Bool
> Int
n ->
                                   (Int
clen, a
cs)forall a. a -> [a] -> [a]
:(Int
len', a
l')forall a. a -> [a] -> [a]
:[(Int, a)]
rest
                               | Bool
otherwise ->
                                   (Int
len' forall a. Num a => a -> a -> a
+ Int
clen, a
cs forall a. Semigroup a => a -> a -> a
<> a
l')forall a. a -> [a] -> [a]
:[(Int, a)]
rest
                             [] -> [(Int
clen, a
cs)]) [] a
l

-- | Encloses a 'Doc' inside a start and end 'Doc'.
inside :: Doc a -> Doc a -> Doc a -> Doc a
inside :: forall a. Doc a -> Doc a -> Doc a -> Doc a
inside Doc a
start Doc a
end Doc a
contents =
  Doc a
start forall a. Semigroup a => a -> a -> a
<> Doc a
contents forall a. Semigroup a => a -> a -> a
<> Doc a
end

-- | Puts a 'Doc' in curly braces.
braces :: HasChars a => Doc a -> Doc a
braces :: forall a. HasChars a => Doc a -> Doc a
braces = forall a. Doc a -> Doc a -> Doc a -> Doc a
inside (forall a. HasChars a => Char -> Doc a
char Char
'{') (forall a. HasChars a => Char -> Doc a
char Char
'}')

-- | Puts a 'Doc' in square brackets.
brackets :: HasChars a => Doc a -> Doc a
brackets :: forall a. HasChars a => Doc a -> Doc a
brackets = forall a. Doc a -> Doc a -> Doc a -> Doc a
inside (forall a. HasChars a => Char -> Doc a
char Char
'[') (forall a. HasChars a => Char -> Doc a
char Char
']')

-- | Puts a 'Doc' in parentheses.
parens :: HasChars a => Doc a -> Doc a
parens :: forall a. HasChars a => Doc a -> Doc a
parens = forall a. Doc a -> Doc a -> Doc a -> Doc a
inside (forall a. HasChars a => Char -> Doc a
char Char
'(') (forall a. HasChars a => Char -> Doc a
char Char
')')

-- | Wraps a 'Doc' in single quotes.
quotes :: HasChars a => Doc a -> Doc a
quotes :: forall a. HasChars a => Doc a -> Doc a
quotes = forall a. Doc a -> Doc a -> Doc a -> Doc a
inside (forall a. HasChars a => Char -> Doc a
char Char
'\'') (forall a. HasChars a => Char -> Doc a
char Char
'\'')

-- | Wraps a 'Doc' in double quotes.
doubleQuotes :: HasChars a => Doc a -> Doc a
doubleQuotes :: forall a. HasChars a => Doc a -> Doc a
doubleQuotes = forall a. Doc a -> Doc a -> Doc a -> Doc a
inside (forall a. HasChars a => Char -> Doc a
char Char
'"') (forall a. HasChars a => Char -> Doc a
char Char
'"')

-- | Returns width of a character in a monospace font:  0 for a combining
-- character, 1 for a regular character, 2 for an East Asian wide character.
-- Ambiguous characters are treated as width 1.
charWidth :: Char -> Int
charWidth :: Char -> Int
charWidth = MatchState -> Int
extractLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. MatchState -> Char -> MatchState
updateMatchStateNarrow (Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False Int
0 Char
' ' Int
0)

-- | Get real length of string, taking into account combining and double-wide
-- characters. Ambiguous characters are treated as width 1.
realLength :: HasChars a => a -> Int
realLength :: forall a. HasChars a => a -> Int
realLength = forall a. HasChars a => a -> Int
realLengthNarrowContext

-- | Get the real length of a string, taking into account combining and
-- double-wide characters. Ambiguous characters are treated as width 1.
realLengthNarrowContext :: HasChars a => a -> Int
realLengthNarrowContext :: forall a. HasChars a => a -> Int
realLengthNarrowContext = forall a.
HasChars a =>
(MatchState -> Char -> MatchState) -> a -> Int
realLengthWith MatchState -> Char -> MatchState
updateMatchStateNarrow

-- | Get the real length of a string, taking into account combining and
-- double-wide characters. Ambiguous characters are treated as width 2.
realLengthWideContext :: HasChars a => a -> Int
realLengthWideContext :: forall a. HasChars a => a -> Int
realLengthWideContext = forall a.
HasChars a =>
(MatchState -> Char -> MatchState) -> a -> Int
realLengthWith MatchState -> Char -> MatchState
updateMatchStateWide

-- | Like 'realLengthNarrowContext', but avoids optimizations (shortcuts).
-- This is exposed for testing, to ensure that the optimizations are safe.
realLengthNarrowContextNoShortcut :: HasChars a => a -> Int
realLengthNarrowContextNoShortcut :: forall a. HasChars a => a -> Int
realLengthNarrowContextNoShortcut = forall a.
HasChars a =>
(MatchState -> Char -> MatchState) -> a -> Int
realLengthWith MatchState -> Char -> MatchState
updateMatchStateNoShortcut

-- | Like 'realLengthWideContext', but avoids optimizations (shortcuts).
-- This is exposed for testing, to ensure that the optimizations are safe.
realLengthWideContextNoShortcut :: HasChars a => a -> Int
realLengthWideContextNoShortcut :: forall a. HasChars a => a -> Int
realLengthWideContextNoShortcut = forall a.
HasChars a =>
(MatchState -> Char -> MatchState) -> a -> Int
realLengthWith MatchState -> Char -> MatchState
updateMatchStateNoShortcutWide

-- | Get real length of string, taking into account combining and double-wide
-- characters, using the given accumulator. This is exposed for testing.
realLengthWith :: HasChars a => (MatchState -> Char -> MatchState) -> a -> Int
realLengthWith :: forall a.
HasChars a =>
(MatchState -> Char -> MatchState) -> a -> Int
realLengthWith MatchState -> Char -> MatchState
f = MatchState -> Int
extractLength forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. HasChars a => (b -> Char -> b) -> b -> a -> b
foldlChar MatchState -> Char -> MatchState
f (Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
True Int
0 Char
' ' Int
0)

-- | Update a 'MatchState' by processing a character.
-- For efficiency, we isolate commonly used portions of the basic
-- multilingual plane that do not have emoji in them.
-- This works in a narrow context.
updateMatchStateNarrow :: MatchState -> Char -> MatchState
updateMatchStateNarrow :: MatchState -> Char -> MatchState
updateMatchStateNarrow (MatchState Bool
firstChar Int
tot Char
_ Int
tentative) !Char
c
    -- Control characters have width 0: friends don't let friends use tabs
    | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x001F'  = MatchState
controlState
    -- ASCII
    | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x007E'  = MatchState
narrowState
    -- More control characters
    | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x009F'  = MatchState
controlState
    -- Extended Latin: Latin 1-supplement, Extended-A, Extended-B, IPA Extensions.
    -- This block is full of ambiguous characters, so these shortcuts will not
    -- work in a wide context.
    | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x00AD'  = MatchState
controlState    -- Soft hyphen
    | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x02FF'  = MatchState
narrowState
    -- Combining diacritical marks used in Latin and other scripts
    | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x036F'  = MatchState
combiningState
    -- Han ideographs
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x3250' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\xA4CF' =
        if | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x4DBF' -> MatchState
wideState       -- Han ideographs
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x4DFF' -> MatchState
narrowState     -- Hexagrams
           | Bool
otherwise     -> MatchState
wideState       -- More Han ideographs
    -- Arabic
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x0600' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x06FF' =
        if | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0605' -> MatchState
controlState    -- Number marks
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x060F' -> MatchState
narrowState     -- Punctuation and marks
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x061A' -> MatchState
combiningState  -- Combining marks
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x061B' -> MatchState
narrowState     -- Arabic semicolon
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x061C' -> MatchState
controlState    -- Letter mark
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x064A' -> MatchState
narrowState     -- Main Arabic abjad
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x065F' -> MatchState
combiningState  -- Arabic vowel markers
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0670' -> MatchState
combiningState  -- Superscript alef
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x06D5' -> MatchState
narrowState     -- Arabic digits and letters used in other languages
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x06DC' -> MatchState
combiningState  -- Small high ligatures
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x06DD' -> MatchState
controlState    -- End of ayah
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x06DE' -> MatchState
narrowState     -- Start of rub el hizb
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x06E4' -> MatchState
combiningState  -- More small high ligatures
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x06E6' -> MatchState
narrowState     -- Small vowels
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x06E9' -> MatchState
narrowState     -- Place of sajdah
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x06ED' -> MatchState
combiningState  -- More combining
           | Bool
otherwise     -> MatchState
narrowState     -- All the rest
    -- Devanagari
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x0900' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x097F' =
        if | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0902' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0939' -> MatchState
narrowState     -- Main Devanagari abugida
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x093A' -> MatchState
combiningState
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x093C' -> MatchState
combiningState
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0940' -> MatchState
narrowState     -- Main Devanagari abugida
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0948' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x094D' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0950' -> MatchState
narrowState     -- Devanagari om
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0957' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0962' -> MatchState
combiningState  -- Combining character
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0963' -> MatchState
combiningState  -- Combining character
           | Bool
otherwise     -> MatchState
narrowState     -- Devanagari digits and up to beginning of Bengali block
    -- Bengali (plus a couple Gurmukhi characters)
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x0980' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0A02' =
        if | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0981' -> MatchState
combiningState  -- Combining signs
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x09BC' -> MatchState
combiningState  -- Combining signs
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x09C0' -> MatchState
narrowState     -- Main Bengali abugida
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x09C4' -> MatchState
combiningState  -- Combining signs
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x09CD' -> MatchState
combiningState  -- Combining signs
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x09E1' -> MatchState
narrowState     -- Bengali
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x09E3' -> MatchState
combiningState  -- Combining marks
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x09E2' -> MatchState
combiningState  -- Bengali vocalic vowel signs
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x09E3' -> MatchState
combiningState  -- Bengali vocalic vowel signs
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x09FD' -> MatchState
narrowState     -- Bengali digits and other symbols
           | Bool
otherwise     -> MatchState
combiningState  -- Bengali sandhi mark, plus a few symbols from Gurmukhi
    -- Cyrillic (plus Greek and Armenian for free)
    -- This block has many ambiguous characters, and so cannot be used in wide contexts
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x0370' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x058F' =
        if | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0482' -> MatchState
narrowState     -- Main Greek and Cyrillic block
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0489' -> MatchState
combiningState  -- Cyrillic combining characters
           | Bool
otherwise     -> MatchState
narrowState     -- Extra Cyrillic characters used in Ukrainian and others, plus Armenian
    -- Japanese
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x2E80' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x324F' =
        if | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x3029' -> MatchState
wideState       -- Punctuation and others
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x302D' -> MatchState
combiningState  -- Tone marks
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x303F' -> MatchState
narrowState     -- Half-fill space
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x3096' -> MatchState
wideState       -- Hiragana and others
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x309A' -> MatchState
combiningState  -- Hiragana voiced marks
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x3247' -> MatchState
wideState       -- Katakana plus compatibility Jamo for Korean
           | Bool
otherwise     -> MatchState
ambiguousState  -- Circled numbers
    -- Korean
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\xAC00' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\xD7A3' = MatchState
wideState  -- Precomposed Hangul
    -- Telugu (plus one character of Kannada)
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x0C00' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0C80' =
        if | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0C00' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0C04' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0C39' -> MatchState
narrowState     -- Main Telugu abugida
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0C3D' -> MatchState
narrowState     -- Telugu avagraha
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0C40' -> MatchState
combiningState  -- Vowel markers
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0C44' -> MatchState
narrowState     -- Vowel markers
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0C56' -> MatchState
combiningState  -- Vowel markers
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0C62' -> MatchState
combiningState  -- Combining character
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0C63' -> MatchState
combiningState  -- Combining character
           | Bool
otherwise     -> MatchState
narrowState     -- Telugu digits
    -- Tamil
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x0B80' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0BFF' =
        if | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0B82' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0BC0' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0BCD' -> MatchState
combiningState  -- Vowel markers
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0BCC' -> MatchState
narrowState     -- Main Tamil abugida
           | Bool
otherwise     -> MatchState
narrowState     -- Tamil digits and others
  where
    narrowState :: MatchState
narrowState    = Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
1
    wideState :: MatchState
wideState      = Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
2
    combiningState :: MatchState
combiningState = let w :: Int
w = if Bool
firstChar then Int
1 else Int
0 in Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
w
    controlState :: MatchState
controlState   = Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
0
    ambiguousState :: MatchState
ambiguousState = Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
1
updateMatchStateNarrow MatchState
s Char
c = MatchState -> Char -> MatchState
updateMatchStateNoShortcut MatchState
s Char
c

-- | Update a 'MatchState' by processing a character.
-- For efficiency, we isolate commonly used portions of the basic
-- multilingual plane that do not have emoji in them.
-- This works in a wide context.
updateMatchStateWide :: MatchState -> Char -> MatchState
updateMatchStateWide :: MatchState -> Char -> MatchState
updateMatchStateWide (MatchState Bool
firstChar Int
tot Char
_ Int
tentative) !Char
c
    -- Control characters have width 0: friends don't let friends use tabs
    | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x001F'  = MatchState
controlState
    -- ASCII
    | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x007E'  = MatchState
narrowState
    -- Han ideographs
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x3250' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\xA4CF' =
        if | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x4DBF' -> MatchState
wideState       -- Han ideographs
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x4DFF' -> MatchState
narrowState     -- Hexagrams
           | Bool
otherwise     -> MatchState
wideState       -- More Han ideographs
    -- Japanese
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x2E80' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x324F' =
        if | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x3029' -> MatchState
wideState       -- Punctuation and others
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x302D' -> MatchState
combiningState  -- Tone marks
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x303F' -> MatchState
narrowState     -- Half-fill space
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x3096' -> MatchState
wideState       -- Hiragana and others
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x309A' -> MatchState
combiningState  -- Hiragana voiced marks
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x3247' -> MatchState
wideState       -- Katakana plus compatibility Jamo for Korean
           | Bool
otherwise     -> MatchState
ambiguousState  -- Circled numbers
    -- Korean
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\xAC00' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\xD7A3' = MatchState
wideState  -- Precomposed Hangul
    -- Combining diacritical marks used in Latin and other scripts
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x0300' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x036F'  = MatchState
combiningState
    -- Arabic
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x0600' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x06FF' =
        if | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0605' -> MatchState
controlState    -- Number marks
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x060F' -> MatchState
narrowState     -- Punctuation and marks
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x061A' -> MatchState
combiningState  -- Combining marks
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x061B' -> MatchState
narrowState     -- Arabic semicolon
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x061C' -> MatchState
controlState    -- Letter mark
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x064A' -> MatchState
narrowState     -- Main Arabic abjad
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x065F' -> MatchState
combiningState  -- Arabic vowel markers
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0670' -> MatchState
combiningState  -- Superscript alef
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x06D5' -> MatchState
narrowState     -- Arabic digits and letters used in other languages
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x06DC' -> MatchState
combiningState  -- Small high ligatures
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x06DD' -> MatchState
controlState    -- End of ayah
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x06DE' -> MatchState
narrowState     -- Start of rub el hizb
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x06E4' -> MatchState
combiningState  -- More small high ligatures
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x06E6' -> MatchState
narrowState     -- Small vowels
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x06E9' -> MatchState
narrowState     -- Place of sajdah
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x06ED' -> MatchState
combiningState  -- More combining
           | Bool
otherwise     -> MatchState
narrowState     -- All the rest
    -- Devanagari
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x0900' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x097F' =
        if | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0902' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0939' -> MatchState
narrowState     -- Main Devanagari abugida
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x093A' -> MatchState
combiningState
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x093C' -> MatchState
combiningState
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0940' -> MatchState
narrowState     -- Main Devanagari abugida
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0948' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x094D' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0950' -> MatchState
narrowState     -- Devanagari om
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0957' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0962' -> MatchState
combiningState  -- Combining character
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0963' -> MatchState
combiningState  -- Combining character
           | Bool
otherwise     -> MatchState
narrowState     -- Devanagari digits and up to beginning of Bengali block
    -- Bengali (plus a couple Gurmukhi characters)
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x0980' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0A02' =
        if | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0981' -> MatchState
combiningState  -- Combining signs
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x09BC' -> MatchState
combiningState  -- Combining signs
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x09C0' -> MatchState
narrowState     -- Main Bengali abugida
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x09C4' -> MatchState
combiningState  -- Combining signs
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x09CD' -> MatchState
combiningState  -- Combining signs
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x09E1' -> MatchState
narrowState     -- Bengali
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x09E3' -> MatchState
combiningState  -- Combining marks
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x09E2' -> MatchState
combiningState  -- Bengali vocalic vowel signs
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x09E3' -> MatchState
combiningState  -- Bengali vocalic vowel signs
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x09FD' -> MatchState
narrowState     -- Bengali digits and other symbols
           | Bool
otherwise     -> MatchState
combiningState  -- Bengali sandhi mark, plus a few symbols from Gurmukhi
    -- Telugu (plus one character of Kannada)
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x0C00' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0C80' =
        if | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0C00' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0C04' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0C39' -> MatchState
narrowState     -- Main Telugu abugida
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0C3D' -> MatchState
narrowState     -- Telugu avagraha
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0C40' -> MatchState
combiningState  -- Vowel markers
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0C44' -> MatchState
narrowState     -- Vowel markers
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0C56' -> MatchState
combiningState  -- Vowel markers
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0C62' -> MatchState
combiningState  -- Combining character
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0C63' -> MatchState
combiningState  -- Combining character
           | Bool
otherwise     -> MatchState
narrowState     -- Telugu digits
    -- Tamil
    | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x0B80' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0BFF' =
        if | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0B82' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0BC0' -> MatchState
combiningState  -- Combining characters
           | Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x0BCD' -> MatchState
combiningState  -- Vowel markers
           | Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x0BCC' -> MatchState
narrowState     -- Main Tamil abugida
           | Bool
otherwise     -> MatchState
narrowState     -- Tamil digits and others
  where
    narrowState :: MatchState
narrowState    = Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
1
    wideState :: MatchState
wideState      = Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
2
    combiningState :: MatchState
combiningState = let w :: Int
w = if Bool
firstChar then Int
1 else Int
0 in Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
w
    controlState :: MatchState
controlState   = Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
0
    ambiguousState :: MatchState
ambiguousState = Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
2
updateMatchStateWide MatchState
s Char
c = MatchState -> Char -> MatchState
updateMatchStateNoShortcutWide MatchState
s Char
c

-- | Update a 'MatchState' by processing a character, without taking any
-- shortcuts. This should give the same answer as 'updateMatchStateNarrow', but will
-- be slower. It is here to test that the shortcuts are implemented correctly.
updateMatchStateNoShortcut :: MatchState -> Char -> MatchState
updateMatchStateNoShortcut :: MatchState -> Char -> MatchState
updateMatchStateNoShortcut MatchState
match Char
c = MatchState -> Char -> UnicodeWidth -> MatchState
resolveWidth MatchState
match Char
c forall a b. (a -> b) -> a -> b
$ UnicodeMap -> Char -> UnicodeWidth
unicodeWidth (UnicodeWidth -> UnicodeMap
unicodeRangeMap UnicodeWidth
Narrow) Char
c

-- | Update a 'MatchState' by processing a character, without taking any
-- shortcuts. This should give the same answer as 'updateMatchStateWide', but will
-- be slower. It is here to test that the shortcuts are implemented correctly.
updateMatchStateNoShortcutWide :: MatchState -> Char -> MatchState
updateMatchStateNoShortcutWide :: MatchState -> Char -> MatchState
updateMatchStateNoShortcutWide MatchState
match Char
c = MatchState -> Char -> UnicodeWidth -> MatchState
resolveWidth MatchState
match Char
c forall a b. (a -> b) -> a -> b
$ UnicodeMap -> Char -> UnicodeWidth
unicodeWidth (UnicodeWidth -> UnicodeMap
unicodeRangeMap UnicodeWidth
Wide) Char
c

-- | Update a match state given a character and its class
resolveWidth :: MatchState -> Char -> UnicodeWidth -> MatchState
resolveWidth :: MatchState -> Char -> UnicodeWidth -> MatchState
resolveWidth (MatchState Bool
firstChar Int
tot Char
lastChar Int
tentative) !Char
c = \case
    UnicodeWidth
Narrow                    -> MatchState
narrowState
    UnicodeWidth
Wide                      -> MatchState
wideState
    UnicodeWidth
Combining                 -> MatchState
combiningState
    UnicodeWidth
Control                   -> MatchState
controlState
    UnicodeWidth
Ambiguous                 -> MatchState
ambiguousState
    -- Zero width joiners will join two emoji together, so let's discard the
    -- state and parse the next emoji
    UnicodeWidth
ZWJ | Bool
isLastCharEmojiLike -> Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
- Int
2) Char
c Int
2
    UnicodeWidth
ZWJ                       -> MatchState
controlState
    -- Variation modifiers modify the emoji up to this point, so can be
    -- discarded. However, they always make it width 2, so we set the tentative
    -- width to 2.
    UnicodeWidth
EmojiPresentationMod | Just (EmojiInfo Bool
True Bool
_) <- Maybe EmojiInfo
lastCharEmoji
                              -> Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False Int
tot Char
c Int
2
    UnicodeWidth
EmojiPresentationMod      -> MatchState
controlState
    -- Skin tone modifiers make it width 2, but if they are not in a valid
    -- position they end the emoji and take up another width 2.
    UnicodeWidth
EmojiSkinToneMod | Just (EmojiInfo Bool
_ Bool
True) <- Maybe EmojiInfo
lastCharEmoji
                              -> Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False Int
tot Char
c Int
2
    UnicodeWidth
EmojiSkinToneMod          -> MatchState
wideState
  where
    narrowState :: MatchState
narrowState    = Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
1
    wideState :: MatchState
wideState      = Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
2
    combiningState :: MatchState
combiningState = let w :: Int
w = if Bool
firstChar then Int
1 else Int
0 in Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
w
    controlState :: MatchState
controlState   = Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
0
    ambiguousState :: MatchState
ambiguousState = Bool -> Int -> Char -> Int -> MatchState
MatchState Bool
False (Int
tot forall a. Num a => a -> a -> a
+ Int
tentative) Char
c Int
1  -- Should be handled already, but treat it as 1
    lastCharEmoji :: Maybe EmojiInfo
lastCharEmoji = forall a. Int -> IntMap a -> Maybe a
IM.lookup (Char -> Int
ord Char
lastChar) IntMap EmojiInfo
emojiMap
    isLastCharEmojiLike :: Bool
isLastCharEmojiLike = forall a. Maybe a -> Bool
isJust Maybe EmojiInfo
lastCharEmoji Bool -> Bool -> Bool
|| Char
lastChar forall a. Eq a => a -> a -> Bool
== Char
'\xFE0F' Bool -> Bool -> Bool
|| Char -> Bool
isSkinToneModifier Char
lastChar

-- | Keeps track of state in length calculations, determining whether we're at
-- the first character, the width so far, possibly a tentative width for this
-- group, and the Map for possible emoji continuations.
data MatchState = MatchState
    { MatchState -> Bool
matchIsFirst       :: !Bool
    , MatchState -> Int
matchTotal         :: !Int
    , MatchState -> Char
matchLastChar      :: !Char
    , MatchState -> Int
matchTentative     :: !Int
    }
  deriving (Int -> MatchState -> String -> String
[MatchState] -> String -> String
MatchState -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [MatchState] -> String -> String
$cshowList :: [MatchState] -> String -> String
show :: MatchState -> String
$cshow :: MatchState -> String
showsPrec :: Int -> MatchState -> String -> String
$cshowsPrec :: Int -> MatchState -> String -> String
Show)

-- | Get the final width from a 'MatchState'.
extractLength :: MatchState -> Int
extractLength :: MatchState -> Int
extractLength (MatchState Bool
_ Int
tot Char
_ Int
tentative) = Int
tot forall a. Num a => a -> a -> a
+ Int
tentative

-- | The unicode width  of a given character.
data UnicodeWidth = Narrow | Wide | Combining | Control | Ambiguous
                  | ZWJ | EmojiPresentationMod | EmojiSkinToneMod
  deriving (Int -> UnicodeWidth -> String -> String
[UnicodeWidth] -> String -> String
UnicodeWidth -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [UnicodeWidth] -> String -> String
$cshowList :: [UnicodeWidth] -> String -> String
show :: UnicodeWidth -> String
$cshow :: UnicodeWidth -> String
showsPrec :: Int -> UnicodeWidth -> String -> String
$cshowsPrec :: Int -> UnicodeWidth -> String -> String
Show, UnicodeWidth -> UnicodeWidth -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnicodeWidth -> UnicodeWidth -> Bool
$c/= :: UnicodeWidth -> UnicodeWidth -> Bool
== :: UnicodeWidth -> UnicodeWidth -> Bool
$c== :: UnicodeWidth -> UnicodeWidth -> Bool
Eq)

-- | Checks whether a character is a skin tone modifier.
isSkinToneModifier :: Char -> Bool
isSkinToneModifier :: Char -> Bool
isSkinToneModifier Char
c = Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\x1F3FB' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\x1F3FF'

-- | Checks whether a character is an emoji variation modifier.
isEmojiVariation :: Char -> Bool
isEmojiVariation :: Char -> Bool
isEmojiVariation Char
c = Char
c forall a. Ord a => a -> a -> Bool
>= Char
'\xFE0E' Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'\xFE0F'

-- | Checks whether a character is a zero-width joiner.
isZWJ :: Char -> Bool
isZWJ :: Char -> Bool
isZWJ Char
c = Char
c forall a. Eq a => a -> a -> Bool
== Char
'\x200D'

data EmojiInfo = EmojiInfo
    { EmojiInfo -> Bool
acceptsVariation :: !Bool
    , EmojiInfo -> Bool
acceptsSkinTones :: !Bool
    } deriving (EmojiInfo -> EmojiInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EmojiInfo -> EmojiInfo -> Bool
$c/= :: EmojiInfo -> EmojiInfo -> Bool
== :: EmojiInfo -> EmojiInfo -> Bool
$c== :: EmojiInfo -> EmojiInfo -> Bool
Eq, Int -> EmojiInfo -> String -> String
[EmojiInfo] -> String -> String
EmojiInfo -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [EmojiInfo] -> String -> String
$cshowList :: [EmojiInfo] -> String -> String
show :: EmojiInfo -> String
$cshow :: EmojiInfo -> String
showsPrec :: Int -> EmojiInfo -> String -> String
$cshowsPrec :: Int -> EmojiInfo -> String -> String
Show)

instance Semigroup EmojiInfo where
    EmojiInfo Bool
v1 Bool
s1 <> :: EmojiInfo -> EmojiInfo -> EmojiInfo
<> EmojiInfo Bool
v2 Bool
s2 = Bool -> Bool -> EmojiInfo
EmojiInfo (Bool
v1 Bool -> Bool -> Bool
|| Bool
v2) (Bool
s1 Bool -> Bool -> Bool
|| Bool
s2)

-- | Check a character to see how it modifies emoji.
variationState :: Char -> EmojiInfo
variationState :: Char -> EmojiInfo
variationState Char
y = Bool -> Bool -> EmojiInfo
EmojiInfo (Char -> Bool
isEmojiVariation Char
y) (Char -> Bool
isSkinToneModifier Char
y)

-- | A map of all emoji start characters and the modifiers they take.
emojiMap :: IM.IntMap EmojiInfo
emojiMap :: IntMap EmojiInfo
emojiMap = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip (Char, Text) -> IntMap EmojiInfo -> IntMap EmojiInfo
addEmoji) forall a. Monoid a => a
mempty forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Text -> Maybe (Char, Text)
T.uncons [Text]
baseEmojis
  where
    addEmoji :: (Char, Text) -> IntMap EmojiInfo -> IntMap EmojiInfo
addEmoji (Char
x, Text
xs) = forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith forall a. Semigroup a => a -> a -> a
(<>) (Char -> Int
ord Char
x) (Text -> EmojiInfo
emojiInfo Text
xs)
    emojiInfo :: Text -> EmojiInfo
emojiInfo = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool -> Bool -> EmojiInfo
EmojiInfo Bool
False Bool
False) (Char -> EmojiInfo
variationState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (Char, Text)
T.uncons

-- | Denotes the contiguous ranges of Unicode characters which have a given
-- width: 1 for a regular character, 2 for an East Asian wide character.
-- Ambiguous characters are resolved in the specified way.
unicodeRangeMap :: UnicodeWidth -> UnicodeMap
unicodeRangeMap :: UnicodeWidth -> UnicodeMap
unicodeRangeMap UnicodeWidth
ambiguous =
    Map Char UnicodeWidth -> UnicodeMap
repack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Char UnicodeWidth -> Map Char UnicodeWidth
addEmojiClasses forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Eq b => [(a, b)] -> [(a, b)]
mergeRanges forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second UnicodeWidth -> UnicodeWidth
resolve) [(Char, UnicodeWidth)]
unicodeSpec
  where
    resolve :: UnicodeWidth -> UnicodeWidth
resolve UnicodeWidth
Ambiguous = UnicodeWidth
ambiguous
    resolve UnicodeWidth
x         = UnicodeWidth
x

-- | Add zero-width joiner and emoji modifiers to a Map.
addEmojiClasses :: M.Map Char UnicodeWidth -> M.Map Char UnicodeWidth
addEmojiClasses :: Map Char UnicodeWidth -> Map Char UnicodeWidth
addEmojiClasses =
    forall {p} {a}.
(Ord p, Enum p) =>
p -> p -> a -> Map p a -> Map p a
addAndRestoreBoundary Char
'\x200D' Char
'\x200D' UnicodeWidth
ZWJ
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {p} {a}.
(Ord p, Enum p) =>
p -> p -> a -> Map p a -> Map p a
addAndRestoreBoundary Char
'\xFE0F' Char
'\xFE0F' UnicodeWidth
EmojiPresentationMod
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {p} {a}.
(Ord p, Enum p) =>
p -> p -> a -> Map p a -> Map p a
addAndRestoreBoundary Char
'\x1F3FB' Char
'\x1F3FF' UnicodeWidth
EmojiSkinToneMod
  where
    addAndRestoreBoundary :: p -> p -> a -> Map p a -> Map p a
addAndRestoreBoundary p
k1 p
k2 a
v Map p a
m = Map p a -> Map p a
insertAfter forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert p
k1 a
v Map p a
m
      where
        insertAfter :: Map p a -> Map p a
insertAfter = case forall k v. Ord k => k -> Map k v -> Maybe (k, v)
M.lookupLE p
k1 Map p a
m of
          Just (p
_, a
prev) -> forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith (\a
_ a
old -> a
old) (forall a. Enum a => a -> a
succ p
k2) a
prev
          Maybe (p, a)
Nothing        -> forall a. a -> a
id

-- | Collapse unicode character ranges if the general category doesn't make a
-- difference for width.
mergeRanges :: Eq b => [(a, b)] -> [(a, b)]
mergeRanges :: forall b a. Eq b => [(a, b)] -> [(a, b)]
mergeRanges []  = []
mergeRanges [(a, b)
x] = [(a, b)
x]
mergeRanges (x :: (a, b)
x@(a
_,b
xw):y :: (a, b)
y@(a
_,b
yw):[(a, b)]
xs)
    | b
xw forall a. Eq a => a -> a -> Bool
== b
yw  = forall b a. Eq b => [(a, b)] -> [(a, b)]
mergeRanges ((a, b)
xforall a. a -> [a] -> [a]
:[(a, b)]
xs)
    | Bool
otherwise = (a, b)
x forall a. a -> [a] -> [a]
: forall b a. Eq b => [(a, b)] -> [(a, b)]
mergeRanges ((a, b)
yforall a. a -> [a] -> [a]
:[(a, b)]
xs)


data UnicodeMap
    = Bin {-# UNPACK #-} !Char !UnicodeWidth !UnicodeMap !UnicodeMap
    | Tip

-- | Find the width of a unicode character
unicodeWidth :: UnicodeMap -> Char -> UnicodeWidth
unicodeWidth :: UnicodeMap -> Char -> UnicodeWidth
unicodeWidth = UnicodeMap -> Char -> UnicodeWidth
goNothing
  where
    goNothing :: UnicodeMap -> Char -> UnicodeWidth
goNothing UnicodeMap
Tip !Char
_ = UnicodeWidth
Control
    goNothing (Bin Char
kx UnicodeWidth
x UnicodeMap
l UnicodeMap
r) Char
k = case forall a. Ord a => a -> a -> Ordering
compare Char
k Char
kx of
        Ordering
LT -> UnicodeMap -> Char -> UnicodeWidth
goNothing UnicodeMap
l Char
k
        Ordering
EQ -> UnicodeWidth
x
        Ordering
GT -> UnicodeMap -> Char -> Char -> UnicodeWidth -> UnicodeWidth
goJust UnicodeMap
r Char
k Char
kx UnicodeWidth
x

    goJust :: UnicodeMap -> Char -> Char -> UnicodeWidth -> UnicodeWidth
goJust UnicodeMap
Tip !Char
_ !Char
_ UnicodeWidth
x' = UnicodeWidth
x'
    goJust (Bin Char
kx UnicodeWidth
x UnicodeMap
l UnicodeMap
r) Char
k Char
kx' UnicodeWidth
x' = case forall a. Ord a => a -> a -> Ordering
compare Char
k Char
kx of
        Ordering
LT -> UnicodeMap -> Char -> Char -> UnicodeWidth -> UnicodeWidth
goJust UnicodeMap
l Char
k Char
kx' UnicodeWidth
x'
        Ordering
EQ -> UnicodeWidth
x
        Ordering
GT -> UnicodeMap -> Char -> Char -> UnicodeWidth -> UnicodeWidth
goJust UnicodeMap
r Char
k Char
kx UnicodeWidth
x
{-# INLINABLE unicodeWidth #-}

-- | Convert a Map to a UnicodeMap for faster code.
repack :: M.Map Char UnicodeWidth -> UnicodeMap
repack :: Map Char UnicodeWidth -> UnicodeMap
repack Map Char UnicodeWidth
MInt.Tip = UnicodeMap
Tip
repack (MInt.Bin Int
_ Char
k UnicodeWidth
v Map Char UnicodeWidth
l Map Char UnicodeWidth
r) = Char -> UnicodeWidth -> UnicodeMap -> UnicodeMap -> UnicodeMap
Bin Char
k UnicodeWidth
v (Map Char UnicodeWidth -> UnicodeMap
repack Map Char UnicodeWidth
l) (Map Char UnicodeWidth -> UnicodeMap
repack Map Char UnicodeWidth
r)

-- | A list of Unicode ranges and the width assigned to them
unicodeSpec :: [(Char, UnicodeWidth)]
#include "unicodeWidth.inc"