module Text.Pretty (
Pretty(..),
Printer,
char, string, sizedText, zeroWidthText,
int, integer, float, double, rational,
empty,
(<->), (<+>), hcat, hsep,
(</>), (<//>), vcat,
sep, cat,
fsep, fcat,
wrap, parens, brackets, braces, quotes, doubleQuotes,
nest,
hang,
sepBy, initBy, termBy,
sepByS, initByS, termByS,
isEmpty,
runPrinter,
Mode(..),
Style(..),
style,
runPrinterStyle
) where
import Data.Semigroup
import Data.Ratio ( Ratio, numerator, denominator )
import Data.String ( IsString(fromString) )
infixl 6 <->
infixl 6 <+>
infixl 5 </>, <//>
list :: b -> (a -> [a] -> b) -> [a] -> b
list z f [] = z
list z f (x:xs) = x `f` xs
class Pretty a where
pretty :: a -> Printer
prettyList :: [a] -> Printer
prettyList = brackets . sepBy (char ',') . map pretty
int :: Int -> Printer
integer :: Integer -> Printer
float :: Float -> Printer
double :: Double -> Printer
rational :: Rational -> Printer
char' :: Char -> Printer
string' :: String -> Printer
int = string . show
integer = string . show
float = string . show
double = string . show
rational = string . show
char' = string . show
string' = string . show
instance Pretty Printer where
pretty = id
instance Pretty () where
pretty = string . show
instance Pretty Int where
pretty = int
instance Pretty Float where
pretty = float
instance Pretty Double where
pretty = double
instance Pretty Char where
pretty = char'
prettyList = string'
instance Pretty Integer where
pretty = integer
instance (Pretty a, Pretty b) => Pretty (a,b) where
pretty (x, y) = parens $ pretty x `g` pretty y
where x `g` y = x <> char ',' <> y
instance Pretty a => Pretty [a] where
pretty x = prettyList x
instance Pretty a => Pretty (Maybe a) where
pretty = maybe empty pretty
instance (Pretty a, Integral a) => Pretty (Ratio a) where
pretty x = pretty (numerator x) <> string " % " <> pretty (denominator x)
data Printer
= Empty
| NilAbove Printer
| TextBeside TextDetails Int Printer
| Nest Int Printer
| Union Printer Printer
| NoPrinter
| Beside Printer Bool Printer
| Above Printer Bool Printer
type RPrinter a = Printer
data TextDetails = Chr Char
| Str String
instance Semigroup Printer where
(<>) = (<->)
instance Monoid Printer where
mempty = empty
mappend = (<->)
instance IsString Printer where
fromString = string
instance Show Printer where
showsPrec _ doc cont = runPrinter' (mode style) (lineLength style)
(ribbonsPerLine style)
txtPrinter cont doc
char :: Char -> Printer
char c = stringBeside_ (Chr c) 1 Empty
string :: String -> Printer
string s = case length s of {sl -> stringBeside_ (Str s) sl Empty}
sizedText :: Int -> String -> Printer
sizedText l s = stringBeside_ (Str s) l Empty
zeroWidthText :: String -> Printer
zeroWidthText = sizedText 0
empty :: Printer
empty = Empty
isEmpty :: Printer -> Bool
isEmpty Empty = True
isEmpty _ = False
indent :: Int -> String
indent !n = replicate n ' '
space_string, nl_string :: TextDetails
space_string = Chr ' '
nl_string = Chr '\n'
wrap :: Char -> Char -> Printer -> Printer
wrap s t p = char s <> p <> char t
parens :: Printer -> Printer
brackets :: Printer -> Printer
braces :: Printer -> Printer
quotes :: Printer -> Printer
doubleQuotes :: Printer -> Printer
quotes = wrap '\'' '\''
doubleQuotes = wrap '"' '"'
parens = wrap '(' ')'
brackets = wrap '[' ']'
braces = wrap '{' '}'
reducePrinter :: Printer -> RPrinter a
reducePrinter (Beside p g q) = beside p g (reducePrinter q)
reducePrinter (Above p g q) = above p g (reducePrinter q)
reducePrinter p = p
hcat :: [Printer] -> Printer
hcat = reduceAB . foldr (beside_' False) empty
hsep :: [Printer] -> Printer
hsep = reduceAB . foldr (beside_' True) empty
vcat :: [Printer] -> Printer
vcat = reduceAB . foldr (above_' False) empty
nest :: Int -> Printer -> Printer
nest k p = mkNest k (reducePrinter p)
hang :: Printer -> Int -> Printer -> Printer
hang d1 n d2 = sep [d1, nest n d2]
mkNest :: Int -> Printer -> Printer
mkNest k _ | k `seq` False = undefined
mkNest k (Nest k1 p) = mkNest (k + k1) p
mkNest _ NoPrinter = NoPrinter
mkNest _ Empty = Empty
mkNest 0 p = p
mkNest k p = nest_ k p
mkUnion :: Printer -> Printer -> Printer
mkUnion Empty _ = Empty
mkUnion p q = p `union_` q
beside_' :: Bool -> Printer -> Printer -> Printer
beside_' _ p Empty = p
beside_' g p q = Beside p g q
above_' :: Bool -> Printer -> Printer -> Printer
above_' _ p Empty = p
above_' g p q = Above p g q
reduceAB :: Printer -> Printer
reduceAB (Above Empty _ q) = q
reduceAB (Beside Empty _ q) = q
reduceAB doc = doc
nilAbove_ :: RPrinter a -> RPrinter a
nilAbove_ p = NilAbove p
stringBeside_ :: TextDetails -> Int -> RPrinter a -> RPrinter a
stringBeside_ s sl p = TextBeside s sl p
nest_ :: Int -> RPrinter a -> RPrinter a
nest_ k p = Nest k p
union_ :: RPrinter a -> RPrinter a -> RPrinter a
union_ p q = Union p q
(</>) :: Printer -> Printer -> Printer
p </> q = above_ p False q
(<//>) :: Printer -> Printer -> Printer
p <//> q = above_ p True q
above_ :: Printer -> Bool -> Printer -> Printer
above_ p _ Empty = p
above_ Empty _ q = q
above_ p g q = Above p g q
above :: Printer -> Bool -> RPrinter a -> RPrinter a
above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
above p@(Beside _ _ _) g q = aboveNest (reducePrinter p) g 0 (reducePrinter q)
above p g q = aboveNest p g 0 (reducePrinter q)
aboveNest :: RPrinter a -> Bool -> Int -> RPrinter a -> RPrinter a
aboveNest _ _ k _ | k `seq` False = undefined
aboveNest NoPrinter _ _ _ = NoPrinter
aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
aboveNest p2 g k q
aboveNest Empty _ k q = mkNest k q
aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k k1) q)
aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
aboveNest (TextBeside s sl p) g k q = stringBeside_ s sl rest
where
!k1 = k sl
rest = case p of
Empty -> nilAboveNest g k1 q
_ -> aboveNest p g k1 q
aboveNest (Above {}) _ _ _ = error "aboveNest Above"
aboveNest (Beside {}) _ _ _ = error "aboveNest Beside"
nilAboveNest :: Bool -> Int -> RPrinter a -> RPrinter a
nilAboveNest _ k _ | k `seq` False = undefined
nilAboveNest _ _ Empty = Empty
nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
nilAboveNest g k q | not g && k > 0
= stringBeside_ (Str (indent k)) k q
| otherwise
= nilAbove_ (mkNest k q)
(<->) :: Printer -> Printer -> Printer
p <-> q = beside_ p False q
(<+>) :: Printer -> Printer -> Printer
p <+> q = beside_ p True q
beside_ :: Printer -> Bool -> Printer -> Printer
beside_ p _ Empty = p
beside_ Empty _ q = q
beside_ p g q = Beside p g q
beside :: Printer -> Bool -> RPrinter a -> RPrinter a
beside NoPrinter _ _ = NoPrinter
beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q
beside Empty _ q = q
beside (Nest k p) g q = nest_ k $! beside p g q
beside p@(Beside p1 g1 q1) g2 q2
| g1 == g2 = beside p1 g1 $! beside q1 g2 q2
| otherwise = beside (reducePrinter p) g2 q2
beside p@(Above _ _ _) g q = let !d = reducePrinter p in beside d g q
beside (NilAbove p) g q = nilAbove_ $! beside p g q
beside (TextBeside s sl p) g q = stringBeside_ s sl $! rest
where
rest = case p of
Empty -> nilBeside g q
_ -> beside p g q
nilBeside :: Bool -> RPrinter a -> RPrinter a
nilBeside _ Empty = Empty
nilBeside g (Nest _ p) = nilBeside g p
nilBeside g p | g = stringBeside_ space_string 1 p
| otherwise = p
sep :: [Printer] -> Printer
sep = sepX True
cat :: [Printer] -> Printer
cat = sepX False
sepX :: Bool -> [Printer] -> Printer
sepX _ [] = empty
sepX x (p:ps) = sep1 x (reducePrinter p) 0 ps
sep1 :: Bool -> RPrinter a -> Int -> [Printer] -> RPrinter a
sep1 _ _ k _ | k `seq` False = undefined
sep1 _ NoPrinter _ _ = NoPrinter
sep1 g (p `Union` q) k ys = sep1 g p k ys `union_`
aboveNest q False k (reducePrinter (vcat ys))
sep1 g Empty k ys = mkNest k (sepX g ys)
sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k n) ys)
sep1 _ (NilAbove p) k ys = nilAbove_
(aboveNest p False k (reducePrinter (vcat ys)))
sep1 g (TextBeside s sl p) k ys = stringBeside_ s sl (sepNB g p (k sl) ys)
sep1 _ (Above {}) _ _ = error "sep1 Above"
sep1 _ (Beside {}) _ _ = error "sep1 Beside"
sepNB :: Bool -> Printer -> Int -> [Printer] -> Printer
sepNB g (Nest _ p) k ys
= sepNB g p k ys
sepNB g Empty k ys
= oneLiner (nilBeside g (reducePrinter rest)) `mkUnion`
nilAboveNest False k (reducePrinter (vcat ys))
where
rest | g = hsep ys
| otherwise = hcat ys
sepNB g p k ys
= sep1 g p k ys
fcat :: [Printer] -> Printer
fcat = fill False
fsep :: [Printer] -> Printer
fsep = fill True
fill :: Bool -> [Printer] -> RPrinter a
fill _ [] = empty
fill g (p:ps) = fill1 g (reducePrinter p) 0 ps
fill1 :: Bool -> RPrinter a -> Int -> [Printer] -> Printer
fill1 _ _ k _ | k `seq` False = undefined
fill1 _ NoPrinter _ _ = NoPrinter
fill1 g (p `Union` q) k ys = fill1 g p k ys `union_`
aboveNest q False k (fill g ys)
fill1 g Empty k ys = mkNest k (fill g ys)
fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k n) ys)
fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
fill1 g (TextBeside s sl p) k ys = stringBeside_ s sl (fillNB g p (k sl) ys)
fill1 _ (Above {}) _ _ = error "fill1 Above"
fill1 _ (Beside {}) _ _ = error "fill1 Beside"
fillNB :: Bool -> Printer -> Int -> [Printer] -> Printer
fillNB _ _ k _ | k `seq` False = undefined
fillNB g (Nest _ p) k ys = fillNB g p k ys
fillNB _ Empty _ [] = Empty
fillNB g Empty k (Empty:ys) = fillNB g Empty k ys
fillNB g Empty k (y:ys) = fillNBE g k y ys
fillNB g p k ys = fill1 g p k ys
fillNBE :: Bool -> Int -> Printer -> [Printer] -> Printer
fillNBE g k y ys
= nilBeside g (fill1 g ((elideNest . oneLiner . reducePrinter) y) k' ys)
`mkUnion` nilAboveNest False k (fill g (y:ys))
where k' = if g then k 1 else k
elideNest :: Printer -> Printer
elideNest (Nest _ d) = d
elideNest d = d
sepBy :: Printer -> [Printer] -> Printer
initBy :: Printer -> [Printer] -> Printer
termBy :: Printer -> [Printer] -> Printer
sepBy p = list empty $ \x -> (x <>) . initBy p
initBy p = hcat . map (p <>)
termBy p = hcat . map (<> p)
sepByS :: Printer -> [Printer] -> Printer
initByS :: Printer -> [Printer] -> Printer
termByS :: Printer -> [Printer] -> Printer
sepByS p = list empty $ \x -> (x <>) . initByS p
initByS p = hcat . map (p <+>)
termByS p = hsep . map (<> p)
best :: Int
-> Int
-> RPrinter a
-> RPrinter a
best w0 r p0
= get w0 p0
where
get w _ | w == 0 && False = undefined
get _ Empty = Empty
get _ NoPrinter = NoPrinter
get w (NilAbove p) = nilAbove_ (get w p)
get w (TextBeside s sl p) = stringBeside_ s sl (get1 w sl p)
get w (Nest k p) = nest_ k (get (w k) p)
get w (p `Union` q) = nicest w r (get w p) (get w q)
get _ (Above {}) = error "best get Above"
get _ (Beside {}) = error "best get Beside"
get1 w _ _ | w == 0 && False = undefined
get1 _ _ Empty = Empty
get1 _ _ NoPrinter = NoPrinter
get1 w sl (NilAbove p) = nilAbove_ (get (w sl) p)
get1 w sl (TextBeside t tl p) = stringBeside_ t tl (get1 w (sl + tl) p)
get1 w sl (Nest _ p) = get1 w sl p
get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
(get1 w sl q)
get1 _ _ (Above {}) = error "best get1 Above"
get1 _ _ (Beside {}) = error "best get1 Beside"
nicest :: Int -> Int -> Printer -> Printer -> Printer
nicest !w !r p q = nicest1 w r 0 p q
nicest1 :: Int -> Int -> Int -> Printer -> Printer -> Printer
nicest1 !w !r !sl p q | fits ((w `min` r) sl) p = p
| otherwise = q
fits :: Int
-> Printer
-> Bool
fits n _ | n < 0 = False
fits _ NoPrinter = False
fits _ Empty = True
fits _ (NilAbove _) = True
fits n (TextBeside _ sl p) = fits (n sl) p
fits _ (Above {}) = error "fits Above"
fits _ (Beside {}) = error "fits Beside"
fits _ (Union {}) = error "fits Union"
fits _ (Nest {}) = error "fits Nest"
first :: Printer -> Printer -> Printer
first p q | nonEmptySet p = p
| otherwise = q
nonEmptySet :: Printer -> Bool
nonEmptySet NoPrinter = False
nonEmptySet (_ `Union` _) = True
nonEmptySet Empty = True
nonEmptySet (NilAbove _) = True
nonEmptySet (TextBeside _ _ p) = nonEmptySet p
nonEmptySet (Nest _ p) = nonEmptySet p
nonEmptySet (Above {}) = error "nonEmptySet Above"
nonEmptySet (Beside {}) = error "nonEmptySet Beside"
oneLiner :: Printer -> Printer
oneLiner NoPrinter = NoPrinter
oneLiner Empty = Empty
oneLiner (NilAbove _) = NoPrinter
oneLiner (TextBeside s sl p) = stringBeside_ s sl (oneLiner p)
oneLiner (Nest k p) = nest_ k (oneLiner p)
oneLiner (p `Union` _) = oneLiner p
oneLiner (Above {}) = error "oneLiner Above"
oneLiner (Beside {}) = error "oneLiner Beside"
data Style
= Style { mode :: Mode
, lineLength :: Int
, ribbonsPerLine :: Float
}
style :: Style
style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }
data Mode = PageMode
| ZigZagMode
| LeftMode
| OneLineMode
runPrinter :: Printer -> String
runPrinter doc = runPrinter' (mode style) (lineLength style) (ribbonsPerLine style)
txtPrinter "" doc
runPrinterStyle :: Style -> Printer -> String
runPrinterStyle s doc = runPrinter' (mode s) (lineLength s) (ribbonsPerLine s)
txtPrinter "" doc
txtPrinter :: TextDetails -> String -> String
txtPrinter (Chr c) s = c:s
txtPrinter (Str s1) s2 = s1 ++ s2
runPrinter' :: Mode
-> Int
-> Float
-> (TextDetails -> a -> a)
-> a
-> Printer
-> a
runPrinter' OneLineMode _ _ txt end doc
= easy_display space_string (\_ y -> y) txt end (reducePrinter doc)
runPrinter' LeftMode _ _ txt end doc
= easy_display nl_string first txt end (reducePrinter doc)
runPrinter' m lineLen ribbons txt rest doc
= display m lineLen ribbonLen txt rest doc'
where
doc' = best bestLineLen ribbonLen (reducePrinter doc)
bestLineLen, ribbonLen :: Int
ribbonLen = round (fromIntegral lineLen / ribbons)
bestLineLen = case m of
ZigZagMode -> maxBound
_ -> lineLen
easy_display :: TextDetails
-> (Printer -> Printer -> Printer)
-> (TextDetails -> a -> a)
-> a
-> Printer
-> a
easy_display nl_space_string choose txt end doc
= lay doc
where
lay NoPrinter = error "easy_display: NoPrinter"
lay (Union p q) = lay (choose p q)
lay (Nest _ p) = lay p
lay Empty = end
lay (NilAbove p) = nl_space_string `txt` lay p
lay (TextBeside s _ p) = s `txt` lay p
lay (Above {}) = error "easy_display Above"
lay (Beside {}) = error "easy_display Beside"
display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Printer -> a
display m !page_width !ribbon_width txt end doc
= case page_width ribbon_width of { gap_width ->
case gap_width `quot` 2 of { shift ->
let
lay k _ | k `seq` False = undefined
lay k (Nest k1 p) = lay (k + k1) p
lay _ Empty = end
lay k (NilAbove p) = nl_string `txt` lay k p
lay k (TextBeside s sl p)
= case m of
ZigZagMode | k >= gap_width
-> nl_string `txt` (
Str (replicate shift '/') `txt` (
nl_string `txt`
lay1 (k shift) s sl p ))
| k < 0
-> nl_string `txt` (
Str (replicate shift '\\') `txt` (
nl_string `txt`
lay1 (k + shift) s sl p ))
_ -> lay1 k s sl p
lay _ (Above {}) = error "display lay Above"
lay _ (Beside {}) = error "display lay Beside"
lay _ NoPrinter = error "display lay NoPrinter"
lay _ (Union {}) = error "display lay Union"
lay1 !k s !sl p = let !r = k + sl
in Str (indent k) `txt` (s `txt` lay2 r p)
lay2 k _ | k `seq` False = undefined
lay2 k (NilAbove p) = nl_string `txt` lay k p
lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p
lay2 k (Nest _ p) = lay2 k p
lay2 _ Empty = end
lay2 _ (Above {}) = error "display lay2 Above"
lay2 _ (Beside {}) = error "display lay2 Beside"
lay2 _ NoPrinter = error "display lay2 NoPrinter"
lay2 _ (Union {}) = error "display lay2 Union"
in
lay 0 doc
}}