--------------------------------------------------------------------------------
-- | This is a small pretty-printing library.
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards            #-}
module Patat.PrettyPrint.Internal
    ( Control (..)
    , Chunk (..)
    , Chunks
    , chunkToString
    , chunkLines

    , DocE (..)
    , chunkToDocE

    , Indentation (..)

    , Doc (..)
    , docToChunks

    , toString
    , dimensions
    , null

    , hPutDoc
    , putDoc
    , mkDoc
    , string
    ) where


--------------------------------------------------------------------------------
import           Control.Monad.Reader       (asks, local)
import           Control.Monad.RWS          (RWS, runRWS)
import           Control.Monad.State        (get, modify)
import           Control.Monad.Writer       (tell)
import           Data.Char.WCWidth.Extended (wcstrwidth)
import qualified Data.List                  as L
import           Data.String                (IsString (..))
import           Prelude                    hiding (null)
import qualified System.Console.ANSI        as Ansi
import qualified System.IO                  as IO


--------------------------------------------------------------------------------
-- | Control actions for the terminal.
data Control
    = ClearScreenControl
    | GoToLineControl Int
    deriving (Control -> Control -> Bool
(Control -> Control -> Bool)
-> (Control -> Control -> Bool) -> Eq Control
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Control -> Control -> Bool
== :: Control -> Control -> Bool
$c/= :: Control -> Control -> Bool
/= :: Control -> Control -> Bool
Eq, Int -> Control -> ShowS
[Control] -> ShowS
Control -> String
(Int -> Control -> ShowS)
-> (Control -> String) -> ([Control] -> ShowS) -> Show Control
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Control -> ShowS
showsPrec :: Int -> Control -> ShowS
$cshow :: Control -> String
show :: Control -> String
$cshowList :: [Control] -> ShowS
showList :: [Control] -> ShowS
Show)


--------------------------------------------------------------------------------
-- | A simple chunk of text.  All ANSI codes are "reset" after printing.
data Chunk
    = StringChunk [Ansi.SGR] String
    | NewlineChunk
    | ControlChunk Control
    deriving (Chunk -> Chunk -> Bool
(Chunk -> Chunk -> Bool) -> (Chunk -> Chunk -> Bool) -> Eq Chunk
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Chunk -> Chunk -> Bool
== :: Chunk -> Chunk -> Bool
$c/= :: Chunk -> Chunk -> Bool
/= :: Chunk -> Chunk -> Bool
Eq, Int -> Chunk -> ShowS
Chunks -> ShowS
Chunk -> String
(Int -> Chunk -> ShowS)
-> (Chunk -> String) -> (Chunks -> ShowS) -> Show Chunk
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Chunk -> ShowS
showsPrec :: Int -> Chunk -> ShowS
$cshow :: Chunk -> String
show :: Chunk -> String
$cshowList :: Chunks -> ShowS
showList :: Chunks -> ShowS
Show)


--------------------------------------------------------------------------------
type Chunks = [Chunk]


--------------------------------------------------------------------------------
hPutChunk :: IO.Handle -> Chunk -> IO ()
hPutChunk :: Handle -> Chunk -> IO ()
hPutChunk Handle
h Chunk
NewlineChunk = Handle -> String -> IO ()
IO.hPutStrLn Handle
h String
""
hPutChunk Handle
h (StringChunk [SGR]
codes String
str) = do
    Handle -> [SGR] -> IO ()
Ansi.hSetSGR Handle
h ([SGR] -> [SGR]
forall a. [a] -> [a]
reverse [SGR]
codes)
    Handle -> String -> IO ()
IO.hPutStr Handle
h String
str
    Handle -> [SGR] -> IO ()
Ansi.hSetSGR Handle
h [SGR
Ansi.Reset]
hPutChunk Handle
h (ControlChunk Control
ctrl) = case Control
ctrl of
    Control
ClearScreenControl -> Handle -> IO ()
Ansi.hClearScreen Handle
h
    GoToLineControl Int
l  -> Handle -> Int -> Int -> IO ()
Ansi.hSetCursorPosition Handle
h Int
l Int
0


--------------------------------------------------------------------------------
chunkToString :: Chunk -> String
chunkToString :: Chunk -> String
chunkToString Chunk
NewlineChunk        = String
"\n"
chunkToString (StringChunk [SGR]
_ String
str) = String
str
chunkToString (ControlChunk Control
_)    = String
""


--------------------------------------------------------------------------------
-- | If two neighboring chunks have the same set of ANSI codes, we can group
-- them together.
optimizeChunks :: Chunks -> Chunks
optimizeChunks :: Chunks -> Chunks
optimizeChunks (StringChunk [SGR]
c1 String
s1 : StringChunk [SGR]
c2 String
s2 : Chunks
chunks)
    | [SGR]
c1 [SGR] -> [SGR] -> Bool
forall a. Eq a => a -> a -> Bool
== [SGR]
c2  = Chunks -> Chunks
optimizeChunks ([SGR] -> String -> Chunk
StringChunk [SGR]
c1 (String
s1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
s2) Chunk -> Chunks -> Chunks
forall a. a -> [a] -> [a]
: Chunks
chunks)
    | Bool
otherwise =
        [SGR] -> String -> Chunk
StringChunk [SGR]
c1 String
s1 Chunk -> Chunks -> Chunks
forall a. a -> [a] -> [a]
: Chunks -> Chunks
optimizeChunks ([SGR] -> String -> Chunk
StringChunk [SGR]
c2 String
s2 Chunk -> Chunks -> Chunks
forall a. a -> [a] -> [a]
: Chunks
chunks)
optimizeChunks (Chunk
x : Chunks
chunks) = Chunk
x Chunk -> Chunks -> Chunks
forall a. a -> [a] -> [a]
: Chunks -> Chunks
optimizeChunks Chunks
chunks
optimizeChunks [] = []


--------------------------------------------------------------------------------
chunkLines :: Chunks -> [Chunks]
chunkLines :: Chunks -> [Chunks]
chunkLines Chunks
chunks = case (Chunk -> Bool) -> Chunks -> (Chunks, Chunks)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Chunk -> Chunk -> Bool
forall a. Eq a => a -> a -> Bool
== Chunk
NewlineChunk) Chunks
chunks of
    (Chunks
xs, Chunk
_newline : Chunks
ys) -> Chunks
xs Chunks -> [Chunks] -> [Chunks]
forall a. a -> [a] -> [a]
: Chunks -> [Chunks]
chunkLines Chunks
ys
    (Chunks
xs, [])            -> [Chunks
xs]


--------------------------------------------------------------------------------
data DocE d
    = String String
    | Softspace
    | Hardspace
    | Softline
    | Hardline
    | WrapAt
        { forall d. DocE d -> Maybe Int
wrapAtCol :: Maybe Int
        , forall d. DocE d -> d
wrapDoc   :: d
        }
    | Ansi
        { forall d. DocE d -> [SGR] -> [SGR]
ansiCode :: [Ansi.SGR] -> [Ansi.SGR]  -- ^ Modifies current codes.
        , forall d. DocE d -> d
ansiDoc  :: d
        }
    | Indent
        { forall d. DocE d -> Indentation Chunks
indentFirstLine  :: Indentation [Chunk]
        , forall d. DocE d -> Indentation Chunks
indentOtherLines :: Indentation [Chunk]
        , forall d. DocE d -> d
indentDoc        :: d
        }
    | Control Control
    deriving ((forall a b. (a -> b) -> DocE a -> DocE b)
-> (forall a b. a -> DocE b -> DocE a) -> Functor DocE
forall a b. a -> DocE b -> DocE a
forall a b. (a -> b) -> DocE a -> DocE b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> DocE a -> DocE b
fmap :: forall a b. (a -> b) -> DocE a -> DocE b
$c<$ :: forall a b. a -> DocE b -> DocE a
<$ :: forall a b. a -> DocE b -> DocE a
Functor)


--------------------------------------------------------------------------------
chunkToDocE :: Chunk -> DocE Doc
chunkToDocE :: Chunk -> DocE Doc
chunkToDocE Chunk
NewlineChunk         = DocE Doc
forall d. DocE d
Hardline
chunkToDocE (StringChunk [SGR]
c1 String
str) = ([SGR] -> [SGR]) -> Doc -> DocE Doc
forall d. ([SGR] -> [SGR]) -> d -> DocE d
Ansi (\[SGR]
c0 -> [SGR]
c1 [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++ [SGR]
c0) ([DocE Doc] -> Doc
Doc [String -> DocE Doc
forall d. String -> DocE d
String String
str])
chunkToDocE (ControlChunk Control
ctrl)  = Control -> DocE Doc
forall d. Control -> DocE d
Control Control
ctrl


--------------------------------------------------------------------------------
newtype Doc = Doc {Doc -> [DocE Doc]
unDoc :: [DocE Doc]}
    deriving (Semigroup Doc
Doc
Semigroup Doc =>
Doc -> (Doc -> Doc -> Doc) -> ([Doc] -> Doc) -> Monoid Doc
[Doc] -> Doc
Doc -> Doc -> Doc
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Doc
mempty :: Doc
$cmappend :: Doc -> Doc -> Doc
mappend :: Doc -> Doc -> Doc
$cmconcat :: [Doc] -> Doc
mconcat :: [Doc] -> Doc
Monoid, NonEmpty Doc -> Doc
Doc -> Doc -> Doc
(Doc -> Doc -> Doc)
-> (NonEmpty Doc -> Doc)
-> (forall b. Integral b => b -> Doc -> Doc)
-> Semigroup Doc
forall b. Integral b => b -> Doc -> Doc
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Doc -> Doc -> Doc
<> :: Doc -> Doc -> Doc
$csconcat :: NonEmpty Doc -> Doc
sconcat :: NonEmpty Doc -> Doc
$cstimes :: forall b. Integral b => b -> Doc -> Doc
stimes :: forall b. Integral b => b -> Doc -> Doc
Semigroup)


--------------------------------------------------------------------------------
instance Show Doc where
    show :: Doc -> String
show = Doc -> String
toString


--------------------------------------------------------------------------------
instance IsString Doc where
    fromString :: String -> Doc
fromString = String -> Doc
string


--------------------------------------------------------------------------------
data DocEnv = DocEnv
    { DocEnv -> [SGR]
deCodes  :: [Ansi.SGR]             -- ^ Most recent ones first in the list
    , DocEnv -> [Indentation Chunks]
deIndent :: [Indentation [Chunk]]  -- ^ No need to store first-line indent
    , DocEnv -> Maybe Int
deWrap   :: Maybe Int              -- ^ Wrap at columns
    }


--------------------------------------------------------------------------------
type DocM = RWS DocEnv Chunks LineBuffer


--------------------------------------------------------------------------------
-- | Note that the lists here are reversed so we have fast append.
-- We also store the current length to avoid having to recompute it.
data LineBuffer = LineBuffer Int [Indentation [Chunk]] [Chunk]


--------------------------------------------------------------------------------
emptyLineBuffer :: LineBuffer
emptyLineBuffer :: LineBuffer
emptyLineBuffer = Int -> [Indentation Chunks] -> Chunks -> LineBuffer
LineBuffer Int
0 [] []


--------------------------------------------------------------------------------
data Indentation a = Indentation Int a
    deriving ((forall m. Monoid m => Indentation m -> m)
-> (forall m a. Monoid m => (a -> m) -> Indentation a -> m)
-> (forall m a. Monoid m => (a -> m) -> Indentation a -> m)
-> (forall a b. (a -> b -> b) -> b -> Indentation a -> b)
-> (forall a b. (a -> b -> b) -> b -> Indentation a -> b)
-> (forall b a. (b -> a -> b) -> b -> Indentation a -> b)
-> (forall b a. (b -> a -> b) -> b -> Indentation a -> b)
-> (forall a. (a -> a -> a) -> Indentation a -> a)
-> (forall a. (a -> a -> a) -> Indentation a -> a)
-> (forall a. Indentation a -> [a])
-> (forall a. Indentation a -> Bool)
-> (forall a. Indentation a -> Int)
-> (forall a. Eq a => a -> Indentation a -> Bool)
-> (forall a. Ord a => Indentation a -> a)
-> (forall a. Ord a => Indentation a -> a)
-> (forall a. Num a => Indentation a -> a)
-> (forall a. Num a => Indentation a -> a)
-> Foldable Indentation
forall a. Eq a => a -> Indentation a -> Bool
forall a. Num a => Indentation a -> a
forall a. Ord a => Indentation a -> a
forall m. Monoid m => Indentation m -> m
forall a. Indentation a -> Bool
forall a. Indentation a -> Int
forall a. Indentation a -> [a]
forall a. (a -> a -> a) -> Indentation a -> a
forall m a. Monoid m => (a -> m) -> Indentation a -> m
forall b a. (b -> a -> b) -> b -> Indentation a -> b
forall a b. (a -> b -> b) -> b -> Indentation 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
$cfold :: forall m. Monoid m => Indentation m -> m
fold :: forall m. Monoid m => Indentation m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Indentation a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Indentation a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Indentation a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> Indentation a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> Indentation a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Indentation a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Indentation a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Indentation a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Indentation a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Indentation a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Indentation a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> Indentation a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> Indentation a -> a
foldr1 :: forall a. (a -> a -> a) -> Indentation a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Indentation a -> a
foldl1 :: forall a. (a -> a -> a) -> Indentation a -> a
$ctoList :: forall a. Indentation a -> [a]
toList :: forall a. Indentation a -> [a]
$cnull :: forall a. Indentation a -> Bool
null :: forall a. Indentation a -> Bool
$clength :: forall a. Indentation a -> Int
length :: forall a. Indentation a -> Int
$celem :: forall a. Eq a => a -> Indentation a -> Bool
elem :: forall a. Eq a => a -> Indentation a -> Bool
$cmaximum :: forall a. Ord a => Indentation a -> a
maximum :: forall a. Ord a => Indentation a -> a
$cminimum :: forall a. Ord a => Indentation a -> a
minimum :: forall a. Ord a => Indentation a -> a
$csum :: forall a. Num a => Indentation a -> a
sum :: forall a. Num a => Indentation a -> a
$cproduct :: forall a. Num a => Indentation a -> a
product :: forall a. Num a => Indentation a -> a
Foldable, (forall a b. (a -> b) -> Indentation a -> Indentation b)
-> (forall a b. a -> Indentation b -> Indentation a)
-> Functor Indentation
forall a b. a -> Indentation b -> Indentation a
forall a b. (a -> b) -> Indentation a -> Indentation b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Indentation a -> Indentation b
fmap :: forall a b. (a -> b) -> Indentation a -> Indentation b
$c<$ :: forall a b. a -> Indentation b -> Indentation a
<$ :: forall a b. a -> Indentation b -> Indentation a
Functor, Functor Indentation
Foldable Indentation
(Functor Indentation, Foldable Indentation) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> Indentation a -> f (Indentation b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    Indentation (f a) -> f (Indentation a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> Indentation a -> m (Indentation b))
-> (forall (m :: * -> *) a.
    Monad m =>
    Indentation (m a) -> m (Indentation a))
-> Traversable Indentation
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 =>
Indentation (m a) -> m (Indentation a)
forall (f :: * -> *) a.
Applicative f =>
Indentation (f a) -> f (Indentation a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Indentation a -> m (Indentation b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Indentation a -> f (Indentation b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Indentation a -> f (Indentation b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Indentation a -> f (Indentation b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Indentation (f a) -> f (Indentation a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Indentation (f a) -> f (Indentation a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Indentation a -> m (Indentation b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Indentation a -> m (Indentation b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Indentation (m a) -> m (Indentation a)
sequence :: forall (m :: * -> *) a.
Monad m =>
Indentation (m a) -> m (Indentation a)
Traversable)


--------------------------------------------------------------------------------
indentationToChunks :: Indentation [Chunk] -> [Chunk]
indentationToChunks :: Indentation Chunks -> Chunks
indentationToChunks (Indentation Int
0 Chunks
c) = Chunks
c
indentationToChunks (Indentation Int
n Chunks
c) = [SGR] -> String -> Chunk
StringChunk [] (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ') Chunk -> Chunks -> Chunks
forall a. a -> [a] -> [a]
: Chunks
c


--------------------------------------------------------------------------------
indentationWidth :: Indentation [Chunk] -> Int
indentationWidth :: Indentation Chunks -> Int
indentationWidth (Indentation Int
s Chunks
c) =
    Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Chunk -> Int) -> Chunks -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
wcstrwidth (String -> Int) -> (Chunk -> String) -> Chunk -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk -> String
chunkToString) Chunks
c)


--------------------------------------------------------------------------------
bufferToChunks :: LineBuffer -> Chunks
bufferToChunks :: LineBuffer -> Chunks
bufferToChunks (LineBuffer Int
_ [Indentation Chunks]
ind Chunks
chunks) = case Chunks
chunks of
    [] -> (Indentation Chunks -> Chunks) -> [Indentation Chunks] -> Chunks
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Indentation Chunks -> Chunks
indentationToChunks ([Indentation Chunks] -> Chunks) -> [Indentation Chunks] -> Chunks
forall a b. (a -> b) -> a -> b
$ [Indentation Chunks] -> [Indentation Chunks]
forall a. [a] -> [a]
reverse ([Indentation Chunks] -> [Indentation Chunks])
-> [Indentation Chunks] -> [Indentation Chunks]
forall a b. (a -> b) -> a -> b
$
        (Indentation Chunks -> Bool)
-> [Indentation Chunks] -> [Indentation Chunks]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Indentation Chunks -> Bool
forall {a}. Indentation [a] -> Bool
emptyIndentation [Indentation Chunks]
ind
    Chunks
_ -> (Indentation Chunks -> Chunks) -> [Indentation Chunks] -> Chunks
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Indentation Chunks -> Chunks
indentationToChunks ([Indentation Chunks] -> [Indentation Chunks]
forall a. [a] -> [a]
reverse [Indentation Chunks]
ind) Chunks -> Chunks -> Chunks
forall a. [a] -> [a] -> [a]
++ Chunks -> Chunks
forall a. [a] -> [a]
reverse Chunks
chunks
  where
    emptyIndentation :: Indentation [a] -> Bool
emptyIndentation (Indentation Int
_ []) = Bool
True
    emptyIndentation Indentation [a]
_                  = Bool
False


--------------------------------------------------------------------------------
docToChunks :: Doc -> Chunks
docToChunks :: Doc -> Chunks
docToChunks Doc
doc0 =
    let env0 :: DocEnv
env0        = [SGR] -> [Indentation Chunks] -> Maybe Int -> DocEnv
DocEnv [] [] Maybe Int
forall a. Maybe a
Nothing
        ((), LineBuffer
b, Chunks
cs) = RWS DocEnv Chunks LineBuffer ()
-> DocEnv -> LineBuffer -> ((), LineBuffer, Chunks)
forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
runRWS ([DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go ([DocE Doc] -> RWS DocEnv Chunks LineBuffer ())
-> [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
forall a b. (a -> b) -> a -> b
$ Doc -> [DocE Doc]
unDoc Doc
doc0) DocEnv
env0 LineBuffer
emptyLineBuffer in
    Chunks -> Chunks
optimizeChunks (Chunks
cs Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> LineBuffer -> Chunks
bufferToChunks LineBuffer
b)
  where
    go :: [DocE Doc] -> DocM ()

    go :: [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go [] = () -> RWS DocEnv Chunks LineBuffer ()
forall a. a -> RWST DocEnv Chunks LineBuffer Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    go (String String
str : [DocE Doc]
docs) = do
        Chunk
chunk <- String -> DocM Chunk
makeChunk String
str
        Chunk -> RWS DocEnv Chunks LineBuffer ()
appendChunk Chunk
chunk
        [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go [DocE Doc]
docs

    go (DocE Doc
Softspace : [DocE Doc]
docs) = do
        DocE Doc
hard <- DocE Doc -> [DocE Doc] -> DocM (DocE Doc)
softConversion DocE Doc
forall d. DocE d
Softspace [DocE Doc]
docs
        [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go (DocE Doc
hard DocE Doc -> [DocE Doc] -> [DocE Doc]
forall a. a -> [a] -> [a]
: [DocE Doc]
docs)

    go (DocE Doc
Hardspace : [DocE Doc]
docs) = do
        Chunk
chunk <- String -> DocM Chunk
makeChunk String
" "
        Chunk -> RWS DocEnv Chunks LineBuffer ()
appendChunk Chunk
chunk
        [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go [DocE Doc]
docs

    go (DocE Doc
Softline : [DocE Doc]
docs) = do
        DocE Doc
hard <- DocE Doc -> [DocE Doc] -> DocM (DocE Doc)
softConversion DocE Doc
forall d. DocE d
Softline [DocE Doc]
docs
        [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go (DocE Doc
hard DocE Doc -> [DocE Doc] -> [DocE Doc]
forall a. a -> [a] -> [a]
: [DocE Doc]
docs)

    go (DocE Doc
Hardline : [DocE Doc]
docs) = do
        LineBuffer
buffer <- RWST DocEnv Chunks LineBuffer Identity LineBuffer
forall s (m :: * -> *). MonadState s m => m s
get
        Chunks -> RWS DocEnv Chunks LineBuffer ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Chunks -> RWS DocEnv Chunks LineBuffer ())
-> Chunks -> RWS DocEnv Chunks LineBuffer ()
forall a b. (a -> b) -> a -> b
$ LineBuffer -> Chunks
bufferToChunks LineBuffer
buffer Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> [Chunk
NewlineChunk]
        [Indentation Chunks]
ind <- (DocEnv -> [Indentation Chunks])
-> RWST DocEnv Chunks LineBuffer Identity [Indentation Chunks]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DocEnv -> [Indentation Chunks]
deIndent
        (LineBuffer -> LineBuffer) -> RWS DocEnv Chunks LineBuffer ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LineBuffer -> LineBuffer) -> RWS DocEnv Chunks LineBuffer ())
-> (LineBuffer -> LineBuffer) -> RWS DocEnv Chunks LineBuffer ()
forall a b. (a -> b) -> a -> b
$ \LineBuffer
_ -> case [DocE Doc]
docs of
            []    -> LineBuffer
emptyLineBuffer
            DocE Doc
_ : [DocE Doc]
_ -> Int -> [Indentation Chunks] -> Chunks -> LineBuffer
LineBuffer ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (Indentation Chunks -> Int) -> [Indentation Chunks] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Indentation Chunks -> Int
indentationWidth [Indentation Chunks]
ind) [Indentation Chunks]
ind []
        [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go [DocE Doc]
docs

    go (WrapAt {Maybe Int
Doc
wrapAtCol :: forall d. DocE d -> Maybe Int
wrapDoc :: forall d. DocE d -> d
wrapAtCol :: Maybe Int
wrapDoc :: Doc
..} : [DocE Doc]
docs) = do
        Int
il <- (DocEnv -> Int) -> RWST DocEnv Chunks LineBuffer Identity Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((DocEnv -> Int) -> RWST DocEnv Chunks LineBuffer Identity Int)
-> (DocEnv -> Int) -> RWST DocEnv Chunks LineBuffer Identity Int
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> (DocEnv -> [Int]) -> DocEnv -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Indentation Chunks -> Int) -> [Indentation Chunks] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Indentation Chunks -> Int
indentationWidth ([Indentation Chunks] -> [Int])
-> (DocEnv -> [Indentation Chunks]) -> DocEnv -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocEnv -> [Indentation Chunks]
deIndent
        (DocEnv -> DocEnv)
-> RWS DocEnv Chunks LineBuffer ()
-> RWS DocEnv Chunks LineBuffer ()
forall a.
(DocEnv -> DocEnv)
-> RWST DocEnv Chunks LineBuffer Identity a
-> RWST DocEnv Chunks LineBuffer Identity a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\DocEnv
env -> DocEnv
env {deWrap = fmap (+ il) wrapAtCol}) (RWS DocEnv Chunks LineBuffer ()
 -> RWS DocEnv Chunks LineBuffer ())
-> RWS DocEnv Chunks LineBuffer ()
-> RWS DocEnv Chunks LineBuffer ()
forall a b. (a -> b) -> a -> b
$ [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go (Doc -> [DocE Doc]
unDoc Doc
wrapDoc)
        [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go [DocE Doc]
docs

    go (Ansi {Doc
[SGR] -> [SGR]
ansiCode :: forall d. DocE d -> [SGR] -> [SGR]
ansiDoc :: forall d. DocE d -> d
ansiCode :: [SGR] -> [SGR]
ansiDoc :: Doc
..} : [DocE Doc]
docs) = do
        (DocEnv -> DocEnv)
-> RWS DocEnv Chunks LineBuffer ()
-> RWS DocEnv Chunks LineBuffer ()
forall a.
(DocEnv -> DocEnv)
-> RWST DocEnv Chunks LineBuffer Identity a
-> RWST DocEnv Chunks LineBuffer Identity a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\DocEnv
env -> DocEnv
env {deCodes = ansiCode (deCodes env)}) (RWS DocEnv Chunks LineBuffer ()
 -> RWS DocEnv Chunks LineBuffer ())
-> RWS DocEnv Chunks LineBuffer ()
-> RWS DocEnv Chunks LineBuffer ()
forall a b. (a -> b) -> a -> b
$
            [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go (Doc -> [DocE Doc]
unDoc Doc
ansiDoc)
        [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go [DocE Doc]
docs

    go (Indent {Indentation Chunks
Doc
indentFirstLine :: forall d. DocE d -> Indentation Chunks
indentOtherLines :: forall d. DocE d -> Indentation Chunks
indentDoc :: forall d. DocE d -> d
indentFirstLine :: Indentation Chunks
indentOtherLines :: Indentation Chunks
indentDoc :: Doc
..} : [DocE Doc]
docs) = do
        (DocEnv -> DocEnv)
-> RWS DocEnv Chunks LineBuffer ()
-> RWS DocEnv Chunks LineBuffer ()
forall a.
(DocEnv -> DocEnv)
-> RWST DocEnv Chunks LineBuffer Identity a
-> RWST DocEnv Chunks LineBuffer Identity a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\DocEnv
e -> DocEnv
e {deIndent = indentOtherLines : deIndent e}) (RWS DocEnv Chunks LineBuffer ()
 -> RWS DocEnv Chunks LineBuffer ())
-> RWS DocEnv Chunks LineBuffer ()
-> RWS DocEnv Chunks LineBuffer ()
forall a b. (a -> b) -> a -> b
$ do
            (LineBuffer -> LineBuffer) -> RWS DocEnv Chunks LineBuffer ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LineBuffer -> LineBuffer) -> RWS DocEnv Chunks LineBuffer ())
-> (LineBuffer -> LineBuffer) -> RWS DocEnv Chunks LineBuffer ()
forall a b. (a -> b) -> a -> b
$ \(LineBuffer Int
w [Indentation Chunks]
i Chunks
c) -> Int -> [Indentation Chunks] -> Chunks -> LineBuffer
LineBuffer
                (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Indentation Chunks -> Int
indentationWidth Indentation Chunks
indentFirstLine) (Indentation Chunks
indentFirstLine Indentation Chunks -> [Indentation Chunks] -> [Indentation Chunks]
forall a. a -> [a] -> [a]
: [Indentation Chunks]
i) Chunks
c
            [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go (Doc -> [DocE Doc]
unDoc Doc
indentDoc)
        [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go [DocE Doc]
docs

    go (Control Control
ctrl : [DocE Doc]
docs) = do
        Chunks -> RWS DocEnv Chunks LineBuffer ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Control -> Chunk
ControlChunk Control
ctrl]
        [DocE Doc] -> RWS DocEnv Chunks LineBuffer ()
go [DocE Doc]
docs


    makeChunk :: String -> DocM Chunk
    makeChunk :: String -> DocM Chunk
makeChunk String
str = do
        [SGR]
codes <- (DocEnv -> [SGR]) -> RWST DocEnv Chunks LineBuffer Identity [SGR]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DocEnv -> [SGR]
deCodes
        Chunk -> DocM Chunk
forall a. a -> RWST DocEnv Chunks LineBuffer Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Chunk -> DocM Chunk) -> Chunk -> DocM Chunk
forall a b. (a -> b) -> a -> b
$ [SGR] -> String -> Chunk
StringChunk [SGR]
codes String
str

    appendChunk :: Chunk -> DocM ()
    appendChunk :: Chunk -> RWS DocEnv Chunks LineBuffer ()
appendChunk Chunk
c = (LineBuffer -> LineBuffer) -> RWS DocEnv Chunks LineBuffer ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((LineBuffer -> LineBuffer) -> RWS DocEnv Chunks LineBuffer ())
-> (LineBuffer -> LineBuffer) -> RWS DocEnv Chunks LineBuffer ()
forall a b. (a -> b) -> a -> b
$ \(LineBuffer Int
w [Indentation Chunks]
i Chunks
cs) ->
        Int -> [Indentation Chunks] -> Chunks -> LineBuffer
LineBuffer (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
wcstrwidth (Chunk -> String
chunkToString Chunk
c)) [Indentation Chunks]
i (Chunk
c Chunk -> Chunks -> Chunks
forall a. a -> [a] -> [a]
: Chunks
cs)

    -- Convert 'Softspace' or 'Softline' to 'Hardspace' or 'Hardline'
    softConversion :: DocE Doc -> [DocE Doc] -> DocM (DocE Doc)
    softConversion :: DocE Doc -> [DocE Doc] -> DocM (DocE Doc)
softConversion DocE Doc
soft [DocE Doc]
docs = do
        Maybe Int
mbWrapCol <- (DocEnv -> Maybe Int)
-> RWST DocEnv Chunks LineBuffer Identity (Maybe Int)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DocEnv -> Maybe Int
deWrap
        case Maybe Int
mbWrapCol of
            Maybe Int
Nothing     -> DocE Doc -> DocM (DocE Doc)
forall a. a -> RWST DocEnv Chunks LineBuffer Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return DocE Doc
hard
            Just Int
maxCol -> do
                LineBuffer Int
currentCol [Indentation Chunks]
_ Chunks
_ <- RWST DocEnv Chunks LineBuffer Identity LineBuffer
forall s (m :: * -> *). MonadState s m => m s
get
                case [DocE Doc] -> Maybe Int
nextWordLength [DocE Doc]
docs of
                    Maybe Int
Nothing                            -> DocE Doc -> DocM (DocE Doc)
forall a. a -> RWST DocEnv Chunks LineBuffer Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return DocE Doc
hard
                    Just Int
l
                        | Int
currentCol Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxCol -> DocE Doc -> DocM (DocE Doc)
forall a. a -> RWST DocEnv Chunks LineBuffer Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return DocE Doc
forall d. DocE d
Hardspace
                        | Bool
otherwise                    -> DocE Doc -> DocM (DocE Doc)
forall a. a -> RWST DocEnv Chunks LineBuffer Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return DocE Doc
forall d. DocE d
Hardline
      where
        hard :: DocE Doc
hard = case DocE Doc
soft of
            DocE Doc
Softspace -> DocE Doc
forall d. DocE d
Hardspace
            DocE Doc
Softline  -> DocE Doc
forall d. DocE d
Hardline
            DocE Doc
_         -> DocE Doc
soft

    nextWordLength :: [DocE Doc] -> Maybe Int
    nextWordLength :: [DocE Doc] -> Maybe Int
nextWordLength []                 = Maybe Int
forall a. Maybe a
Nothing
    nextWordLength (String String
x : [DocE Doc]
xs)
        | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
x                    = [DocE Doc] -> Maybe Int
nextWordLength [DocE Doc]
xs
        | Bool
otherwise                   = Int -> Maybe Int
forall a. a -> Maybe a
Just (String -> Int
wcstrwidth String
x)
    nextWordLength (DocE Doc
Softspace : [DocE Doc]
xs)   = [DocE Doc] -> Maybe Int
nextWordLength [DocE Doc]
xs
    nextWordLength (DocE Doc
Hardspace : [DocE Doc]
xs)   = [DocE Doc] -> Maybe Int
nextWordLength [DocE Doc]
xs
    nextWordLength (DocE Doc
Softline : [DocE Doc]
xs)    = [DocE Doc] -> Maybe Int
nextWordLength [DocE Doc]
xs
    nextWordLength (DocE Doc
Hardline : [DocE Doc]
_)     = Maybe Int
forall a. Maybe a
Nothing
    nextWordLength (WrapAt {Maybe Int
Doc
wrapAtCol :: forall d. DocE d -> Maybe Int
wrapDoc :: forall d. DocE d -> d
wrapAtCol :: Maybe Int
wrapDoc :: Doc
..} : [DocE Doc]
xs) = [DocE Doc] -> Maybe Int
nextWordLength (Doc -> [DocE Doc]
unDoc Doc
wrapDoc   [DocE Doc] -> [DocE Doc] -> [DocE Doc]
forall a. [a] -> [a] -> [a]
++ [DocE Doc]
xs)
    nextWordLength (Ansi   {Doc
[SGR] -> [SGR]
ansiCode :: forall d. DocE d -> [SGR] -> [SGR]
ansiDoc :: forall d. DocE d -> d
ansiCode :: [SGR] -> [SGR]
ansiDoc :: Doc
..} : [DocE Doc]
xs) = [DocE Doc] -> Maybe Int
nextWordLength (Doc -> [DocE Doc]
unDoc Doc
ansiDoc   [DocE Doc] -> [DocE Doc] -> [DocE Doc]
forall a. [a] -> [a] -> [a]
++ [DocE Doc]
xs)
    nextWordLength (Indent {Indentation Chunks
Doc
indentFirstLine :: forall d. DocE d -> Indentation Chunks
indentOtherLines :: forall d. DocE d -> Indentation Chunks
indentDoc :: forall d. DocE d -> d
indentFirstLine :: Indentation Chunks
indentOtherLines :: Indentation Chunks
indentDoc :: Doc
..} : [DocE Doc]
xs) = [DocE Doc] -> Maybe Int
nextWordLength (Doc -> [DocE Doc]
unDoc Doc
indentDoc [DocE Doc] -> [DocE Doc] -> [DocE Doc]
forall a. [a] -> [a] -> [a]
++ [DocE Doc]
xs)
    nextWordLength (Control Control
_ : [DocE Doc]
_)    = Maybe Int
forall a. Maybe a
Nothing


--------------------------------------------------------------------------------
toString :: Doc -> String
toString :: Doc -> String
toString = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> (Doc -> [String]) -> Doc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chunk -> String) -> Chunks -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Chunk -> String
chunkToString (Chunks -> [String]) -> (Doc -> Chunks) -> Doc -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Chunks
docToChunks


--------------------------------------------------------------------------------
-- | Returns the rows and columns necessary to render this document
dimensions :: Doc -> (Int, Int)
dimensions :: Doc -> (Int, Int)
dimensions Doc
doc =
    let ls :: [String]
ls = String -> [String]
lines (Doc -> String
toString Doc
doc) in
    ([String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls, (Int -> Int -> Int) -> Int -> [Int] -> Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 ((String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
wcstrwidth [String]
ls))


--------------------------------------------------------------------------------
null :: Doc -> Bool
null :: Doc -> Bool
null Doc
doc = case Doc -> [DocE Doc]
unDoc Doc
doc of [] -> Bool
True; [DocE Doc]
_ -> Bool
False


--------------------------------------------------------------------------------
hPutDoc :: IO.Handle -> Doc -> IO ()
hPutDoc :: Handle -> Doc -> IO ()
hPutDoc Handle
h = (Chunk -> IO ()) -> Chunks -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Chunk -> IO ()
hPutChunk Handle
h) (Chunks -> IO ()) -> (Doc -> Chunks) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Chunks
docToChunks


--------------------------------------------------------------------------------
putDoc :: Doc -> IO ()
putDoc :: Doc -> IO ()
putDoc = Handle -> Doc -> IO ()
hPutDoc Handle
IO.stdout


--------------------------------------------------------------------------------
mkDoc :: DocE Doc -> Doc
mkDoc :: DocE Doc -> Doc
mkDoc DocE Doc
e = [DocE Doc] -> Doc
Doc [DocE Doc
e]


--------------------------------------------------------------------------------
string :: String -> Doc
string :: String -> Doc
string String
""  = [DocE Doc] -> Doc
Doc []
string String
str = DocE Doc -> Doc
mkDoc (DocE Doc -> Doc) -> DocE Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> DocE Doc
forall d. String -> DocE d
String String
str  -- TODO (jaspervdj): Newline conversion?