--------------------------------------------------------------------------------
-- | This is a small pretty-printing library.
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards            #-}
module Patat.PrettyPrint
    ( Doc
    , toString
    , dimensions
    , null

    , hPutDoc
    , putDoc

    , char
    , string
    , text
    , space
    , spaces
    , softline
    , hardline

    , wrapAt

    , Trimmable (..)
    , indent

    , ansi

    , (<+>)
    , (<$$>)
    , vcat
    , intersperse

    -- * Exotic combinators
    , Alignment (..)
    , align
    , paste

    -- * Control codes
    , removeControls
    , clearScreen
    , goToLine
    ) where


--------------------------------------------------------------------------------
import           Data.Char.WCWidth.Extended (wcstrwidth)
import qualified Data.List                  as L
import qualified Data.Text                  as T
import           Patat.PrettyPrint.Internal
import           Prelude                    hiding (null)
import qualified System.Console.ANSI        as Ansi


--------------------------------------------------------------------------------
char :: Char -> Doc
char :: Char -> Doc
char = String -> Doc
string forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure


--------------------------------------------------------------------------------
text :: T.Text -> Doc
text :: Text -> Doc
text = String -> Doc
string forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack


--------------------------------------------------------------------------------
space :: Doc
space :: Doc
space = DocE Doc -> Doc
mkDoc forall d. DocE d
Softspace


--------------------------------------------------------------------------------
spaces :: Int -> Doc
spaces :: Int -> Doc
spaces Int
n = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
n Doc
space


--------------------------------------------------------------------------------
softline :: Doc
softline :: Doc
softline = DocE Doc -> Doc
mkDoc forall d. DocE d
Softline


--------------------------------------------------------------------------------
hardline :: Doc
hardline :: Doc
hardline = DocE Doc -> Doc
mkDoc forall d. DocE d
Hardline


--------------------------------------------------------------------------------
wrapAt :: Maybe Int -> Doc -> Doc
wrapAt :: Maybe Int -> Doc -> Doc
wrapAt Maybe Int
wrapAtCol Doc
wrapDoc = DocE Doc -> Doc
mkDoc WrapAt {Maybe Int
Doc
wrapDoc :: Doc
wrapAtCol :: Maybe Int
wrapDoc :: Doc
wrapAtCol :: Maybe Int
..}


--------------------------------------------------------------------------------
indent :: Trimmable Doc -> Trimmable Doc -> Doc -> Doc
indent :: Trimmable Doc -> Trimmable Doc -> Doc -> Doc
indent Trimmable Doc
firstLineDoc Trimmable Doc
otherLinesDoc Doc
doc = DocE Doc -> Doc
mkDoc forall a b. (a -> b) -> a -> b
$ Indent
    { indentFirstLine :: LineBuffer
indentFirstLine  = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Doc -> [Chunk]
docToChunks Trimmable Doc
firstLineDoc
    , indentOtherLines :: LineBuffer
indentOtherLines = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Doc -> [Chunk]
docToChunks Trimmable Doc
otherLinesDoc
    , indentDoc :: Doc
indentDoc        = Doc
doc
    }


--------------------------------------------------------------------------------
ansi :: [Ansi.SGR] -> Doc -> Doc
ansi :: [SGR] -> Doc -> Doc
ansi [SGR]
codes =  DocE Doc -> Doc
mkDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. ([SGR] -> [SGR]) -> d -> DocE d
Ansi ([SGR]
codes forall a. [a] -> [a] -> [a]
++)


--------------------------------------------------------------------------------
(<+>) :: Doc -> Doc -> Doc
Doc
x <+> :: Doc -> Doc -> Doc
<+> Doc
y = Doc
x forall a. Semigroup a => a -> a -> a
<> Doc
space forall a. Semigroup a => a -> a -> a
<> Doc
y
infixr 6 <+>


--------------------------------------------------------------------------------
(<$$>) :: Doc -> Doc -> Doc
Doc
x <$$> :: Doc -> Doc -> Doc
<$$> Doc
y = Doc
x forall a. Semigroup a => a -> a -> a
<> Doc
hardline 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 Doc
sep = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
L.intersperse Doc
sep


--------------------------------------------------------------------------------
data Alignment = AlignLeft | AlignCenter | AlignRight deriving (Alignment -> Alignment -> Bool
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
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
Ord, Int -> Alignment -> ShowS
[Alignment] -> ShowS
Alignment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Alignment] -> ShowS
$cshowList :: [Alignment] -> ShowS
show :: Alignment -> String
$cshow :: Alignment -> String
showsPrec :: Int -> Alignment -> ShowS
$cshowsPrec :: Int -> Alignment -> ShowS
Show)


--------------------------------------------------------------------------------
align :: Int -> Alignment -> Doc -> Doc
align :: Int -> Alignment -> Doc -> Doc
align Int
width Alignment
alignment Doc
doc0 =
    let chunks0 :: [Chunk]
chunks0 = Doc -> [Chunk]
docToChunks forall a b. (a -> b) -> a -> b
$ Doc -> Doc
removeControls Doc
doc0
        lines_ :: [[Chunk]]
lines_  = [Chunk] -> [[Chunk]]
chunkLines [Chunk]
chunks0 in
    [Doc] -> Doc
vcat
        [ [DocE Doc] -> Doc
Doc (forall a b. (a -> b) -> [a] -> [b]
map Chunk -> DocE Doc
chunkToDocE ([Chunk] -> [Chunk]
alignLine [Chunk]
line))
        | [Chunk]
line <- [[Chunk]]
lines_
        ]
  where
    lineWidth :: [Chunk] -> Int
    lineWidth :: [Chunk] -> Int
lineWidth = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (String -> Int
wcstrwidth forall b c a. (b -> c) -> (a -> b) -> a -> c
. Chunk -> String
chunkToString)

    alignLine :: [Chunk] -> [Chunk]
    alignLine :: [Chunk] -> [Chunk]
alignLine [Chunk]
line =
        let actual :: Int
actual        = [Chunk] -> Int
lineWidth [Chunk]
line
            chunkSpaces :: Int -> [Chunk]
chunkSpaces Int
n = [[SGR] -> String -> Chunk
StringChunk [] (forall a. Int -> a -> [a]
replicate Int
n Char
' ')] in
        case Alignment
alignment of
            Alignment
AlignLeft   -> [Chunk]
line forall a. Semigroup a => a -> a -> a
<> Int -> [Chunk]
chunkSpaces (Int
width forall a. Num a => a -> a -> a
- Int
actual)
            Alignment
AlignRight  -> Int -> [Chunk]
chunkSpaces (Int
width forall a. Num a => a -> a -> a
- Int
actual) forall a. Semigroup a => a -> a -> a
<> [Chunk]
line
            Alignment
AlignCenter ->
                let r :: Int
r = (Int
width forall a. Num a => a -> a -> a
- Int
actual) forall a. Integral a => a -> a -> a
`div` Int
2
                    l :: Int
l = (Int
width forall a. Num a => a -> a -> a
- Int
actual) forall a. Num a => a -> a -> a
- Int
r in
                Int -> [Chunk]
chunkSpaces Int
l forall a. Semigroup a => a -> a -> a
<> [Chunk]
line forall a. Semigroup a => a -> a -> a
<> Int -> [Chunk]
chunkSpaces Int
r


--------------------------------------------------------------------------------
-- | Like the unix program 'paste'.
paste :: [Doc] -> Doc
paste :: [Doc] -> Doc
paste [Doc]
docs0 =
    let chunkss :: [[Chunk]]
chunkss = forall a b. (a -> b) -> [a] -> [b]
map (Doc -> [Chunk]
docToChunks forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
removeControls) [Doc]
docs0 :: [Chunks]
        cols :: [[[Chunk]]]
cols    = forall a b. (a -> b) -> [a] -> [b]
map [Chunk] -> [[Chunk]]
chunkLines [[Chunk]]
chunkss                   :: [[Chunks]]
        rows0 :: [[[Chunk]]]
rows0   = forall a. [[a]] -> [[a]]
L.transpose [[[Chunk]]]
cols                         :: [[Chunks]]
        rows1 :: [[Doc]]
rows1   = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map ([DocE Doc] -> Doc
Doc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Chunk -> DocE Doc
chunkToDocE)) [[[Chunk]]]
rows0  :: [[Doc]] in
    [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Monoid a => [a] -> a
mconcat [[Doc]]
rows1


--------------------------------------------------------------------------------
removeControls :: Doc -> Doc
removeControls :: Doc -> Doc
removeControls = [DocE Doc] -> Doc
Doc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall {d}. DocE d -> Bool
isNotControl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> Doc
removeControls) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [DocE Doc]
unDoc
  where
    isNotControl :: DocE d -> Bool
isNotControl (Control Control
_) = Bool
False
    isNotControl DocE d
_           = Bool
True


--------------------------------------------------------------------------------
clearScreen :: Doc
clearScreen :: Doc
clearScreen = DocE Doc -> Doc
mkDoc forall a b. (a -> b) -> a -> b
$ forall d. Control -> DocE d
Control Control
ClearScreenControl


--------------------------------------------------------------------------------
goToLine :: Int -> Doc
goToLine :: Int -> Doc
goToLine = DocE Doc -> Doc
mkDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall d. Control -> DocE d
Control forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Control
GoToLineControl