diff options
Diffstat (limited to 'compiler/GHC/Utils/Outputable.hs')
| -rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 540 |
1 files changed, 424 insertions, 116 deletions
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index d7300242bd..87bfd89909 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -5,6 +5,8 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE FlexibleContexts #-} {- (c) The University of Glasgow 2006-2012 @@ -21,15 +23,17 @@ module GHC.Utils.Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), OutputableP(..), + IsOutput(..), IsLine(..), IsDoc(..), + HLine, HDoc, + -- * Pretty printing combinators SDoc, runSDoc, PDoc(..), docToSDoc, interppSP, interpp'SP, interpp'SP', pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, pprWithBars, - empty, isEmpty, nest, - char, - text, ftext, ptext, ztext, + isEmpty, nest, + ptext, int, intWithCommas, integer, word, float, double, rational, doublePrec, parens, cparen, brackets, braces, quotes, quote, doubleQuotes, angleBrackets, @@ -38,10 +42,8 @@ module GHC.Utils.Outputable ( lambda, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, blankLine, forAllLit, bullet, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, + ($+$), + cat, fcat, hang, hangNotEmpty, punctuate, ppWhen, ppUnless, ppWhenOption, ppUnlessOption, speakNth, speakN, speakNOf, plural, singular, @@ -104,6 +106,7 @@ module GHC.Utils.Outputable ( ifPprDebug, whenPprDebug, getPprDebug, + bPutHDoc ) where import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) @@ -113,7 +116,7 @@ import GHC.Prelude.Basic import {-# SOURCE #-} GHC.Unit.Types ( Unit, Module, moduleName ) import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) -import GHC.Utils.BufHandle (BufHandle) +import GHC.Utils.BufHandle (BufHandle, bPutChar, bPutStr, bPutFS, bPutFZS) import GHC.Data.FastString import qualified GHC.Utils.Ppr as Pretty import qualified GHC.Utils.Ppr.Colour as Col @@ -548,17 +551,17 @@ userStyle (PprUser {}) = True userStyle _other = False -- | Indicate if -dppr-debug mode is enabled -getPprDebug :: (Bool -> SDoc) -> SDoc +getPprDebug :: IsOutput doc => (Bool -> doc) -> doc {-# INLINE CONLIKE getPprDebug #-} -getPprDebug d = sdocWithContext $ \ctx -> d (sdocPprDebug ctx) +getPprDebug d = docWithContext $ \ctx -> d (sdocPprDebug ctx) -- | Says what to do with and without -dppr-debug -ifPprDebug :: SDoc -> SDoc -> SDoc +ifPprDebug :: IsOutput doc => doc -> doc -> doc {-# INLINE CONLIKE ifPprDebug #-} ifPprDebug yes no = getPprDebug $ \dbg -> if dbg then yes else no -- | Says what to do with -dppr-debug; without, return empty -whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style +whenPprDebug :: IsOutput doc => doc -> doc -- Empty for non-debug style {-# INLINE CONLIKE whenPprDebug #-} whenPprDebug d = ifPprDebug d empty @@ -625,43 +628,26 @@ isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocPprDebug = True}) docToSDoc :: Doc -> SDoc docToSDoc d = SDoc (\_ -> d) -empty :: SDoc -char :: Char -> SDoc -text :: String -> SDoc -ftext :: FastString -> SDoc -ptext :: PtrString -> SDoc -ztext :: FastZString -> SDoc -int :: Int -> SDoc -integer :: Integer -> SDoc -word :: Integer -> SDoc -float :: Float -> SDoc -double :: Double -> SDoc -rational :: Rational -> SDoc - -{-# INLINE CONLIKE empty #-} -empty = docToSDoc $ Pretty.empty -{-# INLINE CONLIKE char #-} -char c = docToSDoc $ Pretty.char c - -{-# INLINE CONLIKE text #-} -- Inline so that the RULE Pretty.text will fire -text s = docToSDoc $ Pretty.text s - -{-# INLINE CONLIKE ftext #-} -ftext s = docToSDoc $ Pretty.ftext s +ptext :: PtrString -> SDoc +int :: IsLine doc => Int -> doc +integer :: IsLine doc => Integer -> doc +word :: Integer -> SDoc +float :: IsLine doc => Float -> doc +double :: IsLine doc => Double -> doc +rational :: Rational -> SDoc + {-# INLINE CONLIKE ptext #-} ptext s = docToSDoc $ Pretty.ptext s -{-# INLINE CONLIKE ztext #-} -ztext s = docToSDoc $ Pretty.ztext s {-# INLINE CONLIKE int #-} -int n = docToSDoc $ Pretty.int n +int n = text $ show n {-# INLINE CONLIKE integer #-} -integer n = docToSDoc $ Pretty.integer n +integer n = text $ show n {-# INLINE CONLIKE float #-} -float n = docToSDoc $ Pretty.float n +float n = text $ show n {-# INLINE CONLIKE double #-} -double n = docToSDoc $ Pretty.double n +double n = text $ show n {-# INLINE CONLIKE rational #-} -rational n = docToSDoc $ Pretty.rational n +rational n = text $ show n -- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr {-# INLINE CONLIKE word #-} word n = sdocOption sdocHexWordLiterals $ \case @@ -673,19 +659,19 @@ word n = sdocOption sdocHexWordLiterals $ \case doublePrec :: Int -> Double -> SDoc doublePrec p n = text (showFFloat (Just p) n "") -parens, braces, brackets, quotes, quote, - doubleQuotes, angleBrackets :: SDoc -> SDoc +quotes, quote :: SDoc -> SDoc +parens, brackets, braces, doubleQuotes, angleBrackets :: IsLine doc => doc -> doc {-# INLINE CONLIKE parens #-} -parens d = SDoc $ Pretty.parens . runSDoc d +parens d = char '(' <> d <> char ')' {-# INLINE CONLIKE braces #-} -braces d = SDoc $ Pretty.braces . runSDoc d +braces d = char '{' <> d <> char '}' {-# INLINE CONLIKE brackets #-} -brackets d = SDoc $ Pretty.brackets . runSDoc d +brackets d = char '[' <> d <> char ']' {-# INLINE CONLIKE quote #-} quote d = SDoc $ Pretty.quote . runSDoc d {-# INLINE CONLIKE doubleQuotes #-} -doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +doubleQuotes d = char '"' <> d <> char '"' {-# INLINE CONLIKE angleBrackets #-} angleBrackets d = char '<' <> d <> char '>' @@ -707,35 +693,37 @@ quotes d = sdocOption sdocCanUseUnicode $ \case _ | Just '\'' <- lastMaybe str -> pp_d | otherwise -> Pretty.quotes pp_d -semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc -arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc -lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc +blankLine, dcolon, arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, + larrowtt, lambda :: SDoc blankLine = docToSDoc Pretty.emptyText -dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::") -arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->") -lollipop = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "%1 ->") -larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-") -darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>") -arrowt = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-") -larrowt = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") -arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") -larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<") +dcolon = unicodeSyntax (char '∷') (text "::") +arrow = unicodeSyntax (char '→') (text "->") +lollipop = unicodeSyntax (char '⊸') (text "%1 ->") +larrow = unicodeSyntax (char '←') (text "<-") +darrow = unicodeSyntax (char '⇒') (text "=>") +arrowt = unicodeSyntax (char '⤚') (text ">-") +larrowt = unicodeSyntax (char '⤙') (text "-<") +arrowtt = unicodeSyntax (char '⤜') (text ">>-") +larrowtt = unicodeSyntax (char '⤛') (text "-<<") lambda = unicodeSyntax (char 'λ') (char '\\') -semi = docToSDoc $ Pretty.semi -comma = docToSDoc $ Pretty.comma -colon = docToSDoc $ Pretty.colon -equals = docToSDoc $ Pretty.equals -space = docToSDoc $ Pretty.space + +semi, comma, colon, equals, space, underscore, dot, vbar :: IsLine doc => doc +lparen, rparen, lbrack, rbrack, lbrace, rbrace :: IsLine doc => doc +semi = char ';' +comma = char ',' +colon = char ':' +equals = char '=' +space = char ' ' underscore = char '_' dot = char '.' vbar = char '|' -lparen = docToSDoc $ Pretty.lparen -rparen = docToSDoc $ Pretty.rparen -lbrack = docToSDoc $ Pretty.lbrack -rbrack = docToSDoc $ Pretty.rbrack -lbrace = docToSDoc $ Pretty.lbrace -rbrace = docToSDoc $ Pretty.rbrace +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' forAllLit :: SDoc forAllLit = unicodeSyntax (char '∀') (text "forall") @@ -758,38 +746,15 @@ unicode unicode plain = sdocOption sdocCanUseUnicode $ \case nest :: Int -> SDoc -> SDoc -- ^ Indent 'SDoc' some specified amount -(<>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally without a gap -(<+>) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together horizontally with a gap between them -($$) :: SDoc -> SDoc -> SDoc --- ^ Join two 'SDoc' together vertically; if there is --- no vertical overlap it "dovetails" the two onto one line ($+$) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically {-# INLINE CONLIKE nest #-} nest n d = SDoc $ Pretty.nest n . runSDoc d -{-# INLINE CONLIKE (<>) #-} -(<>) d1 d2 = SDoc $ \ctx -> (Pretty.<>) (runSDoc d1 ctx) (runSDoc d2 ctx) -{-# INLINE CONLIKE (<+>) #-} -(<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx) -{-# INLINE CONLIKE ($$) #-} -($$) d1 d2 = SDoc $ \ctx -> (Pretty.$$) (runSDoc d1 ctx) (runSDoc d2 ctx) {-# INLINE CONLIKE ($+$) #-} ($+$) d1 d2 = SDoc $ \ctx -> (Pretty.$+$) (runSDoc d1 ctx) (runSDoc d2 ctx) -hcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally -hsep :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' horizontally with a space between each one -vcat :: [SDoc] -> SDoc --- ^ Concatenate 'SDoc' vertically with dovetailing -sep :: [SDoc] -> SDoc --- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits cat :: [SDoc] -> SDoc --- ^ Concatenate: is either like 'hcat' or like 'vcat', depending on what fits -fsep :: [SDoc] -> SDoc -- ^ A paragraph-fill combinator. It's much like sep, only it -- keeps fitting things on one line until it can't fit any more. fcat :: [SDoc] -> SDoc @@ -799,18 +764,8 @@ fcat :: [SDoc] -> SDoc -- Inline all those wrappers to help ensure we create lists of Doc, not of SDoc -- later applied to the same SDocContext. It helps the worker/wrapper -- transformation extracting only the required fields from the SDocContext. -{-# INLINE CONLIKE hcat #-} -hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE hsep #-} -hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE vcat #-} -vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE sep #-} -sep ds = SDoc $ \ctx -> Pretty.sep [runSDoc d ctx | d <- ds] {-# INLINE CONLIKE cat #-} cat ds = SDoc $ \ctx -> Pretty.cat [runSDoc d ctx | d <- ds] -{-# INLINE CONLIKE fsep #-} -fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds] {-# INLINE CONLIKE fcat #-} fcat ds = SDoc $ \ctx -> Pretty.fcat [runSDoc d ctx | d <- ds] @@ -828,16 +783,17 @@ hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc hangNotEmpty d1 n d2 = SDoc $ \ctx -> Pretty.hangNotEmpty (runSDoc d1 ctx) n (runSDoc d2 ctx) -punctuate :: SDoc -- ^ The punctuation - -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements - -> [SDoc] -- ^ Punctuated list +punctuate :: IsLine doc + => doc -- ^ The punctuation + -> [doc] -- ^ The list that will have punctuation added between every adjacent pair of elements + -> [doc] -- ^ Punctuated list punctuate _ [] = [] punctuate p (d:ds) = go d ds where go d [] = [d] go d (e:es) = (d <> p) : go e es -ppWhen, ppUnless :: Bool -> SDoc -> SDoc +ppWhen, ppUnless :: IsOutput doc => Bool -> doc -> doc {-# INLINE CONLIKE ppWhen #-} ppWhen True doc = doc ppWhen False _ = empty @@ -853,10 +809,9 @@ ppWhenOption f doc = sdocOption f $ \case False -> empty {-# INLINE CONLIKE ppUnlessOption #-} -ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc -ppUnlessOption f doc = sdocOption f $ \case - True -> empty - False -> doc +ppUnlessOption :: IsLine doc => (SDocContext -> Bool) -> doc -> doc +ppUnlessOption f doc = docWithContext $ + \ctx -> if f ctx then empty else doc -- | Apply the given colour\/style for the argument. -- @@ -1028,12 +983,14 @@ instance Outputable Extension where instance Outputable ModuleName where ppr = pprModuleName -pprModuleName :: ModuleName -> SDoc +pprModuleName :: IsLine doc => ModuleName -> doc pprModuleName (ModuleName nm) = - getPprStyle $ \ sty -> - if codeStyle sty + docWithContext $ \ctx -> + if codeStyle (sdocStyle ctx) then ztext (zEncodeFS nm) else ftext nm +{-# SPECIALIZE pprModuleName :: ModuleName -> SDoc #-} +{-# SPECIALIZE pprModuleName :: ModuleName -> HLine #-} -- see Note [SPECIALIZE to HDoc] ----------------------------------------------------------------------- -- The @OutputableP@ class @@ -1301,12 +1258,14 @@ pprFastFilePath path = text $ normalise $ unpackFS path -- | Normalise, escape and render a string representing a path -- -- e.g. "c:\\whatever" -pprFilePathString :: FilePath -> SDoc +pprFilePathString :: IsLine doc => FilePath -> doc pprFilePathString path = doubleQuotes $ text (escape (normalise path)) where escape [] = [] escape ('\\':xs) = '\\':'\\':escape xs escape (x:xs) = x:escape xs +{-# SPECIALIZE pprFilePathString :: FilePath -> SDoc #-} +{-# SPECIALIZE pprFilePathString :: FilePath -> HLine #-} -- see Note [SPECIALIZE to HDoc] {- ************************************************************************ @@ -1485,3 +1444,352 @@ thisOrThese _ = text "These" hasOrHave :: [a] -> SDoc hasOrHave [_] = text "has" hasOrHave _ = text "have" + +{- Note [SDoc versus HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +The SDoc type is used pervasively throughout the compiler to represent pretty- +printable output. Almost all text written by GHC, from the Haskell types and +expressions included in error messages to debug dumps, is assembled using SDoc. +SDoc is nice because it handles multiline layout in a semi-automatic fashion, +enabling printed expressions to wrap to fit a given line width while correctly +indenting the following lines to preserve alignment. + +SDoc’s niceties necessarily have some performance cost, but this is normally +okay, as printing output is rarely a performance bottleneck. However, one +notable exception to this is code generation: GHC must sometimes write +megabytes’ worth of generated assembly when compiling a single module, in which +case the overhead of SDoc has a significant cost (see #21853 for some numbers). +Moreover, generated assembly does not have the complex layout requirements of +pretty-printed Haskell code, so using SDoc does not buy us much, anyway. + +Nevertheless, we do still want to be able to share some logic between writing +assembly and pretty-printing. For example, the logic for printing basic block +labels (GHC.Cmm.CLabel.pprCLabel) is nontrivial, so we want to have a single +implementation that can be used both when generating code and when generating +Cmm dumps. This is where HDoc comes in: HDoc provides a subset of the SDoc +interface, but it is implemented in a far more efficient way, writing directly +to a `Handle` (via a `BufHandle`) without building any intermediate structures. +We can then use typeclasses to parameterize functions like `pprCLabel` over the +printing implementation. + +One might imagine this would result in one IsDoc typeclass, and two instances, +one for SDoc and one for HDoc. However, in fact, we need two *variants* of HDoc, +as described in Note [HLine versus HDoc], and this gives rise to a small +typeclass hierarchy consisting of IsOutput, IsLine, and IsDoc; +see Note [The outputable class hierarchy] for details. + +Note [HLine versus HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [SDoc versus HDoc], HDoc does not support any of the layout +niceties of SDoc for efficiency. However, this presents a small problem if we +want to be compatible with the SDoc API, as expressions like + + text "foo" <+> (text "bar" $$ text "baz") + +are expected to produce + + foo bar + baz + +which requires tracking line widths to know how far to indent the second line. +We can’t throw out vertical composition altogether, as we need to be able to +construct multiline HDocs, but we *can* restrict vertical composition to +concatenating whole lines at a time, as this is all that is necessary to +generate assembly in the code generator. + +To implement this restriction, we provide two distinct types: HLine and HDoc. +As their names suggests, an HLine represents a single line of output, while an +HDoc represents a multiline document. Atoms formed from `char` and `text` begin +their lives as HLines, which can be horizontally (but not vertically) composed: + + char :: Char -> HLine + text :: String -> HLine + (<+>) :: HLine -> HLine -> HLine + +Once a line has been fully assembled, it can be “locked up” into a single-line +HDoc via `line`, and HDocs can be vertically (but not horizontally) composed: + + line :: HLine -> HDoc + ($$) :: HLine -> HLine -> HLine + +Note that, at runtime, HLine and HDoc use exactly the same representation. This +distinction only exists in the type system to rule out the cases we don’t want +to have to handle. + +Note [The outputable class hierarchy] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in Note [SDoc versus HDoc], we want to be able to parameterize over +the choice of printing implementation when implementing common bits of printing +logic. However, as described in Note [HLine versus HDoc], we also want to +distinguish code that does single-line printing from code that does multi-line +printing. Therefore, code that is parameterized over the choice of printer must +respect this single- versus multi-line distinction. This naturally leads to two +typeclasses: + + class IsLine doc where + char :: Char -> doc + text :: String -> doc + (<>) :: doc -> doc -> doc + ... + + class IsLine (Line doc) => IsDoc doc where + type Line doc = r | r -> doc + line :: Line doc -> doc + ($$) :: doc -> doc -> doc + ... + +These classes support the following instances: + + instance IsLine SDoc + instance IsLine SDoc where + type Line SDoc = SDoc + + instance IsLine HLine + instance IsDoc HDoc where + type Line HDoc = HLine + +However, we run into a new problem: we provide many useful combinators on docs +that don’t care at all about the single-/multi-line distinction. For example, +ppWhen and ppUnless provide conditional logic, and docWithContext provides +access to the ambient SDocContext. Given the above classes, we would need two +variants of each of these combinators: + + ppWhenL :: IsLine doc => Bool -> doc -> doc + ppWhenL c d = if c then d else emptyL + + ppWhenD :: IsDoc doc => Bool -> doc -> doc + ppWhenD c d = if c then d else emptyD + +This is a needlessly annoying distinction, so we introduce a common superclass, +IsOutput, that allows these combinators to be generic over both variants: + + class IsOutput doc where + empty :: doc + docWithContext :: (SDocContext -> doc) -> doc + + class IsOutput doc => IsLine doc + class (IsOutput doc, IsLine (Line doc)) => IsDoc doc + +In practice, IsOutput isn’t used explicitly very often, but it makes code that +uses the combinators derived from it significantly less noisy. + +Note [SPECIALIZE to HDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~ +The IsLine and IsDoc classes are useful to share printing logic between code +that uses SDoc and code that uses HDoc, but we must take some care when doing +so. Much HDoc’s efficiency comes from GHC’s ability to optimize code that uses +it to eliminate unnecessary indirection, but the HDoc primitives must be inlined +before these opportunities can be exposed. Therefore, we want to explicitly +request that GHC generate HDoc (or HLine) specializations of any polymorphic +printing functions used by the code generator. + +In code generators (CmmToAsm.{AArch64,PPC,X86}.Ppr) we add a specialize +pragma just to the entry point pprNatCmmDecl, to avoid cluttering +the entire module. Because specialization is transitive, this makes sure +that other functions in that module are specialized too. + +Note [dualLine and dualDoc] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The IsLine and IsDoc classes provide the dualLine and dualDoc methods, +respectively, which have the following types: + + dualLine :: IsLine doc => SDoc -> HLine -> doc + dualDoc :: IsDoc doc => SDoc -> HDoc -> doc + +These are effectively a form of type-`case`, selecting between each of their two +arguments depending on the type they are instantiated at. They serve as a +“nuclear option” for code that is, for some reason or another, unreasonably +difficult to make completely equivalent under both printer implementations. + +These operations should generally be avoided, as they can result in surprising +changes in behavior when the printer implementation is changed. However, in +certain cases, the alternative is even worse. For example, we use dualLine in +the implementation of pprUnitId, as the hack we use for printing unit ids +(see Note [Pretty-printing UnitId] in GHC.Unit) is difficult to adapt to HLine +and is not necessary for code paths that use it, anyway. + +Use these operations wisely. -} + +-- | Represents a single line of output that can be efficiently printed directly +-- to a 'System.IO.Handle' (actually a 'BufHandle'). +-- See Note [SDoc versus HDoc] and Note [HLine versus HDoc] for more details. +newtype HLine = HLine' { runHLine :: SDocContext -> BufHandle -> IO () } + +-- | Represents a (possibly empty) sequence of lines that can be efficiently +-- printed directly to a 'System.IO.Handle' (actually a 'BufHandle'). +-- See Note [SDoc versus HDoc] and Note [HLine versus HDoc] for more details. +newtype HDoc = HDoc' { runHDoc :: SDocContext -> BufHandle -> IO () } + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern HLine :: (SDocContext -> BufHandle -> IO ()) -> HLine +pattern HLine f <- HLine' f + where HLine f = HLine' (oneShot (\ctx -> oneShot (\h -> f ctx h))) +{-# COMPLETE HLine #-} + +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +pattern HDoc :: (SDocContext -> BufHandle -> IO ()) -> HDoc +pattern HDoc f <- HDoc' f + where HDoc f = HDoc' (oneShot (\ctx -> oneShot (\h -> f ctx h))) +{-# COMPLETE HDoc #-} + +bPutHDoc :: BufHandle -> SDocContext -> HDoc -> IO () +bPutHDoc h ctx (HDoc f) = f ctx h + +-- | A superclass for 'IsLine' and 'IsDoc' that provides an identity, 'empty', +-- as well as access to the shared 'SDocContext'. +-- +-- See Note [The outputable class hierarchy] for more details. +class IsOutput doc where + empty :: doc + docWithContext :: (SDocContext -> doc) -> doc + +-- | A class of types that represent a single logical line of text, with support +-- for horizontal composition. +-- +-- See Note [HLine versus HDoc] and Note [The outputable class hierarchy] for +-- more details. +class IsOutput doc => IsLine doc where + char :: Char -> doc + text :: String -> doc + ftext :: FastString -> doc + ztext :: FastZString -> doc + + -- | Join two @doc@s together horizontally without a gap. + (<>) :: doc -> doc -> doc + -- | Join two @doc@s together horizontally with a gap between them. + (<+>) :: doc -> doc -> doc + -- | Separate: is either like 'hsep' or like 'vcat', depending on what fits. + sep :: [doc] -> doc + -- | A paragraph-fill combinator. It's much like 'sep', only it keeps fitting + -- things on one line until it can't fit any more. + fsep :: [doc] -> doc + + -- | Concatenate @doc@s horizontally without gaps. + hcat :: [doc] -> doc + hcat docs = foldr (<>) empty docs + {-# INLINE CONLIKE hcat #-} + + -- | Concatenate @doc@s horizontally with a space between each one. + hsep :: [doc] -> doc + hsep docs = foldr (<+>) empty docs + {-# INLINE CONLIKE hsep #-} + + -- | Prints as either the given 'SDoc' or the given 'HLine', depending on + -- which type the result is instantiated to. This should generally be avoided; + -- see Note [dualLine and dualDoc] for details. + dualLine :: SDoc -> HLine -> doc + + +-- | A class of types that represent a multiline document, with support for +-- vertical composition. +-- +-- See Note [HLine versus HDoc] and Note [The outputable class hierarchy] for +-- more details. +class (IsOutput doc, IsLine (Line doc)) => IsDoc doc where + type Line doc = r | r -> doc + line :: Line doc -> doc + + -- | Join two @doc@s together vertically. If there is no vertical overlap it + -- "dovetails" the two onto one line. + ($$) :: doc -> doc -> doc + + lines_ :: [Line doc] -> doc + lines_ = vcat . map line + {-# INLINE CONLIKE lines_ #-} + + -- | Concatenate @doc@s vertically with dovetailing. + vcat :: [doc] -> doc + vcat ls = foldr ($$) empty ls + {-# INLINE CONLIKE vcat #-} + + -- | Prints as either the given 'SDoc' or the given 'HDoc', depending on + -- which type the result is instantiated to. This should generally be avoided; + -- see Note [dualLine and dualDoc] for details. + dualDoc :: SDoc -> HDoc -> doc + +instance IsOutput SDoc where + empty = docToSDoc $ Pretty.empty + {-# INLINE CONLIKE empty #-} + docWithContext = sdocWithContext + {-# INLINE docWithContext #-} + +instance IsLine SDoc where + char c = docToSDoc $ Pretty.char c + {-# INLINE CONLIKE char #-} + text s = docToSDoc $ Pretty.text s + {-# INLINE CONLIKE text #-} -- Inline so that the RULE Pretty.text will fire + ftext s = docToSDoc $ Pretty.ftext s + {-# INLINE CONLIKE ftext #-} + ztext s = docToSDoc $ Pretty.ztext s + {-# INLINE CONLIKE ztext #-} + (<>) d1 d2 = SDoc $ \ctx -> (Pretty.<>) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE (<>) #-} + (<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE (<+>) #-} + hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE hcat #-} + hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE hsep #-} + sep ds = SDoc $ \ctx -> Pretty.sep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE sep #-} + fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE fsep #-} + dualLine s _ = s + {-# INLINE CONLIKE dualLine #-} + +instance IsDoc SDoc where + type Line SDoc = SDoc + line = id + {-# INLINE line #-} + lines_ = vcat + {-# INLINE lines_ #-} + + ($$) d1 d2 = SDoc $ \ctx -> (Pretty.$$) (runSDoc d1 ctx) (runSDoc d2 ctx) + {-# INLINE CONLIKE ($$) #-} + vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds] + {-# INLINE CONLIKE vcat #-} + dualDoc s _ = s + {-# INLINE CONLIKE dualDoc #-} + +instance IsOutput HLine where + empty = HLine (\_ _ -> pure ()) + {-# INLINE empty #-} + docWithContext f = HLine $ \ctx h -> runHLine (f ctx) ctx h + {-# INLINE CONLIKE docWithContext #-} + +instance IsOutput HDoc where + empty = HDoc (\_ _ -> pure ()) + {-# INLINE empty #-} + docWithContext f = HDoc $ \ctx h -> runHDoc (f ctx) ctx h + {-# INLINE CONLIKE docWithContext #-} + +instance IsLine HLine where + char c = HLine (\_ h -> bPutChar h c) + {-# INLINE CONLIKE char #-} + text str = HLine (\_ h -> bPutStr h str) + {-# INLINE CONLIKE text #-} + ftext fstr = HLine (\_ h -> bPutFS h fstr) + {-# INLINE CONLIKE ftext #-} + ztext fstr = HLine (\_ h -> bPutFZS h fstr) + {-# INLINE CONLIKE ztext #-} + + HLine f <> HLine g = HLine (\ctx h -> f ctx h *> g ctx h) + {-# INLINE CONLIKE (<>) #-} + f <+> g = f <> char ' ' <> g + {-# INLINE CONLIKE (<+>) #-} + sep = hsep + {-# INLINE sep #-} + fsep = hsep + {-# INLINE fsep #-} + + dualLine _ h = h + {-# INLINE CONLIKE dualLine #-} + +instance IsDoc HDoc where + type Line HDoc = HLine + line (HLine f) = HDoc (\ctx h -> f ctx h *> bPutChar h '\n') + {-# INLINE CONLIKE line #-} + HDoc f $$ HDoc g = HDoc (\ctx h -> f ctx h *> g ctx h) + {-# INLINE CONLIKE ($$) #-} + dualDoc _ h = h + {-# INLINE CONLIKE dualDoc #-} |