never executed always true always false
    1 {-# LANGUAGE LambdaCase #-}
    2 {-# LANGUAGE PatternSynonyms #-}
    3 {-# LANGUAGE StandaloneDeriving #-}
    4 {-# LANGUAGE DerivingStrategies #-}
    5 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
    6 {-# LANGUAGE FlexibleInstances #-}
    7 {-# LANGUAGE MultiParamTypeClasses #-}
    8 
    9 {-
   10 (c) The University of Glasgow 2006-2012
   11 (c) The GRASP Project, Glasgow University, 1992-1998
   12 -}
   13 
   14 -- | This module defines classes and functions for pretty-printing. It also
   15 -- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'.
   16 --
   17 -- The interface to this module is very similar to the standard Hughes-PJ pretty printing
   18 -- module, except that it exports a number of additional functions that are rarely used,
   19 -- and works over the 'SDoc' type.
   20 module GHC.Utils.Outputable (
   21         -- * Type classes
   22         Outputable(..), OutputableBndr(..), OutputableP(..),
   23 
   24         -- * Pretty printing combinators
   25         SDoc, runSDoc, PDoc(..),
   26         docToSDoc,
   27         interppSP, interpp'SP, interpp'SP',
   28         pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,
   29         pprWithBars,
   30         empty, isEmpty, nest,
   31         char,
   32         text, ftext, ptext, ztext,
   33         int, intWithCommas, integer, word, float, double, rational, doublePrec,
   34         parens, cparen, brackets, braces, quotes, quote,
   35         doubleQuotes, angleBrackets,
   36         semi, comma, colon, dcolon, space, equals, dot, vbar,
   37         arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,
   38         lambda,
   39         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, mulArrow,
   40         blankLine, forAllLit, bullet,
   41         (<>), (<+>), hcat, hsep,
   42         ($$), ($+$), vcat,
   43         sep, cat,
   44         fsep, fcat,
   45         hang, hangNotEmpty, punctuate, ppWhen, ppUnless,
   46         ppWhenOption, ppUnlessOption,
   47         speakNth, speakN, speakNOf, plural, singular, isOrAre, doOrDoes, itsOrTheir, thisOrThese,
   48         unicodeSyntax,
   49 
   50         coloured, keyword,
   51 
   52         -- * Converting 'SDoc' into strings and outputting it
   53         printSDoc, printSDocLn,
   54         bufLeftRenderSDoc,
   55         pprCode,
   56         showSDocOneLine,
   57         showSDocUnsafe,
   58         showPprUnsafe,
   59         renderWithContext,
   60         pprDebugAndThen,
   61 
   62         pprInfixVar, pprPrefixVar,
   63         pprHsChar, pprHsString, pprHsBytes,
   64 
   65         primFloatSuffix, primCharSuffix, primDoubleSuffix,
   66         primInt8Suffix, primWord8Suffix,
   67         primInt16Suffix, primWord16Suffix,
   68         primInt32Suffix, primWord32Suffix,
   69         primInt64Suffix, primWord64Suffix,
   70         primIntSuffix, primWordSuffix,
   71 
   72         pprPrimChar, pprPrimInt, pprPrimWord,
   73         pprPrimInt8, pprPrimWord8,
   74         pprPrimInt16, pprPrimWord16,
   75         pprPrimInt32, pprPrimWord32,
   76         pprPrimInt64, pprPrimWord64,
   77 
   78         pprFastFilePath, pprFilePathString,
   79 
   80         -- * Controlling the style in which output is printed
   81         BindingSite(..),
   82 
   83         PprStyle(..), LabelStyle(..), PrintUnqualified(..),
   84         QueryQualifyName, QueryQualifyModule, QueryQualifyPackage,
   85         reallyAlwaysQualify, reallyAlwaysQualifyNames,
   86         alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,
   87         neverQualify, neverQualifyNames, neverQualifyModules,
   88         alwaysQualifyPackages, neverQualifyPackages,
   89         QualifyName(..), queryQual,
   90         sdocOption,
   91         updSDocContext,
   92         SDocContext (..), sdocWithContext, defaultSDocContext,
   93         getPprStyle, withPprStyle, setStyleColoured,
   94         pprDeeper, pprDeeperList, pprSetDepth,
   95         codeStyle, userStyle, dumpStyle, asmStyle,
   96         qualName, qualModule, qualPackage,
   97         mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle,
   98         mkUserStyle, cmdlineParserStyle, Depth(..),
   99         withUserStyle, withErrStyle,
  100 
  101         ifPprDebug, whenPprDebug, getPprDebug,
  102 
  103     ) where
  104 
  105 import GHC.Prelude
  106 
  107 import {-# SOURCE #-}   GHC.Unit.Types ( Unit, Module, moduleName )
  108 import {-# SOURCE #-}   GHC.Unit.Module.Name( ModuleName )
  109 import {-# SOURCE #-}   GHC.Types.Name.Occurrence( OccName )
  110 
  111 import GHC.Utils.BufHandle (BufHandle)
  112 import GHC.Data.FastString
  113 import qualified GHC.Utils.Ppr as Pretty
  114 import qualified GHC.Utils.Ppr.Colour as Col
  115 import GHC.Utils.Ppr       ( Doc, Mode(..) )
  116 import GHC.Serialized
  117 import GHC.LanguageExtensions (Extension)
  118 
  119 import Data.ByteString (ByteString)
  120 import qualified Data.ByteString as BS
  121 import Data.Char
  122 import qualified Data.Map as M
  123 import Data.Int
  124 import qualified Data.IntMap as IM
  125 import Data.Set (Set)
  126 import qualified Data.Set as Set
  127 import qualified Data.IntSet as IntSet
  128 import Data.String
  129 import Data.Word
  130 import System.IO        ( Handle )
  131 import System.FilePath
  132 import Text.Printf
  133 import Numeric (showFFloat)
  134 import Data.Graph (SCC(..))
  135 import Data.List (intersperse)
  136 import Data.List.NonEmpty (NonEmpty (..))
  137 import qualified Data.List.NonEmpty as NEL
  138 import Data.Time
  139 import Data.Time.Format.ISO8601
  140 
  141 import GHC.Fingerprint
  142 import GHC.Show         ( showMultiLineString )
  143 import GHC.Utils.Exception
  144 import GHC.Exts (oneShot)
  145 
  146 {-
  147 ************************************************************************
  148 *                                                                      *
  149 \subsection{The @PprStyle@ data type}
  150 *                                                                      *
  151 ************************************************************************
  152 -}
  153 
  154 data PprStyle
  155   = PprUser PrintUnqualified Depth Coloured
  156                 -- Pretty-print in a way that will make sense to the
  157                 -- ordinary user; must be very close to Haskell
  158                 -- syntax, etc.
  159                 -- Assumes printing tidied code: non-system names are
  160                 -- printed without uniques.
  161 
  162   | PprDump PrintUnqualified
  163                 -- For -ddump-foo; less verbose than in ppr-debug mode, but more than PprUser
  164                 -- Does not assume tidied code: non-external names
  165                 -- are printed with uniques.
  166 
  167   | PprCode !LabelStyle -- ^ Print code; either C or assembler
  168 
  169 -- | Style of label pretty-printing.
  170 --
  171 -- When we produce C sources or headers, we have to take into account that C
  172 -- compilers transform C labels when they convert them into symbols. For
  173 -- example, they can add prefixes (e.g., "_" on Darwin) or suffixes (size for
  174 -- stdcalls on Windows). So we provide two ways to pretty-print CLabels: C style
  175 -- or Asm style.
  176 --
  177 data LabelStyle
  178    = CStyle   -- ^ C label style (used by C and LLVM backends)
  179    | AsmStyle -- ^ Asm label style (used by NCG backend)
  180    deriving (Eq,Ord,Show)
  181 
  182 data Depth
  183    = AllTheWay
  184    | PartWay Int  -- ^ 0 => stop
  185    | DefaultDepth -- ^ Use 'sdocDefaultDepth' field as depth
  186 
  187 data Coloured
  188   = Uncoloured
  189   | Coloured
  190 
  191 -- -----------------------------------------------------------------------------
  192 -- Printing original names
  193 
  194 -- | When printing code that contains original names, we need to map the
  195 -- original names back to something the user understands.  This is the
  196 -- purpose of the triple of functions that gets passed around
  197 -- when rendering 'SDoc'.
  198 data PrintUnqualified = QueryQualify {
  199     queryQualifyName    :: QueryQualifyName,
  200     queryQualifyModule  :: QueryQualifyModule,
  201     queryQualifyPackage :: QueryQualifyPackage
  202 }
  203 
  204 -- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify
  205 -- it.
  206 type QueryQualifyName = Module -> OccName -> QualifyName
  207 
  208 -- | For a given module, we need to know whether to print it with
  209 -- a package name to disambiguate it.
  210 type QueryQualifyModule = Module -> Bool
  211 
  212 -- | For a given package, we need to know whether to print it with
  213 -- the component id to disambiguate it.
  214 type QueryQualifyPackage = Unit -> Bool
  215 
  216 -- See Note [Printing original names] in GHC.Types.Name.Ppr
  217 data QualifyName   -- Given P:M.T
  218   = NameUnqual           -- It's in scope unqualified as "T"
  219                          -- OR nothing called "T" is in scope
  220 
  221   | NameQual ModuleName  -- It's in scope qualified as "X.T"
  222 
  223   | NameNotInScope1      -- It's not in scope at all, but M.T is not bound
  224                          -- in the current scope, so we can refer to it as "M.T"
  225 
  226   | NameNotInScope2      -- It's not in scope at all, and M.T is already bound in
  227                          -- the current scope, so we must refer to it as "P:M.T"
  228 
  229 instance Outputable QualifyName where
  230   ppr NameUnqual      = text "NameUnqual"
  231   ppr (NameQual _mod) = text "NameQual"  -- can't print the mod without module loops :(
  232   ppr NameNotInScope1 = text "NameNotInScope1"
  233   ppr NameNotInScope2 = text "NameNotInScope2"
  234 
  235 reallyAlwaysQualifyNames :: QueryQualifyName
  236 reallyAlwaysQualifyNames _ _ = NameNotInScope2
  237 
  238 -- | NB: This won't ever show package IDs
  239 alwaysQualifyNames :: QueryQualifyName
  240 alwaysQualifyNames m _ = NameQual (moduleName m)
  241 
  242 neverQualifyNames :: QueryQualifyName
  243 neverQualifyNames _ _ = NameUnqual
  244 
  245 alwaysQualifyModules :: QueryQualifyModule
  246 alwaysQualifyModules _ = True
  247 
  248 neverQualifyModules :: QueryQualifyModule
  249 neverQualifyModules _ = False
  250 
  251 alwaysQualifyPackages :: QueryQualifyPackage
  252 alwaysQualifyPackages _ = True
  253 
  254 neverQualifyPackages :: QueryQualifyPackage
  255 neverQualifyPackages _ = False
  256 
  257 reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified
  258 reallyAlwaysQualify
  259               = QueryQualify reallyAlwaysQualifyNames
  260                              alwaysQualifyModules
  261                              alwaysQualifyPackages
  262 alwaysQualify = QueryQualify alwaysQualifyNames
  263                              alwaysQualifyModules
  264                              alwaysQualifyPackages
  265 neverQualify  = QueryQualify neverQualifyNames
  266                              neverQualifyModules
  267                              neverQualifyPackages
  268 
  269 defaultUserStyle :: PprStyle
  270 defaultUserStyle = mkUserStyle neverQualify AllTheWay
  271 
  272 defaultDumpStyle :: PprStyle
  273  -- Print without qualifiers to reduce verbosity, unless -dppr-debug
  274 defaultDumpStyle = PprDump neverQualify
  275 
  276 mkDumpStyle :: PrintUnqualified -> PprStyle
  277 mkDumpStyle print_unqual = PprDump print_unqual
  278 
  279 -- | Default style for error messages, when we don't know PrintUnqualified
  280 -- It's a bit of a hack because it doesn't take into account what's in scope
  281 -- Only used for desugarer warnings, and typechecker errors in interface sigs
  282 defaultErrStyle :: PprStyle
  283 defaultErrStyle = mkErrStyle neverQualify
  284 
  285 -- | Style for printing error messages
  286 mkErrStyle :: PrintUnqualified -> PprStyle
  287 mkErrStyle unqual = mkUserStyle unqual DefaultDepth
  288 
  289 cmdlineParserStyle :: PprStyle
  290 cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay
  291 
  292 mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
  293 mkUserStyle unqual depth = PprUser unqual depth Uncoloured
  294 
  295 withUserStyle :: PrintUnqualified -> Depth -> SDoc -> SDoc
  296 withUserStyle unqual depth doc = withPprStyle (PprUser unqual depth Uncoloured) doc
  297 
  298 withErrStyle :: PrintUnqualified -> SDoc -> SDoc
  299 withErrStyle unqual doc =
  300    withPprStyle (mkErrStyle unqual) doc
  301 
  302 setStyleColoured :: Bool -> PprStyle -> PprStyle
  303 setStyleColoured col style =
  304   case style of
  305     PprUser q d _ -> PprUser q d c
  306     _             -> style
  307   where
  308     c | col       = Coloured
  309       | otherwise = Uncoloured
  310 
  311 instance Outputable PprStyle where
  312   ppr (PprUser {})  = text "user-style"
  313   ppr (PprCode {})  = text "code-style"
  314   ppr (PprDump {})  = text "dump-style"
  315 
  316 {-
  317 Orthogonal to the above printing styles are (possibly) some
  318 command-line flags that affect printing (often carried with the
  319 style).  The most likely ones are variations on how much type info is
  320 shown.
  321 
  322 The following test decides whether or not we are actually generating
  323 code (either C or assembly), or generating interface files.
  324 
  325 ************************************************************************
  326 *                                                                      *
  327 \subsection{The @SDoc@ data type}
  328 *                                                                      *
  329 ************************************************************************
  330 -}
  331 
  332 -- | Represents a pretty-printable document.
  333 --
  334 -- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc',
  335 -- or 'renderWithContext'.  Avoid calling 'runSDoc' directly as it breaks the
  336 -- abstraction layer.
  337 newtype SDoc = SDoc' (SDocContext -> Doc)
  338 
  339 -- See Note [The one-shot state monad trick] in GHC.Utils.Monad
  340 {-# COMPLETE SDoc #-}
  341 pattern SDoc :: (SDocContext -> Doc) -> SDoc
  342 pattern SDoc m <- SDoc' m
  343   where
  344     SDoc m = SDoc' (oneShot m)
  345 
  346 runSDoc :: SDoc -> (SDocContext -> Doc)
  347 runSDoc (SDoc m) = m
  348 
  349 data SDocContext = SDC
  350   { sdocStyle                       :: !PprStyle
  351   , sdocColScheme                   :: !Col.Scheme
  352   , sdocLastColour                  :: !Col.PprColour
  353       -- ^ The most recently used colour.
  354       -- This allows nesting colours.
  355   , sdocShouldUseColor              :: !Bool
  356   , sdocDefaultDepth                :: !Int
  357   , sdocLineLength                  :: !Int
  358   , sdocCanUseUnicode               :: !Bool
  359       -- ^ True if Unicode encoding is supported
  360       -- and not disable by GHC_NO_UNICODE environment variable
  361   , sdocHexWordLiterals             :: !Bool
  362   , sdocPprDebug                    :: !Bool
  363   , sdocPrintUnicodeSyntax          :: !Bool
  364   , sdocPrintCaseAsLet              :: !Bool
  365   , sdocPrintTypecheckerElaboration :: !Bool
  366   , sdocPrintAxiomIncomps           :: !Bool
  367   , sdocPrintExplicitKinds          :: !Bool
  368   , sdocPrintExplicitCoercions      :: !Bool
  369   , sdocPrintExplicitRuntimeReps    :: !Bool
  370   , sdocPrintExplicitForalls        :: !Bool
  371   , sdocPrintPotentialInstances     :: !Bool
  372   , sdocPrintEqualityRelations      :: !Bool
  373   , sdocSuppressTicks               :: !Bool
  374   , sdocSuppressTypeSignatures      :: !Bool
  375   , sdocSuppressTypeApplications    :: !Bool
  376   , sdocSuppressIdInfo              :: !Bool
  377   , sdocSuppressCoercions           :: !Bool
  378   , sdocSuppressUnfoldings          :: !Bool
  379   , sdocSuppressVarKinds            :: !Bool
  380   , sdocSuppressUniques             :: !Bool
  381   , sdocSuppressModulePrefixes      :: !Bool
  382   , sdocSuppressStgExts             :: !Bool
  383   , sdocErrorSpans                  :: !Bool
  384   , sdocStarIsType                  :: !Bool
  385   , sdocLinearTypes                 :: !Bool
  386   , sdocImpredicativeTypes          :: !Bool
  387   , sdocPrintTypeAbbreviations      :: !Bool
  388   , sdocUnitIdForUser               :: !(FastString -> SDoc)
  389       -- ^ Used to map UnitIds to more friendly "package-version:component"
  390       -- strings while pretty-printing.
  391       --
  392       -- Use `GHC.Unit.State.pprWithUnitState` to set it. Users should never
  393       -- have to set it to pretty-print SDocs emitted by GHC, otherwise it's a
  394       -- bug. It's an internal field used to thread the UnitState so that the
  395       -- Outputable instance of UnitId can use it.
  396       --
  397       -- See Note [Pretty-printing UnitId] in "GHC.Unit" for more details.
  398       --
  399       -- Note that we use `FastString` instead of `UnitId` to avoid boring
  400       -- module inter-dependency issues.
  401   }
  402 
  403 instance IsString SDoc where
  404   fromString = text
  405 
  406 -- The lazy programmer's friend.
  407 instance Outputable SDoc where
  408   ppr = id
  409 
  410 -- | Default pretty-printing options
  411 defaultSDocContext :: SDocContext
  412 defaultSDocContext = SDC
  413   { sdocStyle                       = defaultDumpStyle
  414   , sdocColScheme                   = Col.defaultScheme
  415   , sdocLastColour                  = Col.colReset
  416   , sdocShouldUseColor              = False
  417   , sdocDefaultDepth                = 5
  418   , sdocLineLength                  = 100
  419   , sdocCanUseUnicode               = False
  420   , sdocHexWordLiterals             = False
  421   , sdocPprDebug                    = False
  422   , sdocPrintUnicodeSyntax          = False
  423   , sdocPrintCaseAsLet              = False
  424   , sdocPrintTypecheckerElaboration = False
  425   , sdocPrintAxiomIncomps           = False
  426   , sdocPrintExplicitKinds          = False
  427   , sdocPrintExplicitCoercions      = False
  428   , sdocPrintExplicitRuntimeReps    = False
  429   , sdocPrintExplicitForalls        = False
  430   , sdocPrintPotentialInstances     = False
  431   , sdocPrintEqualityRelations      = False
  432   , sdocSuppressTicks               = False
  433   , sdocSuppressTypeSignatures      = False
  434   , sdocSuppressTypeApplications    = False
  435   , sdocSuppressIdInfo              = False
  436   , sdocSuppressCoercions           = False
  437   , sdocSuppressUnfoldings          = False
  438   , sdocSuppressVarKinds            = False
  439   , sdocSuppressUniques             = False
  440   , sdocSuppressModulePrefixes      = False
  441   , sdocSuppressStgExts             = False
  442   , sdocErrorSpans                  = False
  443   , sdocStarIsType                  = False
  444   , sdocImpredicativeTypes          = False
  445   , sdocLinearTypes                 = False
  446   , sdocPrintTypeAbbreviations      = True
  447   , sdocUnitIdForUser               = ftext
  448   }
  449 
  450 withPprStyle :: PprStyle -> SDoc -> SDoc
  451 {-# INLINE CONLIKE withPprStyle #-}
  452 withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
  453 
  454 pprDeeper :: SDoc -> SDoc
  455 pprDeeper d = SDoc $ \ctx -> case sdocStyle ctx of
  456   PprUser q depth c ->
  457    let deeper 0 = Pretty.text "..."
  458        deeper n = runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
  459    in case depth of
  460          DefaultDepth -> deeper (sdocDefaultDepth ctx)
  461          PartWay n    -> deeper n
  462          AllTheWay    -> runSDoc d ctx
  463   _ -> runSDoc d ctx
  464 
  465 
  466 -- | Truncate a list that is longer than the current depth.
  467 pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
  468 pprDeeperList f ds
  469   | null ds   = f []
  470   | otherwise = SDoc work
  471  where
  472   work ctx@SDC{sdocStyle=PprUser q depth c}
  473    | DefaultDepth <- depth
  474    = work (ctx { sdocStyle = PprUser q (PartWay (sdocDefaultDepth ctx)) c })
  475    | PartWay 0 <- depth
  476    = Pretty.text "..."
  477    | PartWay n <- depth
  478    = let
  479         go _ [] = []
  480         go i (d:ds) | i >= n    = [text "...."]
  481                     | otherwise = d : go (i+1) ds
  482      in runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c}
  483   work other_ctx = runSDoc (f ds) other_ctx
  484 
  485 pprSetDepth :: Depth -> SDoc -> SDoc
  486 pprSetDepth depth doc = SDoc $ \ctx ->
  487     case ctx of
  488         SDC{sdocStyle=PprUser q _ c} ->
  489             runSDoc doc ctx{sdocStyle = PprUser q depth c}
  490         _ ->
  491             runSDoc doc ctx
  492 
  493 getPprStyle :: (PprStyle -> SDoc) -> SDoc
  494 {-# INLINE CONLIKE getPprStyle #-}
  495 getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
  496 
  497 sdocWithContext :: (SDocContext -> SDoc) -> SDoc
  498 {-# INLINE CONLIKE sdocWithContext #-}
  499 sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx
  500 
  501 sdocOption :: (SDocContext -> a) -> (a -> SDoc) -> SDoc
  502 {-# INLINE CONLIKE sdocOption #-}
  503 sdocOption f g = sdocWithContext (g . f)
  504 
  505 updSDocContext :: (SDocContext -> SDocContext) -> SDoc -> SDoc
  506 {-# INLINE CONLIKE updSDocContext #-}
  507 updSDocContext upd doc
  508   = SDoc $ \ctx -> runSDoc doc (upd ctx)
  509 
  510 qualName :: PprStyle -> QueryQualifyName
  511 qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ
  512 qualName (PprDump q)     mod occ = queryQualifyName q mod occ
  513 qualName _other          mod _   = NameQual (moduleName mod)
  514 
  515 qualModule :: PprStyle -> QueryQualifyModule
  516 qualModule (PprUser q _ _)  m = queryQualifyModule q m
  517 qualModule (PprDump q)      m = queryQualifyModule q m
  518 qualModule _other          _m = True
  519 
  520 qualPackage :: PprStyle -> QueryQualifyPackage
  521 qualPackage (PprUser q _ _)  m = queryQualifyPackage q m
  522 qualPackage (PprDump q)      m = queryQualifyPackage q m
  523 qualPackage _other          _m = True
  524 
  525 queryQual :: PprStyle -> PrintUnqualified
  526 queryQual s = QueryQualify (qualName s)
  527                            (qualModule s)
  528                            (qualPackage s)
  529 
  530 codeStyle :: PprStyle -> Bool
  531 codeStyle (PprCode _)     = True
  532 codeStyle _               = False
  533 
  534 asmStyle :: PprStyle -> Bool
  535 asmStyle (PprCode AsmStyle)  = True
  536 asmStyle _other              = False
  537 
  538 dumpStyle :: PprStyle -> Bool
  539 dumpStyle (PprDump {}) = True
  540 dumpStyle _other       = False
  541 
  542 userStyle ::  PprStyle -> Bool
  543 userStyle (PprUser {}) = True
  544 userStyle _other       = False
  545 
  546 -- | Indicate if -dppr-debug mode is enabled
  547 getPprDebug :: (Bool -> SDoc) -> SDoc
  548 {-# INLINE CONLIKE getPprDebug #-}
  549 getPprDebug d = sdocWithContext $ \ctx -> d (sdocPprDebug ctx)
  550 
  551 -- | Says what to do with and without -dppr-debug
  552 ifPprDebug :: SDoc -> SDoc -> SDoc
  553 {-# INLINE CONLIKE ifPprDebug #-}
  554 ifPprDebug yes no = getPprDebug $ \dbg -> if dbg then yes else no
  555 
  556 -- | Says what to do with -dppr-debug; without, return empty
  557 whenPprDebug :: SDoc -> SDoc        -- Empty for non-debug style
  558 {-# INLINE CONLIKE whenPprDebug #-}
  559 whenPprDebug d = ifPprDebug d empty
  560 
  561 -- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the
  562 --   terminal doesn't get screwed up by the ANSI color codes if an exception
  563 --   is thrown during pretty-printing.
  564 printSDoc :: SDocContext -> Mode -> Handle -> SDoc -> IO ()
  565 printSDoc ctx mode handle doc =
  566   Pretty.printDoc_ mode cols handle (runSDoc doc ctx)
  567     `finally`
  568       Pretty.printDoc_ mode cols handle
  569         (runSDoc (coloured Col.colReset empty) ctx)
  570   where
  571     cols = sdocLineLength ctx
  572 
  573 -- | Like 'printSDoc' but appends an extra newline.
  574 printSDocLn :: SDocContext -> Mode -> Handle -> SDoc -> IO ()
  575 printSDocLn ctx mode handle doc =
  576   printSDoc ctx mode handle (doc $$ text "")
  577 
  578 -- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that
  579 -- outputs to a 'BufHandle'.
  580 bufLeftRenderSDoc :: SDocContext -> BufHandle -> SDoc -> IO ()
  581 bufLeftRenderSDoc ctx bufHandle doc =
  582   Pretty.bufLeftRender bufHandle (runSDoc doc ctx)
  583 
  584 pprCode :: LabelStyle -> SDoc -> SDoc
  585 {-# INLINE CONLIKE pprCode #-}
  586 pprCode cs d = withPprStyle (PprCode cs) d
  587 
  588 renderWithContext :: SDocContext -> SDoc -> String
  589 renderWithContext ctx sdoc
  590   = let s = Pretty.style{ Pretty.mode       = PageMode False,
  591                           Pretty.lineLength = sdocLineLength ctx }
  592     in Pretty.renderStyle s $ runSDoc sdoc ctx
  593 
  594 -- This shows an SDoc, but on one line only. It's cheaper than a full
  595 -- showSDoc, designed for when we're getting results like "Foo.bar"
  596 -- and "foo{uniq strictness}" so we don't want fancy layout anyway.
  597 showSDocOneLine :: SDocContext -> SDoc -> String
  598 showSDocOneLine ctx d
  599  = let s = Pretty.style{ Pretty.mode = OneLineMode,
  600                          Pretty.lineLength = sdocLineLength ctx } in
  601    Pretty.renderStyle s $
  602       runSDoc d ctx
  603 
  604 showSDocUnsafe :: SDoc -> String
  605 showSDocUnsafe sdoc = renderWithContext defaultSDocContext sdoc
  606 
  607 showPprUnsafe :: Outputable a => a -> String
  608 showPprUnsafe a = renderWithContext defaultSDocContext (ppr a)
  609 
  610 
  611 pprDebugAndThen :: SDocContext -> (String -> a) -> SDoc -> SDoc -> a
  612 pprDebugAndThen ctx cont heading pretty_msg
  613  = cont (renderWithContext ctx doc)
  614  where
  615      doc = withPprStyle defaultDumpStyle (sep [heading, nest 2 pretty_msg])
  616 
  617 
  618 isEmpty :: SDocContext -> SDoc -> Bool
  619 isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocPprDebug = True})
  620 
  621 docToSDoc :: Doc -> SDoc
  622 docToSDoc d = SDoc (\_ -> d)
  623 
  624 empty    :: SDoc
  625 char     :: Char       -> SDoc
  626 text     :: String     -> SDoc
  627 ftext    :: FastString -> SDoc
  628 ptext    :: PtrString  -> SDoc
  629 ztext    :: FastZString -> SDoc
  630 int      :: Int        -> SDoc
  631 integer  :: Integer    -> SDoc
  632 word     :: Integer    -> SDoc
  633 float    :: Float      -> SDoc
  634 double   :: Double     -> SDoc
  635 rational :: Rational   -> SDoc
  636 
  637 {-# INLINE CONLIKE empty #-}
  638 empty       = docToSDoc $ Pretty.empty
  639 {-# INLINE CONLIKE char #-}
  640 char c      = docToSDoc $ Pretty.char c
  641 
  642 {-# INLINE CONLIKE text #-}   -- Inline so that the RULE Pretty.text will fire
  643 text s      = docToSDoc $ Pretty.text s
  644 
  645 {-# INLINE CONLIKE ftext #-}
  646 ftext s     = docToSDoc $ Pretty.ftext s
  647 {-# INLINE CONLIKE ptext #-}
  648 ptext s     = docToSDoc $ Pretty.ptext s
  649 {-# INLINE CONLIKE ztext #-}
  650 ztext s     = docToSDoc $ Pretty.ztext s
  651 {-# INLINE CONLIKE int #-}
  652 int n       = docToSDoc $ Pretty.int n
  653 {-# INLINE CONLIKE integer #-}
  654 integer n   = docToSDoc $ Pretty.integer n
  655 {-# INLINE CONLIKE float #-}
  656 float n     = docToSDoc $ Pretty.float n
  657 {-# INLINE CONLIKE double #-}
  658 double n    = docToSDoc $ Pretty.double n
  659 {-# INLINE CONLIKE rational #-}
  660 rational n  = docToSDoc $ Pretty.rational n
  661               -- See Note [Print Hexadecimal Literals] in GHC.Utils.Ppr
  662 {-# INLINE CONLIKE word #-}
  663 word n      = sdocOption sdocHexWordLiterals $ \case
  664                True  -> docToSDoc $ Pretty.hex n
  665                False -> docToSDoc $ Pretty.integer n
  666 
  667 -- | @doublePrec p n@ shows a floating point number @n@ with @p@
  668 -- digits of precision after the decimal point.
  669 doublePrec :: Int -> Double -> SDoc
  670 doublePrec p n = text (showFFloat (Just p) n "")
  671 
  672 parens, braces, brackets, quotes, quote,
  673         doubleQuotes, angleBrackets :: SDoc -> SDoc
  674 
  675 {-# INLINE CONLIKE parens #-}
  676 parens d        = SDoc $ Pretty.parens . runSDoc d
  677 {-# INLINE CONLIKE braces #-}
  678 braces d        = SDoc $ Pretty.braces . runSDoc d
  679 {-# INLINE CONLIKE brackets #-}
  680 brackets d      = SDoc $ Pretty.brackets . runSDoc d
  681 {-# INLINE CONLIKE quote #-}
  682 quote d         = SDoc $ Pretty.quote . runSDoc d
  683 {-# INLINE CONLIKE doubleQuotes #-}
  684 doubleQuotes d  = SDoc $ Pretty.doubleQuotes . runSDoc d
  685 {-# INLINE CONLIKE angleBrackets #-}
  686 angleBrackets d = char '<' <> d <> char '>'
  687 
  688 cparen :: Bool -> SDoc -> SDoc
  689 {-# INLINE CONLIKE cparen #-}
  690 cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d
  691 
  692 -- 'quotes' encloses something in single quotes...
  693 -- but it omits them if the thing begins or ends in a single quote
  694 -- so that we don't get `foo''.  Instead we just have foo'.
  695 quotes d = sdocOption sdocCanUseUnicode $ \case
  696    True  -> char '‘' <> d <> char '’'
  697    False -> SDoc $ \sty ->
  698       let pp_d = runSDoc d sty
  699           str  = show pp_d
  700       in case str of
  701          []                   -> Pretty.quotes pp_d
  702          '\'' : _             -> pp_d
  703          _ | '\'' <- last str -> pp_d
  704            | otherwise        -> Pretty.quotes pp_d
  705 
  706 semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
  707 arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc
  708 lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
  709 
  710 blankLine  = docToSDoc Pretty.emptyText
  711 dcolon     = unicodeSyntax (char '∷') (docToSDoc $ Pretty.text "::")
  712 arrow      = unicodeSyntax (char '→') (docToSDoc $ Pretty.text "->")
  713 lollipop   = unicodeSyntax (char '⊸') (docToSDoc $ Pretty.text "%1 ->")
  714 larrow     = unicodeSyntax (char '←') (docToSDoc $ Pretty.text "<-")
  715 darrow     = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.text "=>")
  716 arrowt     = unicodeSyntax (char '⤚') (docToSDoc $ Pretty.text ">-")
  717 larrowt    = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<")
  718 arrowtt    = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-")
  719 larrowtt   = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<")
  720 lambda     = unicodeSyntax (char 'λ') (char '\\')
  721 semi       = docToSDoc $ Pretty.semi
  722 comma      = docToSDoc $ Pretty.comma
  723 colon      = docToSDoc $ Pretty.colon
  724 equals     = docToSDoc $ Pretty.equals
  725 space      = docToSDoc $ Pretty.space
  726 underscore = char '_'
  727 dot        = char '.'
  728 vbar       = char '|'
  729 lparen     = docToSDoc $ Pretty.lparen
  730 rparen     = docToSDoc $ Pretty.rparen
  731 lbrack     = docToSDoc $ Pretty.lbrack
  732 rbrack     = docToSDoc $ Pretty.rbrack
  733 lbrace     = docToSDoc $ Pretty.lbrace
  734 rbrace     = docToSDoc $ Pretty.rbrace
  735 
  736 mulArrow :: SDoc -> SDoc
  737 mulArrow d = text "%" <> d <+> arrow
  738 
  739 
  740 forAllLit :: SDoc
  741 forAllLit = unicodeSyntax (char '∀') (text "forall")
  742 
  743 bullet :: SDoc
  744 bullet = unicode (char '•') (char '*')
  745 
  746 unicodeSyntax :: SDoc -> SDoc -> SDoc
  747 unicodeSyntax unicode plain =
  748    sdocOption sdocCanUseUnicode $ \can_use_unicode ->
  749    sdocOption sdocPrintUnicodeSyntax $ \print_unicode_syntax ->
  750     if can_use_unicode && print_unicode_syntax
  751     then unicode
  752     else plain
  753 
  754 unicode :: SDoc -> SDoc -> SDoc
  755 unicode unicode plain = sdocOption sdocCanUseUnicode $ \case
  756    True  -> unicode
  757    False -> plain
  758 
  759 nest :: Int -> SDoc -> SDoc
  760 -- ^ Indent 'SDoc' some specified amount
  761 (<>) :: SDoc -> SDoc -> SDoc
  762 -- ^ Join two 'SDoc' together horizontally without a gap
  763 (<+>) :: SDoc -> SDoc -> SDoc
  764 -- ^ Join two 'SDoc' together horizontally with a gap between them
  765 ($$) :: SDoc -> SDoc -> SDoc
  766 -- ^ Join two 'SDoc' together vertically; if there is
  767 -- no vertical overlap it "dovetails" the two onto one line
  768 ($+$) :: SDoc -> SDoc -> SDoc
  769 -- ^ Join two 'SDoc' together vertically
  770 
  771 {-# INLINE CONLIKE nest #-}
  772 nest n d    = SDoc $ Pretty.nest n . runSDoc d
  773 {-# INLINE CONLIKE (<>) #-}
  774 (<>) d1 d2  = SDoc $ \ctx -> (Pretty.<>)  (runSDoc d1 ctx) (runSDoc d2 ctx)
  775 {-# INLINE CONLIKE (<+>) #-}
  776 (<+>) d1 d2 = SDoc $ \ctx -> (Pretty.<+>) (runSDoc d1 ctx) (runSDoc d2 ctx)
  777 {-# INLINE CONLIKE ($$) #-}
  778 ($$) d1 d2  = SDoc $ \ctx -> (Pretty.$$)  (runSDoc d1 ctx) (runSDoc d2 ctx)
  779 {-# INLINE CONLIKE ($+$) #-}
  780 ($+$) d1 d2 = SDoc $ \ctx -> (Pretty.$+$) (runSDoc d1 ctx) (runSDoc d2 ctx)
  781 
  782 hcat :: [SDoc] -> SDoc
  783 -- ^ Concatenate 'SDoc' horizontally
  784 hsep :: [SDoc] -> SDoc
  785 -- ^ Concatenate 'SDoc' horizontally with a space between each one
  786 vcat :: [SDoc] -> SDoc
  787 -- ^ Concatenate 'SDoc' vertically with dovetailing
  788 sep :: [SDoc] -> SDoc
  789 -- ^ Separate: is either like 'hsep' or like 'vcat', depending on what fits
  790 cat :: [SDoc] -> SDoc
  791 -- ^ Catenate: is either like 'hcat' or like 'vcat', depending on what fits
  792 fsep :: [SDoc] -> SDoc
  793 -- ^ A paragraph-fill combinator. It's much like sep, only it
  794 -- keeps fitting things on one line until it can't fit any more.
  795 fcat :: [SDoc] -> SDoc
  796 -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
  797 
  798 
  799 -- Inline all those wrappers to help ensure we create lists of Doc, not of SDoc
  800 -- later applied to the same SDocContext. It helps the worker/wrapper
  801 -- transformation extracting only the required fields from the SDocContext.
  802 {-# INLINE CONLIKE hcat #-}
  803 hcat ds = SDoc $ \ctx -> Pretty.hcat [runSDoc d ctx | d <- ds]
  804 {-# INLINE CONLIKE hsep #-}
  805 hsep ds = SDoc $ \ctx -> Pretty.hsep [runSDoc d ctx | d <- ds]
  806 {-# INLINE CONLIKE vcat #-}
  807 vcat ds = SDoc $ \ctx -> Pretty.vcat [runSDoc d ctx | d <- ds]
  808 {-# INLINE CONLIKE sep #-}
  809 sep ds  = SDoc $ \ctx -> Pretty.sep  [runSDoc d ctx | d <- ds]
  810 {-# INLINE CONLIKE cat #-}
  811 cat ds  = SDoc $ \ctx -> Pretty.cat  [runSDoc d ctx | d <- ds]
  812 {-# INLINE CONLIKE fsep #-}
  813 fsep ds = SDoc $ \ctx -> Pretty.fsep [runSDoc d ctx | d <- ds]
  814 {-# INLINE CONLIKE fcat #-}
  815 fcat ds = SDoc $ \ctx -> Pretty.fcat [runSDoc d ctx | d <- ds]
  816 
  817 hang :: SDoc  -- ^ The header
  818       -> Int  -- ^ Amount to indent the hung body
  819       -> SDoc -- ^ The hung body, indented and placed below the header
  820       -> SDoc
  821 {-# INLINE CONLIKE hang #-}
  822 hang d1 n d2   = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
  823 
  824 -- | This behaves like 'hang', but does not indent the second document
  825 -- when the header is empty.
  826 hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc
  827 {-# INLINE CONLIKE hangNotEmpty #-}
  828 hangNotEmpty d1 n d2 =
  829     SDoc $ \ctx -> Pretty.hangNotEmpty (runSDoc d1 ctx) n (runSDoc d2 ctx)
  830 
  831 punctuate :: SDoc   -- ^ The punctuation
  832           -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
  833           -> [SDoc] -- ^ Punctuated list
  834 punctuate _ []     = []
  835 punctuate p (d:ds) = go d ds
  836                    where
  837                      go d [] = [d]
  838                      go d (e:es) = (d <> p) : go e es
  839 
  840 ppWhen, ppUnless :: Bool -> SDoc -> SDoc
  841 {-# INLINE CONLIKE ppWhen #-}
  842 ppWhen True  doc = doc
  843 ppWhen False _   = empty
  844 
  845 {-# INLINE CONLIKE ppUnless #-}
  846 ppUnless True  _   = empty
  847 ppUnless False doc = doc
  848 
  849 {-# INLINE CONLIKE ppWhenOption #-}
  850 ppWhenOption :: (SDocContext -> Bool) -> SDoc -> SDoc
  851 ppWhenOption f doc = sdocOption f $ \case
  852    True  -> doc
  853    False -> empty
  854 
  855 {-# INLINE CONLIKE ppUnlessOption #-}
  856 ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc
  857 ppUnlessOption f doc = sdocOption f $ \case
  858    True  -> empty
  859    False -> doc
  860 
  861 -- | Apply the given colour\/style for the argument.
  862 --
  863 -- Only takes effect if colours are enabled.
  864 coloured :: Col.PprColour -> SDoc -> SDoc
  865 coloured col sdoc = sdocOption sdocShouldUseColor $ \case
  866    True -> SDoc $ \case
  867       ctx@SDC{ sdocLastColour = lastCol, sdocStyle = PprUser _ _ Coloured } ->
  868          let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in
  869          Pretty.zeroWidthText (Col.renderColour col)
  870            Pretty.<> runSDoc sdoc ctx'
  871            Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol)
  872       ctx -> runSDoc sdoc ctx
  873    False -> sdoc
  874 
  875 keyword :: SDoc -> SDoc
  876 keyword = coloured Col.colBold
  877 
  878 -----------------------------------------------------------------------
  879 -- The @Outputable@ class
  880 -----------------------------------------------------------------------
  881 
  882 -- | Class designating that some type has an 'SDoc' representation
  883 class Outputable a where
  884     ppr :: a -> SDoc
  885 
  886 instance Outputable Char where
  887     ppr c = text [c]
  888 
  889 instance Outputable Bool where
  890     ppr True  = text "True"
  891     ppr False = text "False"
  892 
  893 instance Outputable Ordering where
  894     ppr LT = text "LT"
  895     ppr EQ = text "EQ"
  896     ppr GT = text "GT"
  897 
  898 instance Outputable Int32 where
  899    ppr n = integer $ fromIntegral n
  900 
  901 instance Outputable Int64 where
  902    ppr n = integer $ fromIntegral n
  903 
  904 instance Outputable Int where
  905     ppr n = int n
  906 
  907 instance Outputable Integer where
  908     ppr n = integer n
  909 
  910 instance Outputable Word16 where
  911     ppr n = integer $ fromIntegral n
  912 
  913 instance Outputable Word32 where
  914     ppr n = integer $ fromIntegral n
  915 
  916 instance Outputable Word64 where
  917     ppr n = integer $ fromIntegral n
  918 
  919 instance Outputable Word where
  920     ppr n = integer $ fromIntegral n
  921 
  922 instance Outputable Float where
  923     ppr f = float f
  924 
  925 instance Outputable Double where
  926     ppr f = double f
  927 
  928 instance Outputable () where
  929     ppr _ = text "()"
  930 
  931 instance Outputable UTCTime where
  932     ppr = text . formatShow iso8601Format
  933 
  934 instance (Outputable a) => Outputable [a] where
  935     ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
  936 
  937 instance (Outputable a) => Outputable (NonEmpty a) where
  938     ppr = ppr . NEL.toList
  939 
  940 instance (Outputable a) => Outputable (Set a) where
  941     ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))
  942 
  943 instance Outputable IntSet.IntSet where
  944     ppr s = braces (fsep (punctuate comma (map ppr (IntSet.toList s))))
  945 
  946 instance (Outputable a, Outputable b) => Outputable (a, b) where
  947     ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
  948 
  949 instance Outputable a => Outputable (Maybe a) where
  950     ppr Nothing  = text "Nothing"
  951     ppr (Just x) = text "Just" <+> ppr x
  952 
  953 instance (Outputable a, Outputable b) => Outputable (Either a b) where
  954     ppr (Left x)  = text "Left"  <+> ppr x
  955     ppr (Right y) = text "Right" <+> ppr y
  956 
  957 -- ToDo: may not be used
  958 instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
  959     ppr (x,y,z) =
  960       parens (sep [ppr x <> comma,
  961                    ppr y <> comma,
  962                    ppr z ])
  963 
  964 instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
  965          Outputable (a, b, c, d) where
  966     ppr (a,b,c,d) =
  967       parens (sep [ppr a <> comma,
  968                    ppr b <> comma,
  969                    ppr c <> comma,
  970                    ppr d])
  971 
  972 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
  973          Outputable (a, b, c, d, e) where
  974     ppr (a,b,c,d,e) =
  975       parens (sep [ppr a <> comma,
  976                    ppr b <> comma,
  977                    ppr c <> comma,
  978                    ppr d <> comma,
  979                    ppr e])
  980 
  981 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) =>
  982          Outputable (a, b, c, d, e, f) where
  983     ppr (a,b,c,d,e,f) =
  984       parens (sep [ppr a <> comma,
  985                    ppr b <> comma,
  986                    ppr c <> comma,
  987                    ppr d <> comma,
  988                    ppr e <> comma,
  989                    ppr f])
  990 
  991 instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) =>
  992          Outputable (a, b, c, d, e, f, g) where
  993     ppr (a,b,c,d,e,f,g) =
  994       parens (sep [ppr a <> comma,
  995                    ppr b <> comma,
  996                    ppr c <> comma,
  997                    ppr d <> comma,
  998                    ppr e <> comma,
  999                    ppr f <> comma,
 1000                    ppr g])
 1001 
 1002 instance Outputable FastString where
 1003     ppr fs = ftext fs           -- Prints an unadorned string,
 1004                                 -- no double quotes or anything
 1005 
 1006 deriving newtype instance Outputable NonDetFastString
 1007 deriving newtype instance Outputable LexicalFastString
 1008 
 1009 instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
 1010     ppr m = ppr (M.toList m)
 1011 
 1012 instance (Outputable elt) => Outputable (IM.IntMap elt) where
 1013     ppr m = ppr (IM.toList m)
 1014 
 1015 instance Outputable Fingerprint where
 1016     ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2)
 1017 
 1018 instance Outputable a => Outputable (SCC a) where
 1019    ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v))
 1020    ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs)))
 1021 
 1022 instance Outputable Serialized where
 1023     ppr (Serialized the_type bytes) = int (length bytes) <+> text "of type" <+> text (show the_type)
 1024 
 1025 instance Outputable Extension where
 1026     ppr = text . show
 1027 
 1028 -----------------------------------------------------------------------
 1029 -- The @OutputableP@ class
 1030 -----------------------------------------------------------------------
 1031 
 1032 -- Note [The OutputableP class]
 1033 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1034 --
 1035 -- SDoc has become the common type to
 1036 --    * display messages in the terminal
 1037 --    * dump outputs (Cmm, Asm, C, etc.)
 1038 --    * return messages to ghc-api clients
 1039 --
 1040 -- SDoc is a kind of state Monad: SDoc ~ State SDocContext Doc
 1041 -- I.e. to render a SDoc, a SDocContext must be provided.
 1042 --
 1043 -- SDocContext contains legit rendering options (e.g., line length, color and
 1044 -- unicode settings). Sadly SDocContext ended up also being used to thread
 1045 -- values that were considered bothersome to thread otherwise:
 1046 --    * current HomeModule: to decide if module names must be printed qualified
 1047 --    * current UnitState: to print unit-ids as "packagename-version:component"
 1048 --    * target platform: to render labels, instructions, etc.
 1049 --    * selected backend: to display CLabel as C labels or Asm labels
 1050 --
 1051 -- In fact the whole compiler session state that is DynFlags was passed in
 1052 -- SDocContext and these values were retrieved from it.
 1053 --
 1054 -- The Outputable class makes SDoc creation easy for many values by providing
 1055 -- the ppr method:
 1056 --
 1057 --    class Outputable a where
 1058 --       ppr :: a -> SDoc
 1059 --
 1060 -- Almost every type is Outputable in the compiler and it seems great because it
 1061 -- is similar to the Show class. But it's a fallacious simplicity because `SDoc`
 1062 -- needs a `SDocContext` to be transformed into a renderable `Doc`: who is going
 1063 -- to provide the SDocContext with the correct values in it?
 1064 --
 1065 --    E.g. if a SDoc is returned in an exception, how could we know the home
 1066 --    module at the time it was thrown?
 1067 --
 1068 -- A workaround is to pass dummy values (no home module, empty UnitState) at SDoc
 1069 -- rendering time and to hope that the code that produced the SDoc has updated
 1070 -- the SDocContext with meaningful values (e.g. using withPprStyle or
 1071 -- pprWithUnitState). If the context isn't correctly updated, a dummy value is
 1072 -- used and the printed result isn't what we expected. Note that the compiler
 1073 -- doesn't help us finding spots where we need to update the SDocContext.
 1074 --
 1075 -- In some cases we can't pass a dummy value because we can't create one. For
 1076 -- example, how can we create a dummy Platform value? In the old days, GHC only
 1077 -- supported a single Platform set when it was built, so we could use it without
 1078 -- any risk of mistake. But now GHC starts supporting several Platform in the
 1079 -- same session so it becomes an issue. We could be tempted to use the
 1080 -- workaround described above by using "undefined" as a dummy Platform value.
 1081 -- However in this case, if we forget to update it we will get a runtime
 1082 -- error/crash. We could use "Maybe Platform" and die with a better error
 1083 -- message at places where we really really need to know if we are on Windows or
 1084 -- not, or if we use 32- or 64-bit. Still the compiler would not help us in
 1085 -- finding spots where to update the context with a valid Platform.
 1086 --
 1087 -- So finally here comes the OutputableP class:
 1088 --
 1089 --    class OutputableP env a where
 1090 --       pdoc :: env -> a -> SDoc
 1091 --
 1092 -- OutputableP forces us to thread an environment necessary to print a value.
 1093 -- For now we only use it to thread a Platform environment, so we have several
 1094 -- "Outputable Platform XYZ" instances. In the future we could imagine using a
 1095 -- Has class to retrieve a value from a generic environment to make the code
 1096 -- more composable. E.g.:
 1097 --
 1098 --    instance Has Platform env => OutputableP env XYZ where
 1099 --       pdoc env a = ... (getter env :: Platform)
 1100 --
 1101 -- A drawback of this approach over Outputable is that we have to thread an
 1102 -- environment explicitly to use "pdoc" and it's more cumbersome. But it's the
 1103 -- price to pay to have some help from the compiler to ensure that we... thread
 1104 -- an environment down to the places where we need it, i.e. where SDoc are
 1105 -- created (not rendered). On the other hand, it makes life easier for SDoc
 1106 -- renderers as they only have to deal with pretty-printing related options in
 1107 -- SDocContext.
 1108 --
 1109 -- TODO:
 1110 --
 1111 -- 1) we could use OutputableP to thread a UnitState and replace the Outputable
 1112 -- instance of UnitId with:
 1113 --
 1114 --       instance OutputableP UnitState UnitId where ...
 1115 --
 1116 --    This would allow the removal of the `sdocUnitIdForUser` field.
 1117 --
 1118 --    Be warned: I've tried to do it, but there are A LOT of other Outputable
 1119 --    instances depending on UnitId's one. In particular:
 1120 --       UnitId <- Unit <- Module <- Name <- Var <- Core.{Type,Expr} <- ...
 1121 --
 1122 -- 2) Use it to pass the HomeModule (but I fear it will be as difficult as for
 1123 -- UnitId).
 1124 --
 1125 --
 1126 
 1127 -- | Outputable class with an additional environment value
 1128 --
 1129 -- See Note [The OutputableP class]
 1130 class OutputableP env a where
 1131    pdoc :: env -> a -> SDoc
 1132 
 1133 -- | Wrapper for types having a Outputable instance when an OutputableP instance
 1134 -- is required.
 1135 newtype PDoc a = PDoc a
 1136 
 1137 instance Outputable a => OutputableP env (PDoc a) where
 1138    pdoc _ (PDoc a) = ppr a
 1139 
 1140 instance OutputableP env a => OutputableP env [a] where
 1141    pdoc env xs = ppr (fmap (pdoc env) xs)
 1142 
 1143 instance OutputableP env a => OutputableP env (Maybe a) where
 1144    pdoc env xs = ppr (fmap (pdoc env) xs)
 1145 
 1146 instance (OutputableP env a, OutputableP env b) => OutputableP env (a, b) where
 1147     pdoc env (a,b) = ppr (pdoc env a, pdoc env b)
 1148 
 1149 instance (OutputableP env a, OutputableP env b, OutputableP env c) => OutputableP env (a, b, c) where
 1150     pdoc env (a,b,c) = ppr (pdoc env a, pdoc env b, pdoc env c)
 1151 
 1152 
 1153 instance (OutputableP env key, OutputableP env elt) => OutputableP env (M.Map key elt) where
 1154     pdoc env m = ppr $ fmap (\(x,y) -> (pdoc env x, pdoc env y)) $ M.toList m
 1155 
 1156 instance OutputableP env a => OutputableP env (SCC a) where
 1157    pdoc env scc = ppr (fmap (pdoc env) scc)
 1158 
 1159 instance OutputableP env SDoc where
 1160    pdoc _ x = x
 1161 
 1162 instance (OutputableP env a) => OutputableP env (Set a) where
 1163     pdoc env s = braces (fsep (punctuate comma (map (pdoc env) (Set.toList s))))
 1164 
 1165 
 1166 {-
 1167 ************************************************************************
 1168 *                                                                      *
 1169 \subsection{The @OutputableBndr@ class}
 1170 *                                                                      *
 1171 ************************************************************************
 1172 -}
 1173 
 1174 -- | 'BindingSite' is used to tell the thing that prints binder what
 1175 -- language construct is binding the identifier.  This can be used
 1176 -- to decide how much info to print.
 1177 -- Also see Note [Binding-site specific printing] in "GHC.Core.Ppr"
 1178 data BindingSite
 1179     = LambdaBind  -- ^ The x in   (\x. e)
 1180     | CaseBind    -- ^ The x in   case scrut of x { (y,z) -> ... }
 1181     | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... }
 1182     | LetBind     -- ^ The x in   (let x = rhs in e)
 1183 
 1184 -- | When we print a binder, we often want to print its type too.
 1185 -- The @OutputableBndr@ class encapsulates this idea.
 1186 class Outputable a => OutputableBndr a where
 1187    pprBndr :: BindingSite -> a -> SDoc
 1188    pprBndr _b x = ppr x
 1189 
 1190    pprPrefixOcc, pprInfixOcc :: a -> SDoc
 1191       -- Print an occurrence of the name, suitable either in the
 1192       -- prefix position of an application, thus   (f a b) or  ((+) x)
 1193       -- or infix position,                 thus   (a `f` b) or  (x + y)
 1194 
 1195    bndrIsJoin_maybe :: a -> Maybe Int
 1196    bndrIsJoin_maybe _ = Nothing
 1197       -- When pretty-printing we sometimes want to find
 1198       -- whether the binder is a join point.  You might think
 1199       -- we could have a function of type (a->Var), but Var
 1200       -- isn't available yet, alas
 1201 
 1202 {-
 1203 ************************************************************************
 1204 *                                                                      *
 1205 \subsection{Random printing helpers}
 1206 *                                                                      *
 1207 ************************************************************************
 1208 -}
 1209 
 1210 -- We have 31-bit Chars and will simply use Show instances of Char and String.
 1211 
 1212 -- | Special combinator for showing character literals.
 1213 pprHsChar :: Char -> SDoc
 1214 pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
 1215             | otherwise      = text (show c)
 1216 
 1217 -- | Special combinator for showing string literals.
 1218 pprHsString :: FastString -> SDoc
 1219 pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
 1220 
 1221 -- | Special combinator for showing bytestring literals.
 1222 pprHsBytes :: ByteString -> SDoc
 1223 pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs
 1224                 in vcat (map text (showMultiLineString escaped)) <> char '#'
 1225     where escape :: Word8 -> String
 1226           escape w = let c = chr (fromIntegral w)
 1227                      in if isAscii c
 1228                         then [c]
 1229                         else '\\' : show w
 1230 
 1231 -- Postfix modifiers for unboxed literals.
 1232 -- See Note [Printing of literals in Core] in "GHC.Types.Literal".
 1233 primCharSuffix, primFloatSuffix, primDoubleSuffix,
 1234   primIntSuffix, primWordSuffix,
 1235   primInt8Suffix, primWord8Suffix,
 1236   primInt16Suffix, primWord16Suffix,
 1237   primInt32Suffix, primWord32Suffix,
 1238   primInt64Suffix, primWord64Suffix
 1239   :: SDoc
 1240 primCharSuffix   = char '#'
 1241 primFloatSuffix  = char '#'
 1242 primIntSuffix    = char '#'
 1243 primDoubleSuffix = text "##"
 1244 primWordSuffix   = text "##"
 1245 primInt8Suffix   = text "#8"
 1246 primWord8Suffix  = text "##8"
 1247 primInt16Suffix  = text "#16"
 1248 primWord16Suffix = text "##16"
 1249 primInt32Suffix  = text "#32"
 1250 primWord32Suffix = text "##32"
 1251 primInt64Suffix  = text "#64"
 1252 primWord64Suffix = text "##64"
 1253 
 1254 -- | Special combinator for showing unboxed literals.
 1255 pprPrimChar :: Char -> SDoc
 1256 pprPrimInt, pprPrimWord,
 1257   pprPrimInt8, pprPrimWord8,
 1258   pprPrimInt16, pprPrimWord16,
 1259   pprPrimInt32, pprPrimWord32,
 1260   pprPrimInt64, pprPrimWord64
 1261   :: Integer -> SDoc
 1262 pprPrimChar c   = pprHsChar c <> primCharSuffix
 1263 pprPrimInt i    = integer i   <> primIntSuffix
 1264 pprPrimWord w   = word    w   <> primWordSuffix
 1265 pprPrimInt8 i   = integer i   <> primInt8Suffix
 1266 pprPrimInt16 i  = integer i   <> primInt16Suffix
 1267 pprPrimInt32 i  = integer i   <> primInt32Suffix
 1268 pprPrimInt64 i  = integer i   <> primInt64Suffix
 1269 pprPrimWord8 w  = word    w   <> primWord8Suffix
 1270 pprPrimWord16 w = word    w   <> primWord16Suffix
 1271 pprPrimWord32 w = word    w   <> primWord32Suffix
 1272 pprPrimWord64 w = word    w   <> primWord64Suffix
 1273 
 1274 ---------------------
 1275 -- Put a name in parens if it's an operator
 1276 pprPrefixVar :: Bool -> SDoc -> SDoc
 1277 pprPrefixVar is_operator pp_v
 1278   | is_operator = parens pp_v
 1279   | otherwise   = pp_v
 1280 
 1281 -- Put a name in backquotes if it's not an operator
 1282 pprInfixVar :: Bool -> SDoc -> SDoc
 1283 pprInfixVar is_operator pp_v
 1284   | is_operator = pp_v
 1285   | otherwise   = char '`' <> pp_v <> char '`'
 1286 
 1287 ---------------------
 1288 pprFastFilePath :: FastString -> SDoc
 1289 pprFastFilePath path = text $ normalise $ unpackFS path
 1290 
 1291 -- | Normalise, escape and render a string representing a path
 1292 --
 1293 -- e.g. "c:\\whatever"
 1294 pprFilePathString :: FilePath -> SDoc
 1295 pprFilePathString path = doubleQuotes $ text (escape (normalise path))
 1296    where
 1297       escape []        = []
 1298       escape ('\\':xs) = '\\':'\\':escape xs
 1299       escape (x:xs)    = x:escape xs
 1300 
 1301 {-
 1302 ************************************************************************
 1303 *                                                                      *
 1304 \subsection{Other helper functions}
 1305 *                                                                      *
 1306 ************************************************************************
 1307 -}
 1308 
 1309 pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
 1310               -> [a]         -- ^ The things to be pretty printed
 1311               -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,
 1312                              -- comma-separated and finally packed into a paragraph.
 1313 pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
 1314 
 1315 pprWithBars :: (a -> SDoc) -- ^ The pretty printing function to use
 1316             -> [a]         -- ^ The things to be pretty printed
 1317             -> SDoc        -- ^ 'SDoc' where the things have been pretty printed,
 1318                            -- bar-separated and finally packed into a paragraph.
 1319 pprWithBars pp xs = fsep (intersperse vbar (map pp xs))
 1320 
 1321 -- | Returns the separated concatenation of the pretty printed things.
 1322 interppSP  :: Outputable a => [a] -> SDoc
 1323 interppSP  xs = sep (map ppr xs)
 1324 
 1325 -- | Returns the comma-separated concatenation of the pretty printed things.
 1326 interpp'SP :: Outputable a => [a] -> SDoc
 1327 interpp'SP xs = interpp'SP' ppr xs
 1328 
 1329 interpp'SP' :: (a -> SDoc) -> [a] -> SDoc
 1330 interpp'SP' f xs = sep (punctuate comma (map f xs))
 1331 
 1332 -- | Returns the comma-separated concatenation of the quoted pretty printed things.
 1333 --
 1334 -- > [x,y,z]  ==>  `x', `y', `z'
 1335 pprQuotedList :: Outputable a => [a] -> SDoc
 1336 pprQuotedList = quotedList . map ppr
 1337 
 1338 quotedList :: [SDoc] -> SDoc
 1339 quotedList xs = fsep (punctuate comma (map quotes xs))
 1340 
 1341 quotedListWithOr :: [SDoc] -> SDoc
 1342 -- [x,y,z]  ==>  `x', `y' or `z'
 1343 quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> text "or" <+> quotes (last xs)
 1344 quotedListWithOr xs = quotedList xs
 1345 
 1346 quotedListWithNor :: [SDoc] -> SDoc
 1347 -- [x,y,z]  ==>  `x', `y' nor `z'
 1348 quotedListWithNor xs@(_:_:_) = quotedList (init xs) <+> text "nor" <+> quotes (last xs)
 1349 quotedListWithNor xs = quotedList xs
 1350 
 1351 {-
 1352 ************************************************************************
 1353 *                                                                      *
 1354 \subsection{Printing numbers verbally}
 1355 *                                                                      *
 1356 ************************************************************************
 1357 -}
 1358 
 1359 intWithCommas :: Integral a => a -> SDoc
 1360 -- Prints a big integer with commas, eg 345,821
 1361 intWithCommas n
 1362   | n < 0     = char '-' <> intWithCommas (-n)
 1363   | q == 0    = int (fromIntegral r)
 1364   | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r)
 1365   where
 1366     (q,r) = n `quotRem` 1000
 1367     zeroes | r >= 100  = empty
 1368            | r >= 10   = char '0'
 1369            | otherwise = text "00"
 1370 
 1371 -- | Converts an integer to a verbal index:
 1372 --
 1373 -- > speakNth 1 = text "first"
 1374 -- > speakNth 5 = text "fifth"
 1375 -- > speakNth 21 = text "21st"
 1376 speakNth :: Int -> SDoc
 1377 speakNth 1 = text "first"
 1378 speakNth 2 = text "second"
 1379 speakNth 3 = text "third"
 1380 speakNth 4 = text "fourth"
 1381 speakNth 5 = text "fifth"
 1382 speakNth 6 = text "sixth"
 1383 speakNth n = hcat [ int n, text suffix ]
 1384   where
 1385     suffix | n <= 20       = "th"       -- 11,12,13 are non-std
 1386            | last_dig == 1 = "st"
 1387            | last_dig == 2 = "nd"
 1388            | last_dig == 3 = "rd"
 1389            | otherwise     = "th"
 1390 
 1391     last_dig = n `rem` 10
 1392 
 1393 -- | Converts an integer to a verbal multiplicity:
 1394 --
 1395 -- > speakN 0 = text "none"
 1396 -- > speakN 5 = text "five"
 1397 -- > speakN 10 = text "10"
 1398 speakN :: Int -> SDoc
 1399 speakN 0 = text "none"  -- E.g.  "they have none"
 1400 speakN 1 = text "one"   -- E.g.  "they have one"
 1401 speakN 2 = text "two"
 1402 speakN 3 = text "three"
 1403 speakN 4 = text "four"
 1404 speakN 5 = text "five"
 1405 speakN 6 = text "six"
 1406 speakN n = int n
 1407 
 1408 -- | Converts an integer and object description to a statement about the
 1409 -- multiplicity of those objects:
 1410 --
 1411 -- > speakNOf 0 (text "melon") = text "no melons"
 1412 -- > speakNOf 1 (text "melon") = text "one melon"
 1413 -- > speakNOf 3 (text "melon") = text "three melons"
 1414 speakNOf :: Int -> SDoc -> SDoc
 1415 speakNOf 0 d = text "no" <+> d <> char 's'
 1416 speakNOf 1 d = text "one" <+> d                 -- E.g. "one argument"
 1417 speakNOf n d = speakN n <+> d <> char 's'               -- E.g. "three arguments"
 1418 
 1419 -- | Determines the pluralisation suffix appropriate for the length of a list:
 1420 --
 1421 -- > plural [] = char 's'
 1422 -- > plural ["Hello"] = empty
 1423 -- > plural ["Hello", "World"] = char 's'
 1424 plural :: [a] -> SDoc
 1425 plural [_] = empty  -- a bit frightening, but there you are
 1426 plural _   = char 's'
 1427 
 1428 -- | Determines the singular verb suffix appropriate for the length of a list:
 1429 --
 1430 -- > singular [] = empty
 1431 -- > singular["Hello"] = char 's'
 1432 -- > singular ["Hello", "World"] = empty
 1433 singular :: [a] -> SDoc
 1434 singular [_] = char 's'
 1435 singular _   = empty
 1436 
 1437 -- | Determines the form of to be appropriate for the length of a list:
 1438 --
 1439 -- > isOrAre [] = text "are"
 1440 -- > isOrAre ["Hello"] = text "is"
 1441 -- > isOrAre ["Hello", "World"] = text "are"
 1442 isOrAre :: [a] -> SDoc
 1443 isOrAre [_] = text "is"
 1444 isOrAre _   = text "are"
 1445 
 1446 -- | Determines the form of to do appropriate for the length of a list:
 1447 --
 1448 -- > doOrDoes [] = text "do"
 1449 -- > doOrDoes ["Hello"] = text "does"
 1450 -- > doOrDoes ["Hello", "World"] = text "do"
 1451 doOrDoes :: [a] -> SDoc
 1452 doOrDoes [_] = text "does"
 1453 doOrDoes _   = text "do"
 1454 
 1455 -- | Determines the form of possessive appropriate for the length of a list:
 1456 --
 1457 -- > itsOrTheir [x]   = text "its"
 1458 -- > itsOrTheir [x,y] = text "their"
 1459 -- > itsOrTheir []    = text "their"  -- probably avoid this
 1460 itsOrTheir :: [a] -> SDoc
 1461 itsOrTheir [_] = text "its"
 1462 itsOrTheir _   = text "their"
 1463 
 1464 
 1465 -- | Determines the form of subject appropriate for the length of a list:
 1466 --
 1467 -- > thisOrThese [x]   = text "This"
 1468 -- > thisOrThese [x,y] = text "These"
 1469 -- > thisOrThese []    = text "These"  -- probably avoid this
 1470 thisOrThese :: [a] -> SDoc
 1471 thisOrThese [_] = text "This"
 1472 thisOrThese _   = text "These"