ref: 35ff6ea8bf0f2131b70ff44d2fefa683ce3aab3c
parent: 9ddedca6c919515788d006a0b11a3f1e6564adb3
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Sat Feb 17 09:22:18 EST 2024
Add Pretty class.
--- a/lib/Text/PrettyPrint/HughesPJ.hs
+++ b/lib/Text/PrettyPrint/HughesPJ.hs
@@ -9,6 +9,7 @@
hcat, hsep,
vcat,
sep, cat,
+ fsep, fcat,
nest, hang,
punctuate,
parens, brackets, braces,
@@ -79,7 +80,6 @@
-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
mkNest :: Int -> Doc -> Doc
-mkNest k _ | k `seq` False = undefined
mkNest k (Nest k1 p) = mkNest (k + k1) p
mkNest _ NoDoc = NoDoc
mkNest _ Empty = Empty
@@ -366,3 +366,64 @@
fits _ (NilAbove _) = True
fits n (TextBeside s p) = fits (n - length s) p
fits _ _ = error "fits"
+
+---------
+
+fcat :: [Doc] -> Doc
+fcat = fill False
+
+fsep :: [Doc] -> Doc
+fsep = fill True
+
+-- Specification:
+--
+-- fill g docs = fillIndent 0 docs
+--
+-- fillIndent k [] = []
+-- fillIndent k [p] = p
+-- fillIndent k (p1:p2:ps) =
+-- oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0)
+-- (remove_nests (oneLiner p2) : ps)
+-- `Union`
+-- (p1 $*$ nest (-k) (fillIndent 0 ps))
+--
+-- $*$ is defined for layouts (not Docs) as
+-- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2
+-- | otherwise = layout1 $+$ layout2
+
+fill :: Bool -> [Doc] -> RDoc
+fill _ [] = empty
+fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
+
+fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
+fill1 _ _ k _ | k `seq` False = undefined
+fill1 _ NoDoc _ _ = NoDoc
+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 p) k ys = textBeside_ s (fillNB g p k ys)
+fill1 _ (Above _ _ _) _ _ = error "fill1 Above"
+fill1 _ (Beside _ _ _) _ _ = error "fill1 Beside"
+
+fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
+fillNB _ _ k _ | k `seq` False = undefined
+fillNB g (Nest _ p) k ys = fillNB g p k ys
+ -- Never triggered, because of invariant (2)
+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 -> Doc -> [Doc] -> Doc
+fillNBE g k y ys
+ = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys)
+ -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
+ `mkUnion` nilAboveNest False k (fill g (y:ys))
+ where k' = if g then k - 1 else k
+
+elideNest :: Doc -> Doc
+elideNest (Nest _ d) = d
+elideNest d = d
--- /dev/null
+++ b/lib/Text/PrettyPrint/HughesPJClass.hs
@@ -1,0 +1,133 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Text.PrettyPrint.HughesPJClass
+-- Copyright : (c) Lennart Augustsson 2014
+-- License : BSD-style (see the file LICENSE)
+--
+-- Maintainer : David Terei <code@davidterei.com>
+-- Stability : stable
+-- Portability : portable
+--
+-- Pretty printing class, simlar to 'Show' but nicer looking.
+--
+-- Note that the precedence level is a 'Rational' so there is an unlimited
+-- number of levels. This module re-exports 'Text.PrettyPrint.HughesPJ'.
+--
+-----------------------------------------------------------------------------
+
+module Text.PrettyPrint.HughesPJClass (
+ -- * Pretty typeclass
+ Pretty(..),
+
+ PrettyLevel(..), prettyNormal,
+ prettyShow,
+
+ -- re-export HughesPJ
+ module Text.PrettyPrint.HughesPJ
+ ) where
+
+import Text.PrettyPrint.HughesPJ
+
+-- | Level of detail in the pretty printed output. Level 0 is the least
+-- detail.
+newtype PrettyLevel = PrettyLevel Int
+ deriving (Eq, Ord, Show)
+
+-- | The "normal" (Level 0) of detail.
+prettyNormal :: PrettyLevel
+prettyNormal = PrettyLevel 0
+
+-- | Pretty printing class. The precedence level is used in a similar way as in
+-- the 'Show' class. Minimal complete definition is either 'pPrintPrec' or
+-- 'pPrint'.
+class Pretty a where
+ pPrintPrec :: PrettyLevel -> Rational -> a -> Doc
+ pPrintPrec _ _ = pPrint
+
+ pPrint :: a -> Doc
+ pPrint = pPrintPrec prettyNormal 0
+
+ pPrintList :: PrettyLevel -> [a] -> Doc
+ pPrintList l = brackets . fsep . punctuate comma . map (pPrintPrec l 0)
+
+-- | Pretty print a value with the 'prettyNormal' level.
+prettyShow :: (Pretty a) => a -> String
+prettyShow = render . pPrint
+
+pPrint0 :: (Pretty a) => PrettyLevel -> a -> Doc
+pPrint0 l = pPrintPrec l 0
+
+appPrec :: Rational
+appPrec = 10
+
+comma :: Doc
+comma = text ","
+
+-- Various Pretty instances
+instance Pretty Int where pPrint = text . show
+
+instance Pretty Integer where pPrint = text . show
+
+instance Pretty Double where pPrint = text . show
+
+instance Pretty () where pPrint _ = text "()"
+
+instance Pretty Bool where pPrint = text . show
+
+instance Pretty Ordering where pPrint = text . show
+
+instance Pretty Char where
+ pPrint = text . show
+ pPrintList _ = text . show
+
+instance (Pretty a) => Pretty (Maybe a) where
+ pPrintPrec _ _ Nothing = text "Nothing"
+ pPrintPrec l p (Just x) =
+ maybeParens (p > appPrec) $ text "Just" <+> pPrintPrec l (appPrec+1) x
+
+instance (Pretty a, Pretty b) => Pretty (Either a b) where
+ pPrintPrec l p (Left x) =
+ maybeParens (p > appPrec) $ text "Left" <+> pPrintPrec l (appPrec+1) x
+ pPrintPrec l p (Right x) =
+ maybeParens (p > appPrec) $ text "Right" <+> pPrintPrec l (appPrec+1) x
+
+instance (Pretty a) => Pretty [a] where
+ pPrintPrec l _ = pPrintList l
+
+instance (Pretty a, Pretty b) => Pretty (a, b) where
+ pPrintPrec l _ (a, b) =
+ parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b]
+
+instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where
+ pPrintPrec l _ (a, b, c) =
+ parens $ fsep $ punctuate comma [pPrint0 l a, pPrint0 l b, pPrint0 l c]
+
+instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where
+ pPrintPrec l _ (a, b, c, d) =
+ parens $ fsep $ punctuate comma
+ [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d]
+
+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e) => Pretty (a, b, c, d, e) where
+ pPrintPrec l _ (a, b, c, d, e) =
+ parens $ fsep $ punctuate comma
+ [pPrint0 l a, pPrint0 l b, pPrint0 l c, pPrint0 l d, pPrint0 l e]
+
+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f) => Pretty (a, b, c, d, e, f) where
+ pPrintPrec l _ (a, b, c, d, e, f) =
+ parens $ fsep $ punctuate comma
+ [pPrint0 l a, pPrint0 l b, pPrint0 l c,
+ pPrint0 l d, pPrint0 l e, pPrint0 l f]
+
+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g) =>
+ Pretty (a, b, c, d, e, f, g) where
+ pPrintPrec l _ (a, b, c, d, e, f, g) =
+ parens $ fsep $ punctuate comma
+ [pPrint0 l a, pPrint0 l b, pPrint0 l c,
+ pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g]
+
+instance (Pretty a, Pretty b, Pretty c, Pretty d, Pretty e, Pretty f, Pretty g, Pretty h) =>
+ Pretty (a, b, c, d, e, f, g, h) where
+ pPrintPrec l _ (a, b, c, d, e, f, g, h) =
+ parens $ fsep $ punctuate comma
+ [pPrint0 l a, pPrint0 l b, pPrint0 l c,
+ pPrint0 l d, pPrint0 l e, pPrint0 l f, pPrint0 l g, pPrint0 l h]
--
⑨