{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP               #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE DeriveFoldable    #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveDataTypeable #-}
{- |
   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
     , realLengthNoShortcut
     , isEmojiModifier
     , isEmojiVariation
     , isEmojiJoiner
     -- * Types
     , Doc(..)
     , HasChars(..)
     )

where
import Prelude
import Data.Maybe (fromMaybe)
import Data.Monoid (Sum(..))
import Safe (lastMay, initSafe)
import Control.Monad
import Control.Monad.State.Strict
import GHC.Generics
import Data.Char (isDigit, isSpace, ord)
import Data.List (foldl', intersperse)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.IntMap.Strict as IM
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 n :: Int
n c :: Char
c = String -> a
forall a. IsString a => String -> a
fromString (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
c)
  isNull        :: a -> Bool
  isNull = (Char -> Bool -> Bool) -> Bool -> a -> Bool
forall a b. HasChars a => (Char -> b -> b) -> b -> a -> b
foldrChar (\_ _ -> Bool
False) Bool
True
  splitLines    :: a -> [a]
  splitLines s :: a
s = (String -> a
forall a. IsString a => String -> a
fromString String
firstline a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
otherlines)
   where
    (firstline :: String
firstline, otherlines :: [a]
otherlines) = (Char -> (String, [a]) -> (String, [a]))
-> (String, [a]) -> a -> (String, [a])
forall a b. HasChars a => (Char -> b -> b) -> b -> a -> b
foldrChar Char -> (String, [a]) -> (String, [a])
forall a. IsString a => Char -> (String, [a]) -> (String, [a])
go ([],[]) a
s
    go :: Char -> (String, [a]) -> (String, [a])
go '\n' (cur :: String
cur,lns :: [a]
lns) = ([], String -> a
forall a. IsString a => String -> a
fromString String
cur a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
lns)
    go c :: Char
c    (cur :: String
cur,lns :: [a]
lns) = (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cur, [a]
lns)

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

instance HasChars TL.Text where
  foldrChar :: (Char -> b -> b) -> b -> Text -> b
foldrChar         = (Char -> b -> b) -> b -> Text -> b
forall b. (Char -> b -> b) -> b -> Text -> b
TL.foldr
  foldlChar :: (b -> Char -> b) -> b -> Text -> b
foldlChar         = (b -> Char -> b) -> b -> Text -> b
forall b. (b -> Char -> b) -> b -> Text -> b
TL.foldl'
  splitLines :: Text -> [Text]
splitLines        = Text -> Text -> [Text]
TL.splitOn "\n"
  replicateChar :: Int -> Char -> Text
replicateChar n :: Int
n c :: Char
c = Int64 -> Text -> Text
TL.replicate (Int -> Int64
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
[Doc a] -> String -> String
Doc a -> String
(Int -> Doc a -> String -> String)
-> (Doc a -> String)
-> ([Doc a] -> String -> String)
-> Show (Doc a)
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)
Int -> ReadS (Doc a)
ReadS [Doc a]
(Int -> ReadS (Doc a))
-> ReadS [Doc a]
-> ReadPrec (Doc a)
-> ReadPrec [Doc a]
-> Read (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
(Doc a -> Doc a -> Bool) -> (Doc a -> Doc a -> Bool) -> Eq (Doc a)
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, Eq (Doc a)
Eq (Doc a) =>
(Doc a -> Doc a -> Ordering)
-> (Doc a -> Doc a -> Bool)
-> (Doc a -> Doc a -> Bool)
-> (Doc a -> Doc a -> Bool)
-> (Doc a -> Doc a -> Bool)
-> (Doc a -> Doc a -> Doc a)
-> (Doc a -> Doc a -> Doc a)
-> Ord (Doc a)
Doc a -> Doc a -> Bool
Doc a -> Doc a -> Ordering
Doc a -> Doc a -> Doc a
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
$cp1Ord :: forall a. Ord a => Eq (Doc a)
Ord, a -> Doc b -> Doc a
(a -> b) -> Doc a -> Doc b
(forall a b. (a -> b) -> Doc a -> Doc b)
-> (forall a b. a -> Doc b -> Doc a) -> Functor Doc
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
<$ :: a -> Doc b -> Doc a
$c<$ :: forall a b. a -> Doc b -> Doc a
fmap :: (a -> b) -> Doc a -> Doc b
$cfmap :: forall a b. (a -> b) -> Doc a -> Doc b
Functor, Doc a -> Bool
(a -> m) -> Doc a -> m
(a -> b -> b) -> b -> Doc a -> b
(forall m. Monoid m => Doc m -> m)
-> (forall m a. Monoid m => (a -> m) -> Doc a -> m)
-> (forall m a. Monoid m => (a -> m) -> Doc a -> m)
-> (forall a b. (a -> b -> b) -> b -> Doc a -> b)
-> (forall a b. (a -> b -> b) -> b -> Doc a -> b)
-> (forall b a. (b -> a -> b) -> b -> Doc a -> b)
-> (forall b a. (b -> a -> b) -> b -> Doc a -> b)
-> (forall a. (a -> a -> a) -> Doc a -> a)
-> (forall a. (a -> a -> a) -> Doc a -> a)
-> (forall a. Doc a -> [a])
-> (forall a. Doc a -> Bool)
-> (forall a. Doc a -> Int)
-> (forall a. Eq a => a -> Doc a -> Bool)
-> (forall a. Ord a => Doc a -> a)
-> (forall a. Ord a => Doc a -> a)
-> (forall a. Num a => Doc a -> a)
-> (forall a. Num a => Doc a -> a)
-> Foldable Doc
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 :: Doc a -> a
$cproduct :: forall a. Num a => Doc a -> a
sum :: Doc a -> a
$csum :: forall a. Num a => Doc a -> a
minimum :: Doc a -> a
$cminimum :: forall a. Ord a => Doc a -> a
maximum :: Doc a -> a
$cmaximum :: forall a. Ord a => Doc a -> a
elem :: a -> Doc a -> Bool
$celem :: forall a. Eq a => a -> Doc a -> Bool
length :: Doc a -> Int
$clength :: forall a. Doc a -> Int
null :: Doc a -> Bool
$cnull :: forall a. Doc a -> Bool
toList :: Doc a -> [a]
$ctoList :: forall a. Doc a -> [a]
foldl1 :: (a -> a -> a) -> Doc a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Doc a -> a
foldr1 :: (a -> a -> a) -> Doc a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Doc a -> a
foldl' :: (b -> a -> b) -> b -> Doc a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Doc a -> b
foldl :: (b -> a -> b) -> b -> Doc a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Doc a -> b
foldr' :: (a -> b -> b) -> b -> Doc a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Doc a -> b
foldr :: (a -> b -> b) -> b -> Doc a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Doc a -> b
foldMap' :: (a -> m) -> Doc a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Doc a -> m
foldMap :: (a -> m) -> Doc a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Doc a -> m
fold :: Doc m -> m
$cfold :: forall m. Monoid m => Doc m -> m
Foldable, Functor Doc
Foldable Doc
(Functor Doc, Foldable Doc) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Doc a -> f (Doc b))
-> (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 (m :: * -> *) a. Monad m => Doc (m a) -> m (Doc a))
-> Traversable Doc
(a -> f b) -> Doc a -> f (Doc b)
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 :: Doc (m a) -> m (Doc a)
$csequence :: forall (m :: * -> *) a. Monad m => Doc (m a) -> m (Doc a)
mapM :: (a -> m b) -> Doc a -> m (Doc b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Doc a -> m (Doc b)
sequenceA :: Doc (f a) -> f (Doc a)
$csequenceA :: forall (f :: * -> *) a. Applicative f => Doc (f a) -> f (Doc a)
traverse :: (a -> f b) -> Doc a -> f (Doc b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Doc a -> f (Doc b)
$cp2Traversable :: Foldable Doc
$cp1Traversable :: Functor Doc
Traversable,
                  Typeable (Doc a)
DataType
Constr
Typeable (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 (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Doc a))
-> (Doc a -> Constr)
-> (Doc a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Doc a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Doc a)))
-> ((forall b. Data b => b -> b) -> Doc a -> Doc a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Doc a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Doc a -> r)
-> (forall u. (forall d. Data d => d -> u) -> Doc a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> Doc a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Doc a -> m (Doc a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Doc a -> m (Doc a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Doc a -> m (Doc a))
-> Data (Doc a)
Doc a -> DataType
Doc a -> Constr
(forall d. Data d => c (t d)) -> Maybe (c (Doc a))
(forall b. Data b => b -> b) -> Doc a -> Doc a
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Doc a -> c (Doc a)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Doc a)
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 u. Int -> (forall d. Data d => d -> u) -> Doc a -> u
forall u. (forall d. Data d => d -> u) -> Doc a -> [u]
forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> Doc a -> r
forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> Doc a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Doc a -> m (Doc a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Doc a -> m (Doc 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))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c (Doc a))
$cEmpty :: Constr
$cConcat :: Constr
$cBlankLines :: Constr
$cNewLine :: Constr
$cCarriageReturn :: Constr
$cAfterBreak :: Constr
$cBreakingSpace :: Constr
$cFlush :: Constr
$cBeforeNonBlank :: Constr
$cPrefixed :: Constr
$cVFill :: Constr
$cBlock :: Constr
$cText :: Constr
$tDoc :: DataType
gmapMo :: (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 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 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 :: 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 d. Data d => d -> u) -> Doc a -> [u]
$cgmapQ :: forall a u. Data a => (forall d. Data d => d -> u) -> Doc a -> [u]
gmapQr :: (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 :: (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 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 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 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 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)
$cp1Data :: forall a. Data a => Typeable (Doc a)
Data, Typeable, (forall x. Doc a -> Rep (Doc a) x)
-> (forall x. Rep (Doc a) x -> Doc a) -> Generic (Doc a)
forall x. Rep (Doc a) x -> Doc a
forall x. Doc a -> Rep (Doc a) x
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
  x :: Doc a
x <> :: Doc a -> Doc a -> Doc a
<> Empty = Doc a
x
  Empty <> x :: Doc a
x = Doc a
x
  x :: Doc a
x <> y :: Doc a
y     = Doc a -> Doc a -> Doc a
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 = Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: Doc a
mempty = Doc a
forall a. Doc a
Empty

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

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

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

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

-- | Concatenate documents horizontally.
hcat :: [Doc a] -> Doc a
hcat :: [Doc a] -> Doc a
hcat = [Doc a] -> Doc a
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
<+> :: Doc a -> Doc a -> Doc a
(<+>) x :: Doc a
x y :: Doc a
y
  | Doc a -> Bool
forall a. Doc a -> Bool
isEmpty Doc a
x = Doc a
y
  | Doc a -> Bool
forall a. Doc a -> Bool
isEmpty Doc a
y = Doc a
x
  | Bool
otherwise = Doc a
x Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall a. Doc a
space Doc a -> Doc a -> Doc a
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 :: [Doc a] -> Doc a
hsep = (Doc a -> Doc a -> Doc a) -> Doc a -> [Doc a] -> Doc a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Doc a -> Doc a -> Doc a
forall a. Doc 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
$$ :: Doc a -> Doc a -> Doc a
($$) x :: Doc a
x y :: Doc a
y
  | Doc a -> Bool
forall a. Doc a -> Bool
isEmpty Doc a
x = Doc a
y
  | Doc a -> Bool
forall a. Doc a -> Bool
isEmpty Doc a
y = Doc a
x
  | Bool
otherwise = Doc a
x Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall a. Doc a
cr Doc a -> Doc a -> Doc a
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
$+$ :: Doc a -> Doc a -> Doc a
($+$) x :: Doc a
x y :: Doc a
y
  | Doc a -> Bool
forall a. Doc a -> Bool
isEmpty Doc a
x = Doc a
y
  | Doc a -> Bool
forall a. Doc a -> Bool
isEmpty Doc a
y = Doc a
x
  | Bool
otherwise = Doc a
x Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
forall a. Doc a
blankline Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Doc a
y

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

-- | List version of '$+$'.
vsep :: [Doc a] -> Doc a
vsep :: [Doc a] -> Doc a
vsep = (Doc a -> Doc a -> Doc a) -> Doc a -> [Doc a] -> Doc a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Doc a -> Doc a -> Doc a
forall a. Doc 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 :: Doc a -> Doc a
nestle d :: Doc a
d =
  case Doc a
d of
    BlankLines _              -> Doc a
forall a. Doc a
Empty
    NewLine                   -> Doc a
forall a. Doc a
Empty
    Concat (Concat x :: Doc a
x y :: Doc a
y) z :: Doc a
z     -> Doc a -> Doc a
forall a. Doc a -> Doc a
nestle (Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
Concat Doc a
x (Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
Concat Doc a
y Doc a
z))
    Concat BlankLines{} x :: Doc a
x     -> Doc a -> Doc a
forall a. Doc a -> Doc a
nestle Doc a
x
    Concat NewLine x :: Doc a
x          -> Doc a -> Doc a
forall a. Doc a -> Doc a
nestle Doc a
x
    _                         -> Doc a
d

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

type DocState a = State (RenderState a) ()

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

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

outp :: HasChars a => Int -> a -> DocState a
outp :: Int -> a -> DocState a
outp off :: Int
off s :: a
s = do           -- offset >= 0 (0 might be combining char)
  RenderState a
st' <- StateT (RenderState a) Identity (RenderState a)
forall s (m :: * -> *). MonadState s m => m s
get
  let pref :: a
pref = String -> a
forall a. IsString a => String -> a
fromString (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ RenderState a -> Text
forall a. RenderState a -> Text
prefix RenderState a
st'
  Bool -> DocState a -> DocState a
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RenderState a -> Int
forall a. RenderState a -> Int
column RenderState a
st' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& RenderState a -> Bool
forall a. RenderState a -> Bool
usePrefix RenderState a
st' Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. HasChars a => a -> Bool
isNull a
pref)) (DocState a -> DocState a) -> DocState a -> DocState a
forall a b. (a -> b) -> a -> b
$
    (RenderState a -> RenderState a) -> DocState a
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((RenderState a -> RenderState a) -> DocState a)
-> (RenderState a -> RenderState a) -> DocState a
forall a b. (a -> b) -> a -> b
$ \st :: RenderState a
st -> RenderState a
st{ output :: [a]
output = a
pref a -> [a] -> [a]
forall a. a -> [a] -> [a]
: RenderState a -> [a]
forall a. RenderState a -> [a]
output RenderState a
st
                    , column :: Int
column = RenderState a -> Int
forall a. RenderState a -> Int
column RenderState a
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a. HasChars a => a -> Int
realLength a
pref }
  (RenderState a -> RenderState a) -> DocState a
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((RenderState a -> RenderState a) -> DocState a)
-> (RenderState a -> RenderState a) -> DocState a
forall a b. (a -> b) -> a -> b
$ \st :: RenderState a
st -> RenderState a
st{ output :: [a]
output = a
s a -> [a] -> [a]
forall a. a -> [a] -> [a]
: RenderState a -> [a]
forall a. RenderState a -> [a]
output RenderState a
st
                    , column :: Int
column = RenderState a -> Int
forall a. RenderState a -> Int
column RenderState a
st Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
off
                    , newlines :: Int
newlines = 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 :: Maybe Int -> Doc a -> a
render linelen :: Maybe Int
linelen doc :: Doc a
doc = [a] -> a
forall a. Monoid a => [a] -> a
mconcat ([a] -> a) -> (RenderState a -> [a]) -> RenderState a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. [a] -> [a]
reverse ([a] -> [a]) -> (RenderState a -> [a]) -> RenderState a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderState a -> [a]
forall a. RenderState a -> [a]
output (RenderState a -> a) -> RenderState a -> a
forall a b. (a -> b) -> a -> b
$
  State (RenderState a) () -> RenderState a -> RenderState a
forall s a. State s a -> s -> s
execState (Doc a -> State (RenderState a) ()
forall a. HasChars a => Doc a -> DocState a
renderDoc Doc a
doc) RenderState a
forall a. RenderState a
startingState
   where startingState :: RenderState a
startingState = RenderState :: forall a.
[a] -> Text -> Bool -> Maybe Int -> Int -> Int -> RenderState a
RenderState{
                            output :: [a]
output = [a]
forall a. Monoid a => a
mempty
                          , prefix :: Text
prefix = Text
forall a. Monoid a => a
mempty
                          , usePrefix :: Bool
usePrefix = Bool
True
                          , lineLength :: Maybe Int
lineLength = Maybe Int
linelen
                          , column :: Int
column = 0
                          , newlines :: Int
newlines = 2 }

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


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

-- | Create a 'Doc' from a stringlike value.
literal :: HasChars a => a -> Doc a
literal :: a -> Doc a
literal x :: a
x =
  [Doc a] -> Doc a
forall a. Monoid a => [a] -> a
mconcat ([Doc a] -> Doc a) -> [Doc a] -> Doc a
forall a b. (a -> b) -> a -> b
$
    Doc a -> [Doc a] -> [Doc a]
forall a. a -> [a] -> [a]
intersperse Doc a
forall a. Doc a
NewLine ([Doc a] -> [Doc a]) -> [Doc a] -> [Doc a]
forall a b. (a -> b) -> a -> b
$
      (a -> Doc a) -> [a] -> [Doc a]
forall a b. (a -> b) -> [a] -> [b]
map (\s :: a
s -> if a -> Bool
forall a. HasChars a => a -> Bool
isNull a
s
                    then Doc a
forall a. Doc a
Empty
                    else Int -> a -> Doc a
forall a. Int -> a -> Doc a
Text (a -> Int
forall a. HasChars a => a -> Int
realLength a
s) a
s) ([a] -> [Doc a]) -> [a] -> [Doc a]
forall a b. (a -> b) -> a -> b
$
        a -> [a]
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 :: String -> Doc a
text = a -> Doc a
forall a. HasChars a => a -> Doc a
literal (a -> Doc a) -> (String -> a) -> String -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
forall a. IsString a => String -> a
fromString

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

-- | A breaking (reflowable) space.
space :: Doc a
space :: Doc a
space = Doc a
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 :: Doc a
cr = Doc a
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 :: Doc a
blankline = Int -> Doc a
forall a. Int -> Doc a
BlankLines 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 :: Int -> Doc a
blanklines = Int -> Doc a
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 :: String -> Doc a -> Doc a
prefixed pref :: String
pref doc :: Doc a
doc
  | Doc a -> Bool
forall a. Doc a -> Bool
isEmpty Doc a
doc = Doc a
forall a. Doc a
Empty
  | Bool
otherwise   = Text -> Doc a -> Doc a
forall a. Text -> Doc a -> Doc a
Prefixed (String -> Text
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 :: Doc a -> Doc a
flush doc :: Doc a
doc
  | Doc a -> Bool
forall a. Doc a -> Bool
isEmpty Doc a
doc = Doc a
forall a. Doc a
Empty
  | Bool
otherwise   = Doc a -> Doc a
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 :: Int -> Doc a -> Doc a
nest ind :: Int
ind = String -> Doc a -> Doc a
forall a. IsString a => String -> Doc a -> Doc a
prefixed (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
ind ' ')

-- | 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 :: Int -> Doc a -> Doc a -> Doc a
hang ind :: Int
ind start :: Doc a
start doc :: Doc a
doc = Doc a
start Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
<> Int -> Doc a -> Doc 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 :: Doc a -> Doc a
beforeNonBlank = Doc a -> Doc a
forall a. Doc a -> Doc a
BeforeNonBlank

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

-- | Returns the width of a 'Doc'.
offset :: (IsString a, HasChars a) => Doc a -> Int
offset :: Doc a -> Int
offset (Text n :: Int
n _) = Int
n
offset (Block n :: Int
n _) = Int
n
offset (VFill n :: Int
n _) = Int
n
offset Empty = 0
offset CarriageReturn = 0
offset NewLine = 0
offset (BlankLines _) = 0
offset d :: Doc a
d = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (a -> Int) -> [a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map a -> Int
forall a. HasChars a => a -> Int
realLength (a -> [a]
forall a. HasChars a => a -> [a]
splitLines (Maybe Int -> Doc a -> a
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
forall a. Maybe a
Nothing Doc a
d)))

-- | Returns the minimal width of a 'Doc' when reflowed at breakable spaces.
minOffset :: HasChars a => Doc a -> Int
minOffset :: Doc a -> Int
minOffset (Text n :: Int
n _) = Int
n
minOffset (Block n :: Int
n _) = Int
n
minOffset (VFill n :: Int
n _) = Int
n
minOffset Empty = 0
minOffset CarriageReturn = 0
minOffset NewLine = 0
minOffset (BlankLines _) = 0
minOffset d :: Doc a
d = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: (a -> Int) -> [a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map a -> Int
forall a. HasChars a => a -> Int
realLength (a -> [a]
forall a. HasChars a => a -> [a]
splitLines (Maybe Int -> Doc a -> a
forall a. HasChars a => Maybe Int -> Doc a -> a
render (Int -> Maybe Int
forall a. a -> Maybe a
Just 0) Doc a
d)))

-- | Returns the column that would be occupied by the last
-- laid out character (assuming no wrapping).
updateColumn :: HasChars a => Doc a -> Int -> Int
updateColumn :: Doc a -> Int -> Int
updateColumn (Text !Int
n _) !Int
k = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
updateColumn (Block !Int
n _) !Int
k = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
updateColumn (VFill !Int
n _) !Int
k = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n
updateColumn Empty _ = 0
updateColumn CarriageReturn _ = 0
updateColumn NewLine _ = 0
updateColumn (BlankLines _) _ = 0
updateColumn d :: Doc a
d !Int
k =
  case a -> [a]
forall a. HasChars a => a -> [a]
splitLines (Maybe Int -> Doc a -> a
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
forall a. Maybe a
Nothing Doc a
d) of
    []   -> Int
k
    [t :: a
t]  -> Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ a -> Int
forall a. HasChars a => a -> Int
realLength a
t
    ts :: [a]
ts   -> a -> Int
forall a. HasChars a => a -> Int
realLength (a -> Int) -> a -> Int
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. [a] -> a
last [a]
ts

-- | @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 :: Int -> Doc a -> Doc a
lblock = (a -> a) -> Int -> Doc a -> Doc a
forall a. HasChars a => (a -> a) -> Int -> Doc a -> Doc a
block a -> a
forall a. a -> a
id

-- | Like 'lblock' but aligned to the right.
rblock :: HasChars a => Int -> Doc a -> Doc a
rblock :: Int -> Doc a -> Doc a
rblock w :: Int
w = (a -> a) -> Int -> Doc a -> Doc a
forall a. HasChars a => (a -> a) -> Int -> Doc a -> Doc a
block (\s :: a
s -> Int -> Char -> a
forall a. HasChars a => Int -> Char -> a
replicateChar (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- a -> Int
forall a. HasChars a => a -> Int
realLength a
s) ' ' a -> a -> a
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 :: Int -> Doc a -> Doc a
cblock w :: Int
w = (a -> a) -> Int -> Doc a -> Doc a
forall a. HasChars a => (a -> a) -> Int -> Doc a -> Doc a
block (\s :: a
s -> Int -> Char -> a
forall a. HasChars a => Int -> Char -> a
replicateChar ((Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
- a -> Int
forall a. HasChars a => a -> Int
realLength a
s) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2) ' ' a -> a -> a
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 :: Doc a -> Int
height = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int) -> (Doc a -> [a]) -> Doc a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
forall a. HasChars a => a -> [a]
splitLines (a -> [a]) -> (Doc a -> a) -> Doc a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Int -> Doc a -> a
forall a. HasChars a => Maybe Int -> Doc a -> a
render Maybe Int
forall a. Maybe a
Nothing

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

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

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

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

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

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

-- | Wraps a 'Doc' in double quotes.
doubleQuotes :: HasChars a => Doc a -> Doc a
doubleQuotes :: Doc a -> Doc a
doubleQuotes = Doc a -> Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a -> Doc a
inside (Char -> Doc a
forall a. HasChars a => Char -> Doc a
char '"') (Char -> Doc a
forall a. HasChars a => Char -> Doc a
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.
charWidth :: Char -> Int
charWidth :: Char -> Int
charWidth c :: Char
c = Int
-> ((Int, UnicodeWidthMatch) -> Int)
-> Maybe (Int, UnicodeWidthMatch)
-> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 1 (UnicodeWidthMatch -> Int
specificWidth (UnicodeWidthMatch -> Int)
-> ((Int, UnicodeWidthMatch) -> UnicodeWidthMatch)
-> (Int, UnicodeWidthMatch)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, UnicodeWidthMatch) -> UnicodeWidthMatch
forall a b. (a, b) -> b
snd) (Maybe (Int, UnicodeWidthMatch) -> Int)
-> Maybe (Int, UnicodeWidthMatch) -> Int
forall a b. (a -> b) -> a -> b
$ Int -> IntMap UnicodeWidthMatch -> Maybe (Int, UnicodeWidthMatch)
forall a. Int -> IntMap a -> Maybe (Int, a)
IM.lookupLE (Char -> Int
ord Char
c) IntMap UnicodeWidthMatch
unicodeWidthMap

-- | Get real length of string, taking into account combining and double-wide
-- characters.
realLength :: HasChars a => a -> Int
realLength :: a -> Int
realLength = (MatchState -> Char -> MatchState) -> a -> Int
forall a.
HasChars a =>
(MatchState -> Char -> MatchState) -> a -> Int
realLengthWith MatchState -> Char -> MatchState
updateMatchState

-- | Get real length of string, taking into account combining and double-wide
-- characters, without taking any shortcuts. This should give the same answer
-- as 'updateMatchState', but will be slower. It is here to test that the
-- shortcuts are implemented correctly.
realLengthNoShortcut :: HasChars a => a -> Int
realLengthNoShortcut :: a -> Int
realLengthNoShortcut = (MatchState -> Char -> MatchState) -> a -> Int
forall a.
HasChars a =>
(MatchState -> Char -> MatchState) -> a -> Int
realLengthWith MatchState -> Char -> MatchState
updateMatchStateNoShortcut

-- | Get real length of string, taking into account combining and double-wide
-- characters, using the given accumulator.
realLengthWith :: HasChars a => (MatchState -> Char -> MatchState) -> a -> Int
realLengthWith :: (MatchState -> Char -> MatchState) -> a -> Int
realLengthWith f :: MatchState -> Char -> MatchState
f = MatchState -> Int
extractLength (MatchState -> Int) -> (a -> MatchState) -> a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MatchState -> Char -> MatchState) -> MatchState -> a -> MatchState
forall a b. HasChars a => (b -> Char -> b) -> b -> a -> b
foldlChar MatchState -> Char -> MatchState
f (Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
True 0 0 Maybe EmojiMap
forall a. Monoid a => a
mempty)
  where
    extractLength :: MatchState -> Int
extractLength (MatchState _ tot :: Int
tot w :: Int
w _) = Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w

-- | Update a 'MatchState' by processing a character.
updateMatchState :: MatchState -> Char -> MatchState
updateMatchState :: MatchState -> Char -> MatchState
updateMatchState (MatchState first :: Bool
first tot :: Int
tot _ Nothing) !Char
c
    -- For efficiency, we isolate commonly used portions of the basic
    -- multilingual plane that do not have emoji in them.
    -- Maximum contiguous range containing ASCII alphabetic characters and no emoji
    | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '\x00A8'                                   = Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False (Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) 0 Maybe EmojiMap
forall a. Maybe a
Nothing
    -- Combining characters have width 0
    | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '\x0300' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '\x036F'                  = Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False (if Bool
first then Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 else Int
tot) 0 Maybe EmojiMap
forall a. Maybe a
Nothing
    -- A block of width 1
    | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '\x0370' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '\x10FC'                  = Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False (Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) 0 Maybe EmojiMap
forall a. Maybe a
Nothing
    -- Hexagrams are width 1
    | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '\x4DC0' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '\x4DFF'                  = Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False (Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) 0 Maybe EmojiMap
forall a. Maybe a
Nothing
    -- Maximum contiguous range of width 2 with no emoji containing CJK
    | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '\x329a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '\xA4C6'                  = Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False (Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) 0 Maybe EmojiMap
forall a. Maybe a
Nothing
    -- An ambiguous block; TODO: should be width 2 if surrounded by wide, 1 otherwise
    | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= '\x3248' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= '\x324F'                  = Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False (Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) 0 Maybe EmojiMap
forall a. Maybe a
Nothing
    -- A width 1 straggler
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\x303F'                                   = Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False (Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) 0 Maybe EmojiMap
forall a. Maybe a
Nothing
updateMatchState s :: MatchState
s c :: Char
c = MatchState -> Char -> MatchState
updateMatchStateNoShortcut MatchState
s Char
c

-- | Update a 'MatchState' by processing a character, without taking any
-- shortcuts. This should give the same answer as 'updateMatchState', 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 first :: Bool
first tot :: Int
tot _ Nothing) !Char
c =
    case Int -> IntMap UnicodeWidthMatch -> Maybe (Int, UnicodeWidthMatch)
forall a. Int -> IntMap a -> Maybe (Int, a)
IM.lookupLE Int
oc IntMap UnicodeWidthMatch
unicodeWidthMap of
        -- If there is a specific match, record the tentative width, the map of
        -- continuations, and move to the next character
        Just (!Int
oc', SpecificMatch r :: Int
r w :: Maybe Int
w m :: EmojiMap
m) | Int
oc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
oc' -> Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False Int
tot (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
r Maybe Int
w) (EmojiMap -> Maybe EmojiMap
forall a. a -> Maybe a
Just EmojiMap
m)
        -- If there is only a range match, record the total width and move to
        -- the next character
        Just (!Int
_, !UnicodeWidthMatch
match) -> let r :: Int
r = UnicodeWidthMatch -> Int
rangeWidth UnicodeWidthMatch
match
                                 -- If the string starts with a combining character.  Since there is no
                                 -- preceding character, we count 0 width as 1 in this one case:
                                 r' :: Int
r' = if Bool
first Bool -> Bool -> Bool
&& Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then 1 else Int
r
                              in Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False (Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r') 0 Maybe EmojiMap
forall a. Maybe a
Nothing
        -- M.lookupLE should not fail
        Nothing -> Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False (Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) 0 Maybe EmojiMap
forall a. Maybe a
Nothing
  where
    oc :: Int
oc = Char -> Int
ord Char
c
updateMatchStateNoShortcut (MatchState _ tot :: Int
tot w :: Int
w (Just !EmojiMap
m)) !Char
c
    -- Skin tone modifiers and 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.
    | Char -> Bool
isEmojiModifier Char
c Bool -> Bool -> Bool
|| Char -> Bool
isEmojiVariation Char
c = Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False Int
tot 2 (EmojiMap -> Maybe EmojiMap
forall a. a -> Maybe a
Just EmojiMap
m)
    -- Zero width joiners will join two emoji together, so let's discard the state and parse the next emoji
    | Char -> Bool
isEmojiJoiner Char
c = Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False Int
tot 2 Maybe EmojiMap
forall a. Maybe a
Nothing
    -- Otherwise, lookup the emoji continuations
    | Bool
otherwise = case Int -> EmojiMap -> Maybe Emoji
forall a. Int -> IntMap a -> Maybe a
IM.lookup (Char -> Int
ord Char
c) EmojiMap
m of
        -- Continuations match, move to the next step with new continuations
        Just (Emoji ew :: Int
ew m' :: EmojiMap
m') -> Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False Int
tot Int
ew (EmojiMap -> Maybe EmojiMap
forall a. a -> Maybe a
Just EmojiMap
m')
        -- No continuations match, use the tentative width and process c without continuations
        -- I guess we use shortcuts here; that's probably fine.
        Nothing -> MatchState -> Char -> MatchState
updateMatchState (Bool -> Int -> Int -> Maybe EmojiMap -> MatchState
MatchState Bool
False (Int
tot Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
w) 0 Maybe EmojiMap
forall a. Maybe a
Nothing) Char
c

-- | Keeps track of state in length calculations, determining whether we're at
-- the first character, the width so far, the tentative width for this group,
-- and the Map for possible emoji continuations.
data MatchState = MatchState !Bool !Int !Int !(Maybe EmojiMap)

-- | A possible match for unicode characters; either within a range block, or a
-- specific match with a block range width, possibly a specific width, and a map of
-- continuations.
data UnicodeWidthMatch
    = RangeSeparator !Int                         -- This code point marks the boundary of a range
    | SpecificMatch !Int !(Maybe Int) !EmojiMap   -- This code point has a specific emoji with continuations
  deriving (Int -> UnicodeWidthMatch -> String -> String
[UnicodeWidthMatch] -> String -> String
UnicodeWidthMatch -> String
(Int -> UnicodeWidthMatch -> String -> String)
-> (UnicodeWidthMatch -> String)
-> ([UnicodeWidthMatch] -> String -> String)
-> Show UnicodeWidthMatch
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [UnicodeWidthMatch] -> String -> String
$cshowList :: [UnicodeWidthMatch] -> String -> String
show :: UnicodeWidthMatch -> String
$cshow :: UnicodeWidthMatch -> String
showsPrec :: Int -> UnicodeWidthMatch -> String -> String
$cshowsPrec :: Int -> UnicodeWidthMatch -> String -> String
Show)

instance Semigroup UnicodeWidthMatch where
    (SpecificMatch r :: Int
r w1 :: Maybe Int
w1 m1 :: EmojiMap
m1) <> :: UnicodeWidthMatch -> UnicodeWidthMatch -> UnicodeWidthMatch
<> (SpecificMatch _ w2 :: Maybe Int
w2 m2 :: EmojiMap
m2) = Int -> Maybe Int -> EmojiMap -> UnicodeWidthMatch
SpecificMatch Int
r Maybe Int
w (EmojiMap -> UnicodeWidthMatch) -> EmojiMap -> UnicodeWidthMatch
forall a b. (a -> b) -> a -> b
$ EmojiMap -> EmojiMap -> EmojiMap
concatEmojiMap EmojiMap
m1 EmojiMap
m2
      where
        w :: Maybe Int
w = Sum Int -> Int
forall a. Sum a -> a
getSum (Sum Int -> Int) -> Maybe (Sum Int) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int) -> Maybe Int -> Maybe (Sum Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
w1) Maybe (Sum Int) -> Maybe (Sum Int) -> Maybe (Sum Int)
forall a. Semigroup a => a -> a -> a
<> (Int -> Sum Int
forall a. a -> Sum a
Sum (Int -> Sum Int) -> Maybe Int -> Maybe (Sum Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
w2)
    s :: UnicodeWidthMatch
s <> _ = UnicodeWidthMatch
s

-- | The width of the block in which the character lies, ignoring specific
-- matches.
rangeWidth :: UnicodeWidthMatch -> Int
rangeWidth :: UnicodeWidthMatch -> Int
rangeWidth (RangeSeparator !Int
r)    = Int
r
rangeWidth (SpecificMatch !Int
r !Maybe Int
_ !EmojiMap
_) = Int
r

-- | The specific width of a character.
specificWidth :: UnicodeWidthMatch -> Int
specificWidth :: UnicodeWidthMatch -> Int
specificWidth (RangeSeparator r :: Int
r)    = Int
r
specificWidth (SpecificMatch r :: Int
r w :: Maybe Int
w _) = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
r Maybe Int
w

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

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

-- | Checks whether a character is an emoji joiner.
isEmojiJoiner :: Char -> Bool
isEmojiJoiner :: Char -> Bool
isEmojiJoiner c :: Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\x200D'

-- | A map for looking up the width of Unicode text.
unicodeWidthMap :: IM.IntMap UnicodeWidthMatch
unicodeWidthMap :: IntMap UnicodeWidthMatch
unicodeWidthMap =
    (Text -> IntMap UnicodeWidthMatch -> IntMap UnicodeWidthMatch)
-> IntMap UnicodeWidthMatch -> [Text] -> IntMap UnicodeWidthMatch
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> IntMap UnicodeWidthMatch -> IntMap UnicodeWidthMatch
addEmoji IntMap UnicodeWidthMatch
unicodeRangeMap
    ([Text] -> IntMap UnicodeWidthMatch)
-> ([Text] -> [Text]) -> [Text] -> IntMap UnicodeWidthMatch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> ((Char, Text) -> Bool) -> Maybe (Char, Text) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Bool -> Bool
not (Bool -> Bool) -> ((Char, Text) -> Bool) -> (Char, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isKeypad (Char -> Bool) -> ((Char, Text) -> Char) -> (Char, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, Text) -> Char
forall a b. (a, b) -> a
fst) (Maybe (Char, Text) -> Bool)
-> (Text -> Maybe (Char, Text)) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe (Char, Text)
T.uncons)  -- Keypad emoji can be handles by base rules
    ([Text] -> IntMap UnicodeWidthMatch)
-> [Text] -> IntMap UnicodeWidthMatch
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isEmojiModifier)                   -- Emoji modifiers are inferred from the base emoji
    [Text]
baseEmojis
  where
    isKeypad :: Char -> Bool
isKeypad c :: Char
c = Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '*' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '#'

-- | Denotes the contiguous ranges of Unicode characters which have a given
-- width: 1 for a regular character, 2 for an East Asian wide character. Emoji
-- have different widths and lie within some of these blocks. And the emoji
-- will be added later.
unicodeRangeMap :: IM.IntMap UnicodeWidthMatch
unicodeRangeMap :: IntMap UnicodeWidthMatch
unicodeRangeMap = [(Int, UnicodeWidthMatch)] -> IntMap UnicodeWidthMatch
forall a. [(Int, a)] -> IntMap a
IM.fromList ([(Int, UnicodeWidthMatch)] -> IntMap UnicodeWidthMatch)
-> [(Int, UnicodeWidthMatch)] -> IntMap UnicodeWidthMatch
forall a b. (a -> b) -> a -> b
$ ((Char, UnicodeWidthMatch) -> (Int, UnicodeWidthMatch))
-> [(Char, UnicodeWidthMatch)] -> [(Int, UnicodeWidthMatch)]
forall a b. (a -> b) -> [a] -> [b]
map (\(c :: Char
c, x :: UnicodeWidthMatch
x) -> (Char -> Int
ord Char
c, UnicodeWidthMatch
x))
    [ ('\x0000', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x0300', Int -> UnicodeWidthMatch
RangeSeparator 0)  -- combining
    , ('\x0370', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x1100', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\x1160', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x11A3', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\x11A8', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x11FA', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\x1200', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x1AB0', Int -> UnicodeWidthMatch
RangeSeparator 0)  -- combining
    , ('\x1B00', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x1DC0', Int -> UnicodeWidthMatch
RangeSeparator 0)  -- combining
    , ('\x1E00', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x200B', Int -> UnicodeWidthMatch
RangeSeparator 0)  -- zero-width characters and directional overrides
    , ('\x2010', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x20D0', Int -> UnicodeWidthMatch
RangeSeparator 0)  -- combining
    , ('\x2100', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x2329', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\x232B', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x2E80', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\x303F', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x3041', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\x3248', Int -> UnicodeWidthMatch
RangeSeparator 1)  -- ambiguous
    , ('\x3250', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\x4DC0', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x4E00', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\xA4D0', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\xA960', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\xA980', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\xAC00', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\xD800', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\xE000', Int -> UnicodeWidthMatch
RangeSeparator 1)  -- ambiguous
    , ('\xF900', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\xFB00', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\xFE00', Int -> UnicodeWidthMatch
RangeSeparator 1)  -- ambiguous
    , ('\xFE10', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\xFE20', Int -> UnicodeWidthMatch
RangeSeparator 0)  -- combining
    , ('\xFE30', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\xFE70', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\xFF01', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\xFF61', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x1B000', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\x1D000', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x1F200', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\x1F300', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x1F3FB', Int -> UnicodeWidthMatch
RangeSeparator 2)  -- skin tone modifiers
    , ('\x1F400', Int -> UnicodeWidthMatch
RangeSeparator 1)
    , ('\x20000', Int -> UnicodeWidthMatch
RangeSeparator 2)
    , ('\x3FFFD', Int -> UnicodeWidthMatch
RangeSeparator 1)
    ]

type EmojiMap = IM.IntMap Emoji
data Emoji = Emoji !Int !EmojiMap
  deriving (Int -> Emoji -> String -> String
[Emoji] -> String -> String
Emoji -> String
(Int -> Emoji -> String -> String)
-> (Emoji -> String) -> ([Emoji] -> String -> String) -> Show Emoji
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Emoji] -> String -> String
$cshowList :: [Emoji] -> String -> String
show :: Emoji -> String
$cshow :: Emoji -> String
showsPrec :: Int -> Emoji -> String -> String
$cshowsPrec :: Int -> Emoji -> String -> String
Show)

concatEmojiMap :: EmojiMap -> EmojiMap -> EmojiMap
concatEmojiMap :: EmojiMap -> EmojiMap -> EmojiMap
concatEmojiMap = (Emoji -> Emoji -> Emoji) -> EmojiMap -> EmojiMap -> EmojiMap
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
IM.unionWith (\(Emoji w :: Int
w e1 :: EmojiMap
e1) (Emoji _ e2 :: EmojiMap
e2) -> Int -> EmojiMap -> Emoji
Emoji Int
w (EmojiMap -> Emoji) -> EmojiMap -> Emoji
forall a b. (a -> b) -> a -> b
$ EmojiMap -> EmojiMap -> EmojiMap
concatEmojiMap EmojiMap
e1 EmojiMap
e2)

emojiToMatch :: IM.IntMap UnicodeWidthMatch -> NonEmpty Char -> UnicodeWidthMatch
emojiToMatch :: IntMap UnicodeWidthMatch -> NonEmpty Char -> UnicodeWidthMatch
emojiToMatch m :: IntMap UnicodeWidthMatch
m (x :: Char
x:|xs :: String
xs) = Int -> Maybe Int -> EmojiMap -> UnicodeWidthMatch
SpecificMatch Int
r Maybe Int
w (EmojiMap -> UnicodeWidthMatch)
-> (String -> EmojiMap) -> String -> UnicodeWidthMatch
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> EmojiMap
emojiToMap (String -> UnicodeWidthMatch) -> String -> UnicodeWidthMatch
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isEmojiVariation) String
xs
  where
    r :: Int
r = Int
-> ((Int, UnicodeWidthMatch) -> Int)
-> Maybe (Int, UnicodeWidthMatch)
-> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 1 (UnicodeWidthMatch -> Int
rangeWidth (UnicodeWidthMatch -> Int)
-> ((Int, UnicodeWidthMatch) -> UnicodeWidthMatch)
-> (Int, UnicodeWidthMatch)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, UnicodeWidthMatch) -> UnicodeWidthMatch
forall a b. (a, b) -> b
snd) (Maybe (Int, UnicodeWidthMatch) -> Int)
-> Maybe (Int, UnicodeWidthMatch) -> Int
forall a b. (a -> b) -> a -> b
$ Int -> IntMap UnicodeWidthMatch -> Maybe (Int, UnicodeWidthMatch)
forall a. Int -> IntMap a -> Maybe (Int, a)
IM.lookupLT (Char -> Int
ord Char
x) IntMap UnicodeWidthMatch
m
    -- If it is a single code point emoji, it is of width 2. Otherwise, don't
    -- overwrite the range width.
    w :: Maybe Int
w = if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
xs then Int -> Maybe Int
forall a. a -> Maybe a
Just 2 else Maybe Int
forall a. Maybe a
Nothing

addEmoji :: Text -> IM.IntMap UnicodeWidthMatch -> IM.IntMap UnicodeWidthMatch
addEmoji :: Text -> IntMap UnicodeWidthMatch -> IntMap UnicodeWidthMatch
addEmoji !Text
emoji !IntMap UnicodeWidthMatch
m = case Text -> String
T.unpack Text
emoji of
    []   -> IntMap UnicodeWidthMatch
m
    x :: Char
x:xs :: String
xs -> (UnicodeWidthMatch -> UnicodeWidthMatch -> UnicodeWidthMatch)
-> Int
-> UnicodeWidthMatch
-> IntMap UnicodeWidthMatch
-> IntMap UnicodeWidthMatch
forall a. (a -> a -> a) -> Int -> a -> IntMap a -> IntMap a
IM.insertWith UnicodeWidthMatch -> UnicodeWidthMatch -> UnicodeWidthMatch
forall a. Semigroup a => a -> a -> a
(<>) (Char -> Int
ord Char
x) (IntMap UnicodeWidthMatch -> NonEmpty Char -> UnicodeWidthMatch
emojiToMatch IntMap UnicodeWidthMatch
m (Char
xChar -> String -> NonEmpty Char
forall a. a -> [a] -> NonEmpty a
:|String
xs)) IntMap UnicodeWidthMatch
m

emojiToMap :: String -> EmojiMap
emojiToMap :: String -> EmojiMap
emojiToMap []     = EmojiMap
forall a. Monoid a => a
mempty
emojiToMap (x :: Char
x:xs :: String
xs) = Int -> Emoji -> EmojiMap
forall a. Int -> a -> IntMap a
IM.singleton (Char -> Int
ord Char
x) (Emoji -> EmojiMap) -> (EmojiMap -> Emoji) -> EmojiMap -> EmojiMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> EmojiMap -> Emoji
Emoji 2 (EmojiMap -> EmojiMap) -> EmojiMap -> EmojiMap
forall a b. (a -> b) -> a -> b
$ String -> EmojiMap
emojiToMap String
xs