{- | super simple pretty printer:

Abstract: the only option of formatting
is to increase indentation by a fixed amount.

Application: this is mainly used for pretty-printing
Haskell data literals (records, tuples, lists).

Design goals:

1. for parenthesized (by {}[]() ) sub-structure,
   the opening paren, separators (;,), closing paren
   should be in the same column

2. the location (distance to left margin)
   of that column should only depend on the semantic nesting level
   of sub-structures  (and not on the width of the layout
   of elements of sub-structures)

3. small sub-structures should be put on one line (if they fit)

Example:

> ( Leftist 
>     { tree = Branch 
>         { left = Branch { left = Leaf, key = 4, right = Leaf }
>         , key = 3
>         , right = Leaf 
>         }
>     , refs = listToFM [ ( Ref 13, [ 0 ] ), ( Ref 17, [ ] ) ] 
>     }
> , [ Any, Any ]
> )

Realisation (concept)

1. there is a layout element `nest` (that is called for each opening delimiter)
   that increases the semantic indentation (for its scope)

2. there is a layout element `skip` that compares semantic indentation s
   with current indentation (position of write-head on line) c,
   and if s < c (the head is too far ahead),
   it will insert a line-break, and advance to position s
   (by inserting white space)

This is used in combinator

> l </> r = (l <> " ") <> nest 2 (skip <> r)

that is applied for each block: 'pretty (1,2,3)' is

> vcat [ "(" </> 1, "," </> 2, "," </> 3, ")" ]

and 'pretty (Foo {bar = B})' is

> "Foo" </> vcat [ "{" </> "bar" <+> "=" <+> "B", "}" ]

Note that we might have a named record instead of 'B',
starting with '"B" </> ...', so the 'skip' happens
*after* the constructor name. This is applied in the example above.

3. We want the full layout process to be lazy
(do not build the full document when we only want some prefix).

> ghci> L.take 10  $  renderT $ toDoc $ replicate 1000000 ()
> "[ ( )\n, ( "
> (0.00 secs, 1,169,104 bytes)

There is just one place where the algorithm has to consider
alternative layouts: the 'group' operator will make a layout
without line breaks, if that fits on the current line.
For that decision (does it fit?)
we need to determine the size of the sub-document quickly.
We use a representation of natural numbers, see type 'Size' below,
with lazy addition and comparison.

-}

{-# language OverloadedStrings #-}
{-# language TemplateHaskell #-}
{-# language BangPatterns #-}

module Text.PrettyPrint.Dent

( Doc
  , displayT
  , renderCompact, renderWide, renderPretty, renderFlat
  , textStrict
  , (<+>), (<$$>), (<//>)
  , empty, vcat, hcat, cat, hsep, vsep, sep
  , line, softline, linebreak, softbreak
  , fillSep, fill, fillBreak, group, align
  , nest, indent
  , parens, brackets, braces, dquotes, encloseSep
  , skip, comma, colon, semi, equals, char
  , int, integer, float, double
  )

where

import qualified Data.Text as T
import qualified Data.Text.Lazy as L
import qualified Data.Text.Internal.Builder as B
import Data.String

import Prelude hiding (left, right, break)
import Data.Int (Int64)
import Data.List (foldl1')

import qualified Text.PrettyPrint.Leijen.Text as PP

line_width :: Int64
line_width :: Int64
line_width = Int64
80 {- MAGIC NUMBER -}
  
data Size = This !Int64 | Plus !Int64 Size
total :: Size -> Int64
total :: Size -> Int64
total (This Int64
i) = Int64
i
total (Plus Int64
a Size
b) = Int64
a Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Size -> Int64
total Size
b

instance Num Size where
  fromInteger :: Integer -> Size
fromInteger = Int64 -> Size
This (Int64 -> Size) -> (Integer -> Int64) -> Integer -> Size
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int64
forall a. Num a => Integer -> a
fromInteger
  Size
x + :: Size -> Size -> Size
+ Size
y = Int64 -> Size -> Size
Plus (Size -> Int64
total Size
x) Size
y

instance Eq Size where
instance Ord Size where
  This Int64
i < :: Size -> Size -> Bool
< This Int64
j = Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
j
  Plus Int64
i Size
a < This Int64
j =
    if Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Int64
j then Bool
False
    else Size
a Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
< Int64 -> Size
This (Int64
j Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
i)

data Doc
  = Empty
  | Item { Doc -> Size
_size :: !Size
         , Doc -> Int64
actual_size :: !Int64
         , Doc -> Builder
text :: !B.Builder
         } -- ^ should not contain newline
  | Line -- ^ space or next line (softline in wl-pprint)
  | Break -- ^ empty or next line (softbreak in wl-pprint)
  | Skip -- ^ skip to current indentation level,
  -- if we are already past this, then make a new line
  | Cat { _size :: !Size, Doc -> Doc
left :: !Doc, Doc -> Doc
right :: Doc }
      -- ^ concatenation (no white space)
  | Group { _size :: !Size, Doc -> Doc
contents :: !Doc }
    -- ^ when it fits on the line (current-indentation + size < line-end)
    -- then it is rendered without breaks, else, as-is
  | Nest { _size :: !Size, Doc -> Int64
delta :: !Int64, contents :: !Doc }
    -- ^ relative change of indentation
    -- (invisble, effect will happen after the next line break only)

{-# inline size #-}
size :: Doc -> Size
size :: Doc -> Size
size !Doc
d = case Doc
d of
  Doc
Empty -> Size
0; Doc
Line -> Size
0; Doc
Break -> Size
0; Doc
Skip -> Size
0
  Doc
_ -> Doc -> Size
_size Doc
d

type SimpleDoc = PP.SimpleDoc

displayT :: SimpleDoc -> Text
displayT = SimpleDoc -> Text
PP.displayT

renderCompact :: Doc -> SimpleDoc
renderCompact = Mode -> Int -> Doc -> SimpleDoc
renderMode Mode
Full Int
0
renderWide :: Doc -> SimpleDoc
renderWide = Mode -> Int -> Doc -> SimpleDoc
renderMode Mode
Full Int
0
renderFlat :: Doc -> SimpleDoc
renderFlat = Mode -> Int -> Doc -> SimpleDoc
renderMode Mode
Flat Int
0
renderPretty :: p -> p -> Doc -> SimpleDoc
renderPretty p
_ p
_ = Doc -> SimpleDoc
renderCompact

renderMode :: Mode -> Int -> Doc -> SimpleDoc
renderMode :: Mode -> Int -> Doc -> SimpleDoc
renderMode Mode
m Int
_ Doc
d = Mode
-> Int64
-> Int64
-> Doc
-> (Int64 -> Int64 -> SimpleDoc)
-> SimpleDoc
build Mode
m Int64
0 Int64
0 Doc
d ((Int64 -> Int64 -> SimpleDoc) -> SimpleDoc)
-> (Int64 -> Int64 -> SimpleDoc) -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ \ Int64
_ Int64
_ -> SimpleDoc
PP.SEmpty

data Mode = Flat | Full deriving (Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
(Int -> Mode -> ShowS)
-> (Mode -> String) -> ([Mode] -> ShowS) -> Show Mode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mode -> ShowS
showsPrec :: Int -> Mode -> ShowS
$cshow :: Mode -> String
show :: Mode -> String
$cshowList :: [Mode] -> ShowS
showList :: [Mode] -> ShowS
Show, Mode -> Mode -> Bool
(Mode -> Mode -> Bool) -> (Mode -> Mode -> Bool) -> Eq Mode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
/= :: Mode -> Mode -> Bool
Eq)

build :: Mode -> Int64 -> Int64 -> Doc
  -> (Int64 -> Int64 -> SimpleDoc )
  -> SimpleDoc
build :: Mode
-> Int64
-> Int64
-> Doc
-> (Int64 -> Int64 -> SimpleDoc)
-> SimpleDoc
build !Mode
mode !Int64
start !Int64
current !Doc
d Int64 -> Int64 -> SimpleDoc
k = case Doc
d of
  Doc
Empty ->
    Int64 -> Int64 -> SimpleDoc
k Int64
start Int64
current
  Item {} ->
    Int64 -> Builder -> SimpleDoc -> SimpleDoc
PP.SText (Doc -> Int64
actual_size Doc
d) (Doc -> Builder
text Doc
d)
      (SimpleDoc -> SimpleDoc) -> SimpleDoc -> SimpleDoc
forall a b. (a -> b) -> a -> b
$! Int64 -> Int64 -> SimpleDoc
k Int64
start (Int64
current Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Doc -> Int64
actual_size Doc
d)
  Doc
Break -> case Mode
mode of
    Mode
Flat -> Int64 -> Int64 -> SimpleDoc
k Int64
start Int64
current
    Mode
Full -> Int64 -> SimpleDoc -> SimpleDoc
crlftab Int64
start (SimpleDoc -> SimpleDoc) -> SimpleDoc -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> SimpleDoc
k Int64
start Int64
start
  Doc
Line -> case Mode
mode of
    Mode
Flat -> Char -> SimpleDoc -> SimpleDoc
PP.SChar Char
' ' (SimpleDoc -> SimpleDoc) -> SimpleDoc -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> SimpleDoc
k Int64
start (Int64
current Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
1)
    Mode
Full -> Int64 -> SimpleDoc -> SimpleDoc
crlftab Int64
start (SimpleDoc -> SimpleDoc) -> SimpleDoc -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> SimpleDoc
k Int64
start Int64
start
  Doc
Skip -> case Mode
mode of
    Mode
Flat -> Int64 -> Int64 -> SimpleDoc
k Int64
start Int64
current
    Mode
Full ->
      if Int64
current Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
start
      then Int64 -> SimpleDoc -> SimpleDoc
spaces (Int64
start Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
current) (SimpleDoc -> SimpleDoc) -> SimpleDoc -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> SimpleDoc
k Int64
start Int64
start
      else Int64 -> SimpleDoc -> SimpleDoc
crlftab Int64
start            (SimpleDoc -> SimpleDoc) -> SimpleDoc -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64 -> SimpleDoc
k Int64
start Int64
start
  Cat {} ->
    Mode
-> Int64
-> Int64
-> Doc
-> (Int64 -> Int64 -> SimpleDoc)
-> SimpleDoc
build Mode
mode Int64
start Int64
current (Doc -> Doc
left  Doc
d) ((Int64 -> Int64 -> SimpleDoc) -> SimpleDoc)
-> (Int64 -> Int64 -> SimpleDoc) -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ \ Int64
s Int64
c ->
    Mode
-> Int64
-> Int64
-> Doc
-> (Int64 -> Int64 -> SimpleDoc)
-> SimpleDoc
build Mode
mode    Int64
s     Int64
c       (Doc -> Doc
right Doc
d) Int64 -> Int64 -> SimpleDoc
k
  Nest {} -> 
    Mode
-> Int64
-> Int64
-> Doc
-> (Int64 -> Int64 -> SimpleDoc)
-> SimpleDoc
build Mode
mode (Int64
start Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Doc -> Int64
delta Doc
d) Int64
current (Doc -> Doc
contents Doc
d)
      ((Int64 -> Int64 -> SimpleDoc) -> SimpleDoc)
-> (Int64 -> Int64 -> SimpleDoc) -> SimpleDoc
forall a b. (a -> b) -> a -> b
$ \ Int64
s Int64
c ->  Int64 -> Int64 -> SimpleDoc
k (Int64
s Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Doc -> Int64
delta Doc
d) Int64
c
  Group {} ->
    if Mode
mode Mode -> Mode -> Bool
forall a. Eq a => a -> a -> Bool
== Mode
Flat
    then Mode
-> Int64
-> Int64
-> Doc
-> (Int64 -> Int64 -> SimpleDoc)
-> SimpleDoc
build Mode
Flat Int64
start Int64
current ( Doc -> Doc
contents Doc
d) Int64 -> Int64 -> SimpleDoc
k
    else 
      Mode
-> Int64
-> Int64
-> Doc
-> (Int64 -> Int64 -> SimpleDoc)
-> SimpleDoc
build (if Int64 -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
current Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Doc -> Size
size Doc
d Size -> Size -> Bool
forall a. Ord a => a -> a -> Bool
< Int64 -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral  Int64
line_width
             then Mode
Flat else Mode
Full)
        Int64
start Int64
current ( Doc -> Doc
contents Doc
d) Int64 -> Int64 -> SimpleDoc
k

{-# inline spaces #-}
spaces :: Int64 -> SimpleDoc -> SimpleDoc
spaces !Int64
s SimpleDoc
sd =
  Int64 -> Builder -> SimpleDoc -> SimpleDoc
PP.SText Int64
s
    (Text -> Builder
B.fromLazyText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ Int64 -> Text -> Text
L.replicate Int64
s (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Char -> Text
L.singleton Char
' ') SimpleDoc
sd

{-# inline crlftab #-}
crlftab :: Int64 -> SimpleDoc -> SimpleDoc
crlftab !Int64
s SimpleDoc
sd =
  Int64 -> SimpleDoc -> SimpleDoc
PP.SLine Int64
s SimpleDoc
sd

{-# inline textLazy #-}
textLazy :: L.Text -> Doc
textLazy :: Text -> Doc
textLazy !Text
t = 
  Size -> Int64 -> Builder -> Doc
Item (Int64 -> Size
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Size) -> Int64 -> Size
forall a b. (a -> b) -> a -> b
$ Text -> Int64
L.length Text
t) (Text -> Int64
L.length Text
t) (Text -> Builder
B.fromLazyText Text
t)
  
{-# inline textStrict #-}
textStrict :: T.Text -> Doc
textStrict :: Text -> Doc
textStrict  = Text -> Doc
textLazy (Text -> Doc) -> (Text -> Text) -> Text -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
L.fromStrict

instance Semigroup Doc where
  -- computation of size is lazy for large arguments (we hope)
  Doc
l <> :: Doc -> Doc -> Doc
<> Doc
r = Size -> Doc -> Doc -> Doc
Cat (Doc -> Size
size Doc
l Size -> Size -> Size
forall a. Num a => a -> a -> a
+ Doc -> Size
size Doc
r) Doc
l Doc
r
instance Monoid Doc where
  mempty :: Doc
mempty = Doc
empty
instance IsString Doc where
  fromString :: String -> Doc
fromString = Text -> Doc
textStrict (Text -> Doc) -> (String -> Text) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

parens :: Doc -> Doc
parens :: Doc -> Doc
parens Doc
x = Doc
"(" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
")"
brackets :: Doc -> Doc
brackets :: Doc -> Doc
brackets Doc
x = Doc
"[" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"]"
braces :: Doc -> Doc
braces :: Doc -> Doc
braces Doc
x = Doc
"{" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"}"
dquotes :: Doc -> Doc
dquotes :: Doc -> Doc
dquotes Doc
x = Doc
"\"" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\""

empty :: Doc
empty = Doc
Empty
comma :: Doc
comma = Doc
"," :: Doc
colon :: Doc
colon = Doc
":" :: Doc
semi :: Doc
semi = Doc
";" :: Doc
equals :: Doc
equals = Doc
"=" :: Doc
char :: Char -> a
char Char
c = String -> a
forall a. IsString a => String -> a
fromString [ Char
c ]

encloseSep :: a -> a -> a -> a
encloseSep a
op a
cl a
x = a
op a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
cl

break :: Doc
break = Doc
Break
line :: Doc
line = Doc
Line
skip :: Doc
skip = Doc
Skip

softline :: Doc
softline = Doc
line
softbreak :: Doc
softbreak = Doc
break
linebreak :: Doc
linebreak = Doc
line

-- | concatenate with separating space
(<+>) :: Doc -> Doc -> Doc
Doc
x <+> :: Doc -> Doc -> Doc
<+> Doc
y = Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
" " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
y

-- | concatenate with line break or (flat layout) no space
(<$$>) :: Doc -> Doc -> Doc
Doc
x <$$> :: Doc -> Doc -> Doc
<$$> Doc
y = Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
break Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
y

-- | concatenate with line break or (flat layout) separating space
(<//>) :: Doc -> Doc -> Doc
Doc
x <//> :: Doc -> Doc -> Doc
<//> Doc
y = Doc
x Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
line  Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
y

cat :: [Doc] -> Doc
cat :: [Doc] -> Doc
cat [] = Doc
forall a. Monoid a => a
mempty
cat [Doc]
xs = (Doc -> Doc -> Doc) -> [Doc] -> Doc
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
(<>) [Doc]
xs

-- | concatenate horizontally (no separating space)
hcat :: [Doc] -> Doc
hcat = [Doc] -> Doc
cat

-- | concatenate vertically. in flat layout, concatenate horizontally (no separating space)
vcat :: [Doc] -> Doc
vcat :: [Doc] -> Doc
vcat [] = Doc
forall a. Monoid a => a
mempty
vcat [Doc]
xs = (Doc -> Doc -> Doc) -> [Doc] -> Doc
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Doc -> Doc -> Doc
(<$$>) [Doc]
xs

-- | concatenate horizontally (with separating space)
sep :: [Doc] -> Doc
sep :: [Doc] -> Doc
sep [] = Doc
forall a. Monoid a => a
mempty
sep [Doc]
xs = (Doc -> Doc -> Doc) -> [Doc] -> Doc
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Doc -> Doc -> Doc
(<+>) [Doc]
xs

-- | concatenate horizontally (with separating space)
hsep :: [Doc] -> Doc
hsep :: [Doc] -> Doc
hsep = [Doc] -> Doc
sep

-- | concatenate vertically. in flat layout, concatenate horizontally (with separating space)
vsep :: [Doc] -> Doc
vsep :: [Doc] -> Doc
vsep [] = Doc
forall a. Monoid a => a
mempty
vsep [Doc]
xs = (Doc -> Doc -> Doc) -> [Doc] -> Doc
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Doc -> Doc -> Doc
(<//>) [Doc]
xs

fillSep :: [Doc] -> Doc
fillSep :: [Doc] -> Doc
fillSep = [Doc] -> Doc
hsep

fill :: p -> a -> a
fill p
i = a -> a
forall a. a -> a
id
fillBreak :: p -> a -> a
fillBreak p
i = a -> a
forall a. a -> a
id

group :: Doc -> Doc
group Doc
c = Group
  { _size :: Size
_size = Doc -> Size
size Doc
c, contents :: Doc
contents = Doc
c }
nest :: a -> Doc -> Doc
nest a
d Doc
c = Nest
  { _size :: Size
_size = Doc -> Size
size Doc
c, delta :: Int64
delta = a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
d, contents :: Doc
contents = Doc
c }
indent :: Integer -> Doc -> Doc
indent = Integer -> Doc -> Doc
forall b. Integral b => b -> Doc -> Doc
nest

align :: a -> a
align = a -> a
forall a. a -> a
id

int :: Int -> Doc
int :: Int -> Doc
int = String -> Doc
forall a. IsString a => String -> a
fromString (String -> Doc) -> (Int -> String) -> Int -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show

integer :: Integer -> Doc
integer :: Integer -> Doc
integer = String -> Doc
forall a. IsString a => String -> a
fromString (String -> Doc) -> (Integer -> String) -> Integer -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show

float :: Float -> Doc
float :: Float -> Doc
float = String -> Doc
forall a. IsString a => String -> a
fromString (String -> Doc) -> (Float -> String) -> Float -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> String
forall a. Show a => a -> String
show

double :: Double -> Doc
double :: Double -> Doc
double = String -> Doc
forall a. IsString a => String -> a
fromString (String -> Doc) -> (Double -> String) -> Double -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show