{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
module Patat.PrettyPrint
( Doc
, toString
, dimensions
, null
, hPutDoc
, putDoc
, string
, text
, space
, spaces
, softline
, hardline
, wrapAt
, Trimmable (..)
, indent
, ansi
, (<+>)
, (<$$>)
, vcat
, intersperse
, Alignment (..)
, align
, paste
) where
import Control.Monad.Reader (asks, local)
import Control.Monad.RWS (RWS, runRWS)
import Control.Monad.State (get, gets, modify)
import Control.Monad.Writer (tell)
import qualified Data.List as L
import Data.String (IsString (..))
import qualified Data.Text as T
import Prelude hiding (null)
import qualified System.Console.ANSI as Ansi
import qualified System.IO as IO
data Chunk
= StringChunk [Ansi.SGR] String
| NewlineChunk
deriving (Chunk -> Chunk -> Bool
(Chunk -> Chunk -> Bool) -> (Chunk -> Chunk -> Bool) -> Eq Chunk
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Chunk -> Chunk -> Bool
$c/= :: Chunk -> Chunk -> Bool
== :: Chunk -> Chunk -> Bool
$c== :: Chunk -> Chunk -> Bool
Eq)
type Chunks = [Chunk]
hPutChunk :: IO.Handle -> Chunk -> IO ()
hPutChunk :: Handle -> Chunk -> IO ()
hPutChunk h :: Handle
h NewlineChunk = Handle -> String -> IO ()
IO.hPutStrLn Handle
h ""
hPutChunk h :: Handle
h (StringChunk codes :: [SGR]
codes str :: 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]
chunkToString :: Chunk -> String
chunkToString :: Chunk -> String
chunkToString NewlineChunk = "\n"
chunkToString (StringChunk _ str :: String
str) = String
str
optimizeChunks :: Chunks -> Chunks
optimizeChunks :: Chunks -> Chunks
optimizeChunks (StringChunk c1 :: [SGR]
c1 s1 :: String
s1 : StringChunk c2 :: [SGR]
c2 s2 :: String
s2 : chunks :: 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 -> String -> String
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 (x :: Chunk
x : chunks :: 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
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
(xs :: Chunks
xs, _newline :: Chunk
_newline : ys :: Chunks
ys) -> Chunks
xs Chunks -> [Chunks] -> [Chunks]
forall a. a -> [a] -> [a]
: Chunks -> [Chunks]
chunkLines Chunks
ys
(xs :: Chunks
xs, []) -> [Chunks
xs]
data DocE
= String String
| Softspace
| Hardspace
| Softline
| Hardline
| WrapAt
{ DocE -> Maybe Int
wrapAtCol :: Maybe Int
, DocE -> Doc
wrapDoc :: Doc
}
| Ansi
{ DocE -> [SGR] -> [SGR]
ansiCode :: [Ansi.SGR] -> [Ansi.SGR]
, DocE -> Doc
ansiDoc :: Doc
}
| Indent
{ DocE -> LineBuffer
indentFirstLine :: LineBuffer
, DocE -> LineBuffer
indentOtherLines :: LineBuffer
, DocE -> Doc
indentDoc :: Doc
}
chunkToDocE :: Chunk -> DocE
chunkToDocE :: Chunk -> DocE
chunkToDocE NewlineChunk = DocE
Hardline
chunkToDocE (StringChunk codes :: [SGR]
codes str :: String
str) = ([SGR] -> [SGR]) -> Doc -> DocE
Ansi (\_ -> [SGR]
codes) ([DocE] -> Doc
Doc [String -> DocE
String String
str])
newtype Doc = Doc {Doc -> [DocE]
unDoc :: [DocE]}
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
mconcat :: [Doc] -> Doc
$cmconcat :: [Doc] -> Doc
mappend :: Doc -> Doc -> Doc
$cmappend :: Doc -> Doc -> Doc
mempty :: Doc
$cmempty :: Doc
$cp1Monoid :: Semigroup Doc
Monoid, b -> Doc -> Doc
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
stimes :: b -> Doc -> Doc
$cstimes :: forall b. Integral b => b -> Doc -> Doc
sconcat :: NonEmpty Doc -> Doc
$csconcat :: NonEmpty Doc -> Doc
<> :: Doc -> Doc -> Doc
$c<> :: Doc -> Doc -> Doc
Semigroup)
instance IsString Doc where
fromString :: String -> Doc
fromString = String -> Doc
string
instance Show Doc where
show :: Doc -> String
show = Doc -> String
toString
data DocEnv = DocEnv
{ DocEnv -> [SGR]
deCodes :: [Ansi.SGR]
, DocEnv -> LineBuffer
deIndent :: LineBuffer
, DocEnv -> Maybe Int
deWrap :: Maybe Int
}
type DocM = RWS DocEnv Chunks LineBuffer
data Trimmable a
= NotTrimmable !a
| Trimmable !a
deriving (Trimmable a -> Bool
(a -> m) -> Trimmable a -> m
(a -> b -> b) -> b -> Trimmable a -> b
(forall m. Monoid m => Trimmable m -> m)
-> (forall m a. Monoid m => (a -> m) -> Trimmable a -> m)
-> (forall m a. Monoid m => (a -> m) -> Trimmable a -> m)
-> (forall a b. (a -> b -> b) -> b -> Trimmable a -> b)
-> (forall a b. (a -> b -> b) -> b -> Trimmable a -> b)
-> (forall b a. (b -> a -> b) -> b -> Trimmable a -> b)
-> (forall b a. (b -> a -> b) -> b -> Trimmable a -> b)
-> (forall a. (a -> a -> a) -> Trimmable a -> a)
-> (forall a. (a -> a -> a) -> Trimmable a -> a)
-> (forall a. Trimmable a -> [a])
-> (forall a. Trimmable a -> Bool)
-> (forall a. Trimmable a -> Int)
-> (forall a. Eq a => a -> Trimmable a -> Bool)
-> (forall a. Ord a => Trimmable a -> a)
-> (forall a. Ord a => Trimmable a -> a)
-> (forall a. Num a => Trimmable a -> a)
-> (forall a. Num a => Trimmable a -> a)
-> Foldable Trimmable
forall a. Eq a => a -> Trimmable a -> Bool
forall a. Num a => Trimmable a -> a
forall a. Ord a => Trimmable a -> a
forall m. Monoid m => Trimmable m -> m
forall a. Trimmable a -> Bool
forall a. Trimmable a -> Int
forall a. Trimmable a -> [a]
forall a. (a -> a -> a) -> Trimmable a -> a
forall m a. Monoid m => (a -> m) -> Trimmable a -> m
forall b a. (b -> a -> b) -> b -> Trimmable a -> b
forall a b. (a -> b -> b) -> b -> Trimmable 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 :: Trimmable a -> a
$cproduct :: forall a. Num a => Trimmable a -> a
sum :: Trimmable a -> a
$csum :: forall a. Num a => Trimmable a -> a
minimum :: Trimmable a -> a
$cminimum :: forall a. Ord a => Trimmable a -> a
maximum :: Trimmable a -> a
$cmaximum :: forall a. Ord a => Trimmable a -> a
elem :: a -> Trimmable a -> Bool
$celem :: forall a. Eq a => a -> Trimmable a -> Bool
length :: Trimmable a -> Int
$clength :: forall a. Trimmable a -> Int
null :: Trimmable a -> Bool
$cnull :: forall a. Trimmable a -> Bool
toList :: Trimmable a -> [a]
$ctoList :: forall a. Trimmable a -> [a]
foldl1 :: (a -> a -> a) -> Trimmable a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Trimmable a -> a
foldr1 :: (a -> a -> a) -> Trimmable a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Trimmable a -> a
foldl' :: (b -> a -> b) -> b -> Trimmable a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Trimmable a -> b
foldl :: (b -> a -> b) -> b -> Trimmable a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Trimmable a -> b
foldr' :: (a -> b -> b) -> b -> Trimmable a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Trimmable a -> b
foldr :: (a -> b -> b) -> b -> Trimmable a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Trimmable a -> b
foldMap' :: (a -> m) -> Trimmable a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Trimmable a -> m
foldMap :: (a -> m) -> Trimmable a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Trimmable a -> m
fold :: Trimmable m -> m
$cfold :: forall m. Monoid m => Trimmable m -> m
Foldable, a -> Trimmable b -> Trimmable a
(a -> b) -> Trimmable a -> Trimmable b
(forall a b. (a -> b) -> Trimmable a -> Trimmable b)
-> (forall a b. a -> Trimmable b -> Trimmable a)
-> Functor Trimmable
forall a b. a -> Trimmable b -> Trimmable a
forall a b. (a -> b) -> Trimmable a -> Trimmable b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Trimmable b -> Trimmable a
$c<$ :: forall a b. a -> Trimmable b -> Trimmable a
fmap :: (a -> b) -> Trimmable a -> Trimmable b
$cfmap :: forall a b. (a -> b) -> Trimmable a -> Trimmable b
Functor, Functor Trimmable
Foldable Trimmable
(Functor Trimmable, Foldable Trimmable) =>
(forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Trimmable a -> f (Trimmable b))
-> (forall (f :: * -> *) a.
Applicative f =>
Trimmable (f a) -> f (Trimmable a))
-> (forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Trimmable a -> m (Trimmable b))
-> (forall (m :: * -> *) a.
Monad m =>
Trimmable (m a) -> m (Trimmable a))
-> Traversable Trimmable
(a -> f b) -> Trimmable a -> f (Trimmable 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 =>
Trimmable (m a) -> m (Trimmable a)
forall (f :: * -> *) a.
Applicative f =>
Trimmable (f a) -> f (Trimmable a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Trimmable a -> m (Trimmable b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Trimmable a -> f (Trimmable b)
sequence :: Trimmable (m a) -> m (Trimmable a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Trimmable (m a) -> m (Trimmable a)
mapM :: (a -> m b) -> Trimmable a -> m (Trimmable b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Trimmable a -> m (Trimmable b)
sequenceA :: Trimmable (f a) -> f (Trimmable a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Trimmable (f a) -> f (Trimmable a)
traverse :: (a -> f b) -> Trimmable a -> f (Trimmable b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Trimmable a -> f (Trimmable b)
$cp2Traversable :: Foldable Trimmable
$cp1Traversable :: Functor Trimmable
Traversable)
type LineBuffer = [Trimmable Chunk]
bufferToChunks :: LineBuffer -> Chunks
bufferToChunks :: LineBuffer -> Chunks
bufferToChunks = (Trimmable Chunk -> Chunk) -> LineBuffer -> Chunks
forall a b. (a -> b) -> [a] -> [b]
map Trimmable Chunk -> Chunk
forall p. Trimmable p -> p
trimmableToChunk (LineBuffer -> Chunks)
-> (LineBuffer -> LineBuffer) -> LineBuffer -> Chunks
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineBuffer -> LineBuffer
forall a. [a] -> [a]
reverse (LineBuffer -> LineBuffer)
-> (LineBuffer -> LineBuffer) -> LineBuffer -> LineBuffer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Trimmable Chunk -> Bool) -> LineBuffer -> LineBuffer
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Trimmable Chunk -> Bool
forall a. Trimmable a -> Bool
isTrimmable
where
isTrimmable :: Trimmable a -> Bool
isTrimmable (NotTrimmable _) = Bool
False
isTrimmable (Trimmable _) = Bool
True
trimmableToChunk :: Trimmable p -> p
trimmableToChunk (NotTrimmable c :: p
c) = p
c
trimmableToChunk (Trimmable c :: p
c) = p
c
docToChunks :: Doc -> Chunks
docToChunks :: Doc -> Chunks
docToChunks doc0 :: Doc
doc0 =
let env0 :: DocEnv
env0 = [SGR] -> LineBuffer -> Maybe Int -> DocEnv
DocEnv [] [] Maybe Int
forall a. Maybe a
Nothing
((), b :: LineBuffer
b, cs :: 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] -> RWS DocEnv Chunks LineBuffer ()
go ([DocE] -> RWS DocEnv Chunks LineBuffer ())
-> [DocE] -> RWS DocEnv Chunks LineBuffer ()
forall a b. (a -> b) -> a -> b
$ Doc -> [DocE]
unDoc Doc
doc0) DocEnv
env0 LineBuffer
forall a. Monoid a => a
mempty in
Chunks -> Chunks
optimizeChunks (Chunks
cs Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> LineBuffer -> Chunks
bufferToChunks LineBuffer
b)
where
go :: [DocE] -> DocM ()
go :: [DocE] -> RWS DocEnv Chunks LineBuffer ()
go [] = () -> RWS DocEnv Chunks LineBuffer ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
go (String str :: String
str : docs :: [DocE]
docs) = do
Chunk
chunk <- String -> DocM Chunk
makeChunk String
str
(LineBuffer -> LineBuffer) -> RWS DocEnv Chunks LineBuffer ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Chunk -> Trimmable Chunk
forall a. a -> Trimmable a
NotTrimmable Chunk
chunk Trimmable Chunk -> LineBuffer -> LineBuffer
forall a. a -> [a] -> [a]
:)
[DocE] -> RWS DocEnv Chunks LineBuffer ()
go [DocE]
docs
go (Softspace : docs :: [DocE]
docs) = do
DocE
hard <- DocE -> [DocE] -> DocM DocE
softConversion DocE
Softspace [DocE]
docs
[DocE] -> RWS DocEnv Chunks LineBuffer ()
go (DocE
hard DocE -> [DocE] -> [DocE]
forall a. a -> [a] -> [a]
: [DocE]
docs)
go (Hardspace : docs :: [DocE]
docs) = do
Chunk
chunk <- String -> DocM Chunk
makeChunk " "
(LineBuffer -> LineBuffer) -> RWS DocEnv Chunks LineBuffer ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (Chunk -> Trimmable Chunk
forall a. a -> Trimmable a
NotTrimmable Chunk
chunk Trimmable Chunk -> LineBuffer -> LineBuffer
forall a. a -> [a] -> [a]
:)
[DocE] -> RWS DocEnv Chunks LineBuffer ()
go [DocE]
docs
go (Softline : docs :: [DocE]
docs) = do
DocE
hard <- DocE -> [DocE] -> DocM DocE
softConversion DocE
Softline [DocE]
docs
[DocE] -> RWS DocEnv Chunks LineBuffer ()
go (DocE
hard DocE -> [DocE] -> [DocE]
forall a. a -> [a] -> [a]
: [DocE]
docs)
go (Hardline : docs :: [DocE]
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]
LineBuffer
indentation <- (DocEnv -> LineBuffer)
-> RWST DocEnv Chunks LineBuffer Identity LineBuffer
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DocEnv -> LineBuffer
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
$ \_ -> if [DocE] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [DocE]
docs then [] else LineBuffer
indentation
[DocE] -> RWS DocEnv Chunks LineBuffer ()
go [DocE]
docs
go (WrapAt {..} : docs :: [DocE]
docs) = do
(DocEnv -> DocEnv)
-> RWS DocEnv Chunks LineBuffer ()
-> RWS DocEnv Chunks LineBuffer ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: DocEnv
env -> DocEnv
env {deWrap :: Maybe Int
deWrap = Maybe Int
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] -> RWS DocEnv Chunks LineBuffer ()
go (Doc -> [DocE]
unDoc Doc
wrapDoc)
[DocE] -> RWS DocEnv Chunks LineBuffer ()
go [DocE]
docs
go (Ansi {..} : docs :: [DocE]
docs) = do
(DocEnv -> DocEnv)
-> RWS DocEnv Chunks LineBuffer ()
-> RWS DocEnv Chunks LineBuffer ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: DocEnv
env -> DocEnv
env {deCodes :: [SGR]
deCodes = [SGR] -> [SGR]
ansiCode (DocEnv -> [SGR]
deCodes DocEnv
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] -> RWS DocEnv Chunks LineBuffer ()
go (Doc -> [DocE]
unDoc Doc
ansiDoc)
[DocE] -> RWS DocEnv Chunks LineBuffer ()
go [DocE]
docs
go (Indent {..} : docs :: [DocE]
docs) = do
(DocEnv -> DocEnv)
-> RWS DocEnv Chunks LineBuffer ()
-> RWS DocEnv Chunks LineBuffer ()
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\env :: DocEnv
env -> DocEnv
env {deIndent :: LineBuffer
deIndent = LineBuffer
indentOtherLines LineBuffer -> LineBuffer -> LineBuffer
forall a. [a] -> [a] -> [a]
++ DocEnv -> LineBuffer
deIndent DocEnv
env}) (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
indentFirstLine LineBuffer -> LineBuffer -> LineBuffer
forall a. [a] -> [a] -> [a]
++)
[DocE] -> RWS DocEnv Chunks LineBuffer ()
go (Doc -> [DocE]
unDoc Doc
indentDoc)
[DocE] -> RWS DocEnv Chunks LineBuffer ()
go [DocE]
docs
makeChunk :: String -> DocM Chunk
makeChunk :: String -> DocM Chunk
makeChunk str :: 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 (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
softConversion :: DocE -> [DocE] -> DocM DocE
softConversion :: DocE -> [DocE] -> DocM DocE
softConversion soft :: DocE
soft docs :: [DocE]
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
Nothing -> DocE -> DocM DocE
forall (m :: * -> *) a. Monad m => a -> m a
return DocE
hard
Just maxCol :: Int
maxCol -> do
String
currentLine <- (LineBuffer -> String)
-> RWST DocEnv Chunks LineBuffer Identity String
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Chunk -> String) -> Chunks -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Chunk -> String
chunkToString (Chunks -> String)
-> (LineBuffer -> Chunks) -> LineBuffer -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LineBuffer -> Chunks
bufferToChunks)
let currentCol :: Int
currentCol = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
currentLine
case [DocE] -> Maybe Int
nextWordLength [DocE]
docs of
Nothing -> DocE -> DocM DocE
forall (m :: * -> *) a. Monad m => a -> m a
return DocE
hard
Just l :: Int
l
| Int
currentCol Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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 -> DocM DocE
forall (m :: * -> *) a. Monad m => a -> m a
return DocE
Hardspace
| Bool
otherwise -> DocE -> DocM DocE
forall (m :: * -> *) a. Monad m => a -> m a
return DocE
Hardline
where
hard :: DocE
hard = case DocE
soft of
Softspace -> DocE
Hardspace
Softline -> DocE
Hardline
_ -> DocE
soft
nextWordLength :: [DocE] -> Maybe Int
nextWordLength :: [DocE] -> Maybe Int
nextWordLength [] = Maybe Int
forall a. Maybe a
Nothing
nextWordLength (String x :: String
x : xs :: [DocE]
xs)
| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null String
x = [DocE] -> Maybe Int
nextWordLength [DocE]
xs
| Bool
otherwise = Int -> Maybe Int
forall a. a -> Maybe a
Just (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x)
nextWordLength (Softspace : xs :: [DocE]
xs) = [DocE] -> Maybe Int
nextWordLength [DocE]
xs
nextWordLength (Hardspace : xs :: [DocE]
xs) = [DocE] -> Maybe Int
nextWordLength [DocE]
xs
nextWordLength (Softline : xs :: [DocE]
xs) = [DocE] -> Maybe Int
nextWordLength [DocE]
xs
nextWordLength (Hardline : _) = Maybe Int
forall a. Maybe a
Nothing
nextWordLength (WrapAt {..} : xs :: [DocE]
xs) = [DocE] -> Maybe Int
nextWordLength (Doc -> [DocE]
unDoc Doc
wrapDoc [DocE] -> [DocE] -> [DocE]
forall a. [a] -> [a] -> [a]
++ [DocE]
xs)
nextWordLength (Ansi {..} : xs :: [DocE]
xs) = [DocE] -> Maybe Int
nextWordLength (Doc -> [DocE]
unDoc Doc
ansiDoc [DocE] -> [DocE] -> [DocE]
forall a. [a] -> [a] -> [a]
++ [DocE]
xs)
nextWordLength (Indent {..} : xs :: [DocE]
xs) = [DocE] -> Maybe Int
nextWordLength (Doc -> [DocE]
unDoc Doc
indentDoc [DocE] -> [DocE] -> [DocE]
forall a. [a] -> [a] -> [a]
++ [DocE]
xs)
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
dimensions :: Doc -> (Int, Int)
dimensions :: Doc -> (Int, Int)
dimensions doc :: Doc
doc =
let ls :: [String]
ls = String -> [String]
lines (Doc -> String
toString Doc
doc) in
([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls, (Int -> Int -> Int) -> Int -> [Int] -> Int
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 0 ((String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
ls))
null :: Doc -> Bool
null :: Doc -> Bool
null doc :: Doc
doc = case Doc -> [DocE]
unDoc Doc
doc of [] -> Bool
True; _ -> Bool
False
hPutDoc :: IO.Handle -> Doc -> IO ()
hPutDoc :: Handle -> Doc -> IO ()
hPutDoc h :: 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
mkDoc :: DocE -> Doc
mkDoc e :: DocE
e = [DocE] -> Doc
Doc [DocE
e]
string :: String -> Doc
string :: String -> Doc
string = DocE -> Doc
mkDoc (DocE -> Doc) -> (String -> DocE) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DocE
String
text :: T.Text -> Doc
text :: Text -> Doc
text = String -> Doc
string (String -> Doc) -> (Text -> String) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
space :: Doc
space :: Doc
space = DocE -> Doc
mkDoc DocE
Softspace
spaces :: Int -> Doc
spaces :: Int -> Doc
spaces n :: Int
n = [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> [Doc]
forall a. Int -> a -> [a]
replicate Int
n Doc
space
softline :: Doc
softline :: Doc
softline = DocE -> Doc
mkDoc DocE
Softline
hardline :: Doc
hardline :: Doc
hardline = DocE -> Doc
mkDoc DocE
Hardline
wrapAt :: Maybe Int -> Doc -> Doc
wrapAt :: Maybe Int -> Doc -> Doc
wrapAt wrapAtCol :: Maybe Int
wrapAtCol wrapDoc :: Doc
wrapDoc = DocE -> Doc
mkDoc WrapAt :: Maybe Int -> Doc -> DocE
WrapAt {..}
indent :: Trimmable Doc -> Trimmable Doc -> Doc -> Doc
indent :: Trimmable Doc -> Trimmable Doc -> Doc -> Doc
indent firstLineDoc :: Trimmable Doc
firstLineDoc otherLinesDoc :: Trimmable Doc
otherLinesDoc doc :: Doc
doc = DocE -> Doc
mkDoc (DocE -> Doc) -> DocE -> Doc
forall a b. (a -> b) -> a -> b
$ Indent :: LineBuffer -> LineBuffer -> Doc -> DocE
Indent
{ indentFirstLine :: LineBuffer
indentFirstLine = (Doc -> Chunks) -> Trimmable Doc -> LineBuffer
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Doc -> Chunks
docToChunks Trimmable Doc
firstLineDoc
, indentOtherLines :: LineBuffer
indentOtherLines = (Doc -> Chunks) -> Trimmable Doc -> LineBuffer
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Doc -> Chunks
docToChunks Trimmable Doc
otherLinesDoc
, indentDoc :: Doc
indentDoc = Doc
doc
}
ansi :: [Ansi.SGR] -> Doc -> Doc
ansi :: [SGR] -> Doc -> Doc
ansi codes :: [SGR]
codes = DocE -> Doc
mkDoc (DocE -> Doc) -> (Doc -> DocE) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([SGR] -> [SGR]) -> Doc -> DocE
Ansi ([SGR]
codes [SGR] -> [SGR] -> [SGR]
forall a. [a] -> [a] -> [a]
++)
(<+>) :: Doc -> Doc -> Doc
x :: Doc
x <+> :: Doc -> Doc -> Doc
<+> y :: Doc
y = Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
space Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
y
infixr 6 <+>
(<$$>) :: Doc -> Doc -> Doc
x :: Doc
x <$$> :: Doc -> Doc -> Doc
<$$> y :: Doc
y = Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
hardline Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
y
infixr 5 <$$>
vcat :: [Doc] -> Doc
vcat :: [Doc] -> Doc
vcat = Doc -> [Doc] -> Doc
intersperse Doc
hardline
intersperse :: Doc -> [Doc] -> Doc
intersperse :: Doc -> [Doc] -> Doc
intersperse sep :: Doc
sep = [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
L.intersperse Doc
sep
data Alignment = AlignLeft | AlignCenter | AlignRight deriving (Alignment -> Alignment -> Bool
(Alignment -> Alignment -> Bool)
-> (Alignment -> Alignment -> Bool) -> Eq Alignment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Alignment -> Alignment -> Bool
$c/= :: Alignment -> Alignment -> Bool
== :: Alignment -> Alignment -> Bool
$c== :: Alignment -> Alignment -> Bool
Eq, Eq Alignment
Eq Alignment =>
(Alignment -> Alignment -> Ordering)
-> (Alignment -> Alignment -> Bool)
-> (Alignment -> Alignment -> Bool)
-> (Alignment -> Alignment -> Bool)
-> (Alignment -> Alignment -> Bool)
-> (Alignment -> Alignment -> Alignment)
-> (Alignment -> Alignment -> Alignment)
-> Ord Alignment
Alignment -> Alignment -> Bool
Alignment -> Alignment -> Ordering
Alignment -> Alignment -> Alignment
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
min :: Alignment -> Alignment -> Alignment
$cmin :: Alignment -> Alignment -> Alignment
max :: Alignment -> Alignment -> Alignment
$cmax :: Alignment -> Alignment -> Alignment
>= :: Alignment -> Alignment -> Bool
$c>= :: Alignment -> Alignment -> Bool
> :: Alignment -> Alignment -> Bool
$c> :: Alignment -> Alignment -> Bool
<= :: Alignment -> Alignment -> Bool
$c<= :: Alignment -> Alignment -> Bool
< :: Alignment -> Alignment -> Bool
$c< :: Alignment -> Alignment -> Bool
compare :: Alignment -> Alignment -> Ordering
$ccompare :: Alignment -> Alignment -> Ordering
$cp1Ord :: Eq Alignment
Ord, Int -> Alignment -> String -> String
[Alignment] -> String -> String
Alignment -> String
(Int -> Alignment -> String -> String)
-> (Alignment -> String)
-> ([Alignment] -> String -> String)
-> Show Alignment
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Alignment] -> String -> String
$cshowList :: [Alignment] -> String -> String
show :: Alignment -> String
$cshow :: Alignment -> String
showsPrec :: Int -> Alignment -> String -> String
$cshowsPrec :: Int -> Alignment -> String -> String
Show)
align :: Int -> Alignment -> Doc -> Doc
align :: Int -> Alignment -> Doc -> Doc
align width :: Int
width alignment :: Alignment
alignment doc0 :: Doc
doc0 =
let chunks0 :: Chunks
chunks0 = Doc -> Chunks
docToChunks Doc
doc0
lines_ :: [Chunks]
lines_ = Chunks -> [Chunks]
chunkLines Chunks
chunks0 in
[Doc] -> Doc
vcat
[ [DocE] -> Doc
Doc ((Chunk -> DocE) -> Chunks -> [DocE]
forall a b. (a -> b) -> [a] -> [b]
map Chunk -> DocE
chunkToDocE (Chunks -> Chunks
alignLine Chunks
line))
| Chunks
line <- [Chunks]
lines_
]
where
lineWidth :: [Chunk] -> Int
lineWidth :: Chunks -> Int
lineWidth = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> (Chunks -> [Int]) -> Chunks -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chunk -> Int) -> Chunks -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (String -> Int) -> (Chunk -> String) -> Chunk -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk -> String
chunkToString)
alignLine :: [Chunk] -> [Chunk]
alignLine :: Chunks -> Chunks
alignLine line :: Chunks
line =
let actual :: Int
actual = Chunks -> Int
lineWidth Chunks
line
chunkSpaces :: Int -> Chunks
chunkSpaces n :: Int
n = [[SGR] -> String -> Chunk
StringChunk [] (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n ' ')] in
case Alignment
alignment of
AlignLeft -> Chunks
line Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> Int -> Chunks
chunkSpaces (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
actual)
AlignRight -> Int -> Chunks
chunkSpaces (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
actual) Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> Chunks
line
AlignCenter ->
let r :: Int
r = (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
actual) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2
l :: Int
l = (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
actual) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r in
Int -> Chunks
chunkSpaces Int
l Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> Chunks
line Chunks -> Chunks -> Chunks
forall a. Semigroup a => a -> a -> a
<> Int -> Chunks
chunkSpaces Int
r
paste :: [Doc] -> Doc
paste :: [Doc] -> Doc
paste docs0 :: [Doc]
docs0 =
let chunkss :: [Chunks]
chunkss = (Doc -> Chunks) -> [Doc] -> [Chunks]
forall a b. (a -> b) -> [a] -> [b]
map Doc -> Chunks
docToChunks [Doc]
docs0 :: [Chunks]
cols :: [[Chunks]]
cols = (Chunks -> [Chunks]) -> [Chunks] -> [[Chunks]]
forall a b. (a -> b) -> [a] -> [b]
map Chunks -> [Chunks]
chunkLines [Chunks]
chunkss :: [[Chunks]]
rows0 :: [[Chunks]]
rows0 = [[Chunks]] -> [[Chunks]]
forall a. [[a]] -> [[a]]
L.transpose [[Chunks]]
cols :: [[Chunks]]
rows1 :: [[Doc]]
rows1 = ([Chunks] -> [Doc]) -> [[Chunks]] -> [[Doc]]
forall a b. (a -> b) -> [a] -> [b]
map ((Chunks -> Doc) -> [Chunks] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([DocE] -> Doc
Doc ([DocE] -> Doc) -> (Chunks -> [DocE]) -> Chunks -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chunk -> DocE) -> Chunks -> [DocE]
forall a b. (a -> b) -> [a] -> [b]
map Chunk -> DocE
chunkToDocE)) [[Chunks]]
rows0 :: [[Doc]] in
[Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ([Doc] -> Doc) -> [[Doc]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat [[Doc]]
rows1