--------------------------------------------------------------------------------
-- | 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

    , Indentation (..)
    , indent
    , deindent

    , 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 (String -> Doc) -> (Char -> String) -> Char -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure


--------------------------------------------------------------------------------
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 -> Doc
mkDoc DocE Doc
forall d. DocE d
Softspace


--------------------------------------------------------------------------------
spaces :: Int -> Doc
spaces :: Int -> Doc
spaces 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 -> Doc
mkDoc DocE Doc
forall d. DocE d
Softline


--------------------------------------------------------------------------------
hardline :: Doc
hardline :: Doc
hardline = DocE Doc -> Doc
mkDoc DocE Doc
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
wrapAtCol :: Maybe Int
wrapDoc :: Doc
wrapAtCol :: Maybe Int
wrapDoc :: Doc
..}


--------------------------------------------------------------------------------
indent :: Indentation Doc -> Indentation Doc -> Doc -> Doc
indent :: Indentation Doc -> Indentation Doc -> Doc -> Doc
indent Indentation Doc
firstLineDoc Indentation Doc
otherLinesDoc Doc
doc = DocE Doc -> Doc
mkDoc (DocE Doc -> Doc) -> DocE Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Indent
    { indentFirstLine :: Indentation [Chunk]
indentFirstLine  = (Doc -> [Chunk]) -> Indentation Doc -> Indentation [Chunk]
forall a b. (a -> b) -> Indentation a -> Indentation b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> [Chunk]
docToChunks Indentation Doc
firstLineDoc
    , indentOtherLines :: Indentation [Chunk]
indentOtherLines = (Doc -> [Chunk]) -> Indentation Doc -> Indentation [Chunk]
forall a b. (a -> b) -> Indentation a -> Indentation b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> [Chunk]
docToChunks Indentation Doc
otherLinesDoc
    , indentDoc :: Doc
indentDoc        = Doc
doc
    }


--------------------------------------------------------------------------------
-- | Only strips leading spaces
deindent :: Doc -> Doc
deindent :: Doc -> Doc
deindent = [DocE Doc] -> Doc
Doc ([DocE Doc] -> Doc) -> (Doc -> [DocE Doc]) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DocE Doc -> [DocE Doc]) -> [DocE Doc] -> [DocE Doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DocE Doc -> [DocE Doc]
go ([DocE Doc] -> [DocE Doc])
-> (Doc -> [DocE Doc]) -> Doc -> [DocE Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [DocE Doc]
unDoc
  where
    go :: DocE Doc -> [DocE Doc]
    go :: DocE Doc -> [DocE Doc]
go doc :: DocE Doc
doc@(Indent {Indentation [Chunk]
Doc
indentFirstLine :: forall d. DocE d -> Indentation [Chunk]
indentOtherLines :: forall d. DocE d -> Indentation [Chunk]
indentDoc :: forall d. DocE d -> d
indentFirstLine :: Indentation [Chunk]
indentOtherLines :: Indentation [Chunk]
indentDoc :: Doc
..})
        | Int
fs0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
&& Int
os0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = [DocE Doc
doc]
        | Int
fs1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Int
os1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& [Chunk] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Chunk]
fc Bool -> Bool -> Bool
&& [Chunk] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
L.null [Chunk]
oc =
            (DocE Doc -> [DocE Doc]) -> [DocE Doc] -> [DocE Doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap DocE Doc -> [DocE Doc]
go ([DocE Doc] -> [DocE Doc]) -> [DocE Doc] -> [DocE Doc]
forall a b. (a -> b) -> a -> b
$ Doc -> [DocE Doc]
unDoc Doc
indentDoc
        | Bool
otherwise = DocE Doc -> [DocE Doc]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DocE Doc -> [DocE Doc]) -> DocE Doc -> [DocE Doc]
forall a b. (a -> b) -> a -> b
$ Indent
            { indentFirstLine :: Indentation [Chunk]
indentFirstLine  = Int -> [Chunk] -> Indentation [Chunk]
forall a. Int -> a -> Indentation a
Indentation Int
fs1 [Chunk]
fc
            , indentOtherLines :: Indentation [Chunk]
indentOtherLines = Int -> [Chunk] -> Indentation [Chunk]
forall a. Int -> a -> Indentation a
Indentation Int
os1 [Chunk]
oc
            , indentDoc :: Doc
indentDoc        = Doc
indentDoc
            }
      where
        Indentation Int
fs0 [Chunk]
fc = Indentation [Chunk]
indentFirstLine
        Indentation Int
os0 [Chunk]
oc = Indentation [Chunk]
indentOtherLines
        fs1 :: Int
fs1 = Int
fs0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
fs0 Int
os0
        os1 :: Int
os1 = Int
os0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
fs0 Int
os0
    go DocE Doc
doc = [DocE Doc
doc]


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


--------------------------------------------------------------------------------
(<+>) :: Doc -> Doc -> Doc
Doc
x <+> :: Doc -> Doc -> Doc
<+> 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
Doc
x <$$> :: Doc -> Doc -> Doc
<$$> 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 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
$c== :: Alignment -> Alignment -> Bool
== :: Alignment -> Alignment -> Bool
$c/= :: Alignment -> Alignment -> Bool
/= :: 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
$ccompare :: Alignment -> Alignment -> Ordering
compare :: Alignment -> Alignment -> Ordering
$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
>= :: Alignment -> Alignment -> Bool
$cmax :: Alignment -> Alignment -> Alignment
max :: Alignment -> Alignment -> Alignment
$cmin :: Alignment -> Alignment -> Alignment
min :: Alignment -> Alignment -> Alignment
Ord, Int -> Alignment -> ShowS
[Alignment] -> ShowS
Alignment -> String
(Int -> Alignment -> ShowS)
-> (Alignment -> String)
-> ([Alignment] -> ShowS)
-> Show Alignment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Alignment -> ShowS
showsPrec :: Int -> Alignment -> ShowS
$cshow :: Alignment -> String
show :: Alignment -> String
$cshowList :: [Alignment] -> ShowS
showList :: [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 (Doc -> [Chunk]) -> Doc -> [Chunk]
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 ((Chunk -> DocE Doc) -> [Chunk] -> [DocE 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 = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> ([Chunk] -> [Int]) -> [Chunk] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chunk -> Int) -> [Chunk] -> [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)

    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 [] (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ')] in
        case Alignment
alignment of
            Alignment
AlignLeft   -> [Chunk]
line [Chunk] -> [Chunk] -> [Chunk]
forall a. Semigroup a => a -> a -> a
<> Int -> [Chunk]
chunkSpaces (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
actual)
            Alignment
AlignRight  -> Int -> [Chunk]
chunkSpaces (Int
width Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
actual) [Chunk] -> [Chunk] -> [Chunk]
forall a. Semigroup a => a -> a -> a
<> [Chunk]
line
            Alignment
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` Int
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 -> [Chunk]
chunkSpaces Int
l [Chunk] -> [Chunk] -> [Chunk]
forall a. Semigroup a => a -> a -> a
<> [Chunk]
line [Chunk] -> [Chunk] -> [Chunk]
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 = (Doc -> [Chunk]) -> [Doc] -> [[Chunk]]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> [Chunk]
docToChunks (Doc -> [Chunk]) -> (Doc -> Doc) -> Doc -> [Chunk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
removeControls) [Doc]
docs0 :: [Chunks]
        cols :: [[[Chunk]]]
cols    = ([Chunk] -> [[Chunk]]) -> [[Chunk]] -> [[[Chunk]]]
forall a b. (a -> b) -> [a] -> [b]
map [Chunk] -> [[Chunk]]
chunkLines [[Chunk]]
chunkss                   :: [[Chunks]]
        rows0 :: [[[Chunk]]]
rows0   = [[[Chunk]]] -> [[[Chunk]]]
forall a. [[a]] -> [[a]]
L.transpose [[[Chunk]]]
cols                         :: [[Chunks]]
        rows1 :: [[Doc]]
rows1   = ([[Chunk]] -> [Doc]) -> [[[Chunk]]] -> [[Doc]]
forall a b. (a -> b) -> [a] -> [b]
map (([Chunk] -> Doc) -> [[Chunk]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([DocE Doc] -> Doc
Doc ([DocE Doc] -> Doc) -> ([Chunk] -> [DocE Doc]) -> [Chunk] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Chunk -> DocE Doc) -> [Chunk] -> [DocE Doc]
forall a b. (a -> b) -> [a] -> [b]
map Chunk -> DocE Doc
chunkToDocE)) [[[Chunk]]]
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


--------------------------------------------------------------------------------
removeControls :: Doc -> Doc
removeControls :: Doc -> Doc
removeControls = [DocE Doc] -> Doc
Doc ([DocE Doc] -> Doc) -> (Doc -> [DocE Doc]) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DocE Doc -> Bool) -> [DocE Doc] -> [DocE Doc]
forall a. (a -> Bool) -> [a] -> [a]
filter DocE Doc -> Bool
forall {d}. DocE d -> Bool
isNotControl ([DocE Doc] -> [DocE Doc])
-> (Doc -> [DocE Doc]) -> Doc -> [DocE Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DocE Doc -> DocE Doc) -> [DocE Doc] -> [DocE Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc -> Doc) -> DocE Doc -> DocE Doc
forall a b. (a -> b) -> DocE a -> DocE b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Doc -> Doc
removeControls) ([DocE Doc] -> [DocE Doc])
-> (Doc -> [DocE Doc]) -> Doc -> [DocE Doc]
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 (DocE Doc -> Doc) -> DocE Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Control -> DocE Doc
forall d. Control -> DocE d
Control Control
ClearScreenControl


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