summaryrefslogtreecommitdiff
path: root/compiler/utils/Outputable.lhs
diff options
context:
space:
mode:
authorAustin Seipp <austin@well-typed.com>2014-12-03 12:44:03 -0600
committerAustin Seipp <austin@well-typed.com>2014-12-03 12:44:03 -0600
commit0c48e172836d6a1e281aed63e42d60063700e6d8 (patch)
tree89fe135e31e86dc579aba5652738f14c256a284d /compiler/utils/Outputable.lhs
parentb04296d3a3a256067787241a7727877e35e5af03 (diff)
downloadhaskell-0c48e172836d6a1e281aed63e42d60063700e6d8.tar.gz
compiler: de-lhs utils/
Signed-off-by: Austin Seipp <austin@well-typed.com>
Diffstat (limited to 'compiler/utils/Outputable.lhs')
-rw-r--r--compiler/utils/Outputable.lhs1047
1 files changed, 0 insertions, 1047 deletions
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
deleted file mode 100644
index a4ba48c609..0000000000
--- a/compiler/utils/Outputable.lhs
+++ /dev/null
@@ -1,1047 +0,0 @@
-%
-% (c) The University of Glasgow 2006-2012
-% (c) The GRASP Project, Glasgow University, 1992-1998
-%
-
-\begin{code}
--- | This module defines classes and functions for pretty-printing. It also
--- exports a number of helpful debugging and other utilities such as 'trace' and 'panic'.
---
--- The interface to this module is very similar to the standard Hughes-PJ pretty printing
--- module, except that it exports a number of additional functions that are rarely used,
--- and works over the 'SDoc' type.
-module Outputable (
- -- * Type classes
- Outputable(..), OutputableBndr(..),
-
- -- * Pretty printing combinators
- SDoc, runSDoc, initSDocContext,
- docToSDoc,
- interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
- empty, nest,
- char,
- text, ftext, ptext, ztext,
- int, intWithCommas, integer, float, double, rational,
- parens, cparen, brackets, braces, quotes, quote,
- doubleQuotes, angleBrackets, paBrackets,
- semi, comma, colon, dcolon, space, equals, dot,
- arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,
- lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
- blankLine, forAllLit,
- (<>), (<+>), hcat, hsep,
- ($$), ($+$), vcat,
- sep, cat,
- fsep, fcat,
- hang, punctuate, ppWhen, ppUnless,
- speakNth, speakNTimes, speakN, speakNOf, plural, isOrAre,
-
- coloured, PprColour, colType, colCoerc, colDataCon,
- colBinder, bold, keyword,
-
- -- * Converting 'SDoc' into strings and outputing it
- printForC, printForAsm, printForUser, printForUserPartWay,
- pprCode, mkCodeStyle,
- showSDoc, showSDocSimple, showSDocOneLine,
- showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
- showSDocUnqual, showPpr,
- renderWithStyle,
-
- pprInfixVar, pprPrefixVar,
- pprHsChar, pprHsString, pprHsBytes,
- pprFastFilePath,
-
- -- * Controlling the style in which output is printed
- BindingSite(..),
-
- PprStyle, CodeStyle(..), PrintUnqualified(..),
- QueryQualifyName, QueryQualifyModule, QueryQualifyPackage,
- reallyAlwaysQualify, reallyAlwaysQualifyNames,
- alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,
- neverQualify, neverQualifyNames, neverQualifyModules,
- QualifyName(..), queryQual,
- sdocWithDynFlags, sdocWithPlatform,
- getPprStyle, withPprStyle, withPprStyleDoc,
- pprDeeper, pprDeeperList, pprSetDepth,
- codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
- ifPprDebug, qualName, qualModule, qualPackage,
- mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle,
- mkUserStyle, cmdlineParserStyle, Depth(..),
-
- -- * Error handling and debugging utilities
- pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError,
- pprTrace, warnPprTrace,
- trace, pgmError, panic, sorry, panicFastInt, assertPanic,
- pprDebugAndThen,
- ) where
-
-import {-# SOURCE #-} DynFlags( DynFlags,
- targetPlatform, pprUserLength, pprCols,
- useUnicode, useUnicodeSyntax,
- unsafeGlobalDynFlags )
-import {-# SOURCE #-} Module( PackageKey, Module, ModuleName, moduleName )
-import {-# SOURCE #-} OccName( OccName )
-import {-# SOURCE #-} StaticFlags( opt_PprStyle_Debug, opt_NoDebugOutput )
-
-import FastString
-import FastTypes
-import qualified Pretty
-import Util
-import Platform
-import Pretty ( Doc, Mode(..) )
-import Panic
-
-import Data.ByteString (ByteString)
-import qualified Data.ByteString as BS
-import Data.Char
-import qualified Data.Map as M
-import Data.Int
-import qualified Data.IntMap as IM
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.Word
-import System.IO ( Handle )
-import System.FilePath
-import Text.Printf
-
-import GHC.Fingerprint
-import GHC.Show ( showMultiLineString )
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{The @PprStyle@ data type}
-%* *
-%************************************************************************
-
-\begin{code}
-
-data PprStyle
- = PprUser PrintUnqualified Depth
- -- Pretty-print in a way that will make sense to the
- -- ordinary user; must be very close to Haskell
- -- syntax, etc.
- -- Assumes printing tidied code: non-system names are
- -- printed without uniques.
-
- | PprDump PrintUnqualified
- -- For -ddump-foo; less verbose than PprDebug, but more than PprUser
- -- Does not assume tidied code: non-external names
- -- are printed with uniques.
-
- | PprDebug -- Full debugging output
-
- | PprCode CodeStyle
- -- Print code; either C or assembler
-
-data CodeStyle = CStyle -- The format of labels differs for C and assembler
- | AsmStyle
-
-data Depth = AllTheWay
- | PartWay Int -- 0 => stop
-
-
--- -----------------------------------------------------------------------------
--- Printing original names
-
--- | When printing code that contains original names, we need to map the
--- original names back to something the user understands. This is the
--- purpose of the triple of functions that gets passed around
--- when rendering 'SDoc'.
-data PrintUnqualified = QueryQualify {
- queryQualifyName :: QueryQualifyName,
- queryQualifyModule :: QueryQualifyModule,
- queryQualifyPackage :: QueryQualifyPackage
-}
-
--- | given an /original/ name, this function tells you which module
--- name it should be qualified with when printing for the user, if
--- any. For example, given @Control.Exception.catch@, which is in scope
--- as @Exception.catch@, this fuction will return @Just "Exception"@.
--- Note that the return value is a ModuleName, not a Module, because
--- in source code, names are qualified by ModuleNames.
-type QueryQualifyName = Module -> OccName -> QualifyName
-
--- | For a given module, we need to know whether to print it with
--- a package name to disambiguate it.
-type QueryQualifyModule = Module -> Bool
-
--- | For a given package, we need to know whether to print it with
--- the package key to disambiguate it.
-type QueryQualifyPackage = PackageKey -> Bool
-
--- See Note [Printing original names] in HscTypes
-data QualifyName -- given P:M.T
- = NameUnqual -- refer to it as "T"
- | NameQual ModuleName -- refer to it as "X.T" for the supplied X
- | NameNotInScope1
- -- it is not in scope at all, but M.T is not bound in the current
- -- scope, so we can refer to it as "M.T"
- | NameNotInScope2
- -- it is not in scope at all, and M.T is already bound in the
- -- current scope, so we must refer to it as "P:M.T"
-
-reallyAlwaysQualifyNames :: QueryQualifyName
-reallyAlwaysQualifyNames _ _ = NameNotInScope2
-
--- | NB: This won't ever show package IDs
-alwaysQualifyNames :: QueryQualifyName
-alwaysQualifyNames m _ = NameQual (moduleName m)
-
-neverQualifyNames :: QueryQualifyName
-neverQualifyNames _ _ = NameUnqual
-
-alwaysQualifyModules :: QueryQualifyModule
-alwaysQualifyModules _ = True
-
-neverQualifyModules :: QueryQualifyModule
-neverQualifyModules _ = False
-
-alwaysQualifyPackages :: QueryQualifyPackage
-alwaysQualifyPackages _ = True
-
-neverQualifyPackages :: QueryQualifyPackage
-neverQualifyPackages _ = False
-
-reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified
-reallyAlwaysQualify
- = QueryQualify reallyAlwaysQualifyNames
- alwaysQualifyModules
- alwaysQualifyPackages
-alwaysQualify = QueryQualify alwaysQualifyNames
- alwaysQualifyModules
- alwaysQualifyPackages
-neverQualify = QueryQualify neverQualifyNames
- neverQualifyModules
- neverQualifyPackages
-
-defaultUserStyle, defaultDumpStyle :: PprStyle
-
-defaultUserStyle = mkUserStyle neverQualify AllTheWay
- -- Print without qualifiers to reduce verbosity, unless -dppr-debug
-
-defaultDumpStyle | opt_PprStyle_Debug = PprDebug
- | otherwise = PprDump neverQualify
-
-mkDumpStyle :: PrintUnqualified -> PprStyle
-mkDumpStyle print_unqual | opt_PprStyle_Debug = PprDebug
- | otherwise = PprDump print_unqual
-
-defaultErrStyle :: DynFlags -> PprStyle
--- Default style for error messages, when we don't know PrintUnqualified
--- It's a bit of a hack because it doesn't take into account what's in scope
--- Only used for desugarer warnings, and typechecker errors in interface sigs
--- NB that -dppr-debug will still get into PprDebug style
-defaultErrStyle dflags = mkErrStyle dflags neverQualify
-
--- | Style for printing error messages
-mkErrStyle :: DynFlags -> PrintUnqualified -> PprStyle
-mkErrStyle dflags qual = mkUserStyle qual (PartWay (pprUserLength dflags))
-
-cmdlineParserStyle :: PprStyle
-cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay
-
-mkUserStyle :: PrintUnqualified -> Depth -> PprStyle
-mkUserStyle unqual depth
- | opt_PprStyle_Debug = PprDebug
- | otherwise = PprUser unqual depth
-\end{code}
-
-Orthogonal to the above printing styles are (possibly) some
-command-line flags that affect printing (often carried with the
-style). The most likely ones are variations on how much type info is
-shown.
-
-The following test decides whether or not we are actually generating
-code (either C or assembly), or generating interface files.
-
-%************************************************************************
-%* *
-\subsection{The @SDoc@ data type}
-%* *
-%************************************************************************
-
-\begin{code}
-newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
-
-data SDocContext = SDC
- { sdocStyle :: !PprStyle
- , sdocLastColour :: !PprColour
- -- ^ The most recently used colour. This allows nesting colours.
- , sdocDynFlags :: !DynFlags
- }
-
-initSDocContext :: DynFlags -> PprStyle -> SDocContext
-initSDocContext dflags sty = SDC
- { sdocStyle = sty
- , sdocLastColour = colReset
- , sdocDynFlags = dflags
- }
-
-withPprStyle :: PprStyle -> SDoc -> SDoc
-withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
-
-withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
-withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
-
-pprDeeper :: SDoc -> SDoc
-pprDeeper d = SDoc $ \ctx -> case ctx of
- SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..."
- SDC{sdocStyle=PprUser q (PartWay n)} ->
- runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))}
- _ -> runSDoc d ctx
-
-pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
--- Truncate a list that list that is longer than the current depth
-pprDeeperList f ds
- | null ds = f []
- | otherwise = SDoc work
- where
- work ctx@SDC{sdocStyle=PprUser q (PartWay n)}
- | n==0 = Pretty.text "..."
- | otherwise =
- runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))}
- where
- go _ [] = []
- go i (d:ds) | i >= n = [text "...."]
- | otherwise = d : go (i+1) ds
- work other_ctx = runSDoc (f ds) other_ctx
-
-pprSetDepth :: Depth -> SDoc -> SDoc
-pprSetDepth depth doc = SDoc $ \ctx ->
- case ctx of
- SDC{sdocStyle=PprUser q _} ->
- runSDoc doc ctx{sdocStyle = PprUser q depth}
- _ ->
- runSDoc doc ctx
-
-getPprStyle :: (PprStyle -> SDoc) -> SDoc
-getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
-
-sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc
-sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx
-
-sdocWithPlatform :: (Platform -> SDoc) -> SDoc
-sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
-\end{code}
-
-\begin{code}
-qualName :: PprStyle -> QueryQualifyName
-qualName (PprUser q _) mod occ = queryQualifyName q mod occ
-qualName (PprDump q) mod occ = queryQualifyName q mod occ
-qualName _other mod _ = NameQual (moduleName mod)
-
-qualModule :: PprStyle -> QueryQualifyModule
-qualModule (PprUser q _) m = queryQualifyModule q m
-qualModule (PprDump q) m = queryQualifyModule q m
-qualModule _other _m = True
-
-qualPackage :: PprStyle -> QueryQualifyPackage
-qualPackage (PprUser q _) m = queryQualifyPackage q m
-qualPackage (PprDump q) m = queryQualifyPackage q m
-qualPackage _other _m = True
-
-queryQual :: PprStyle -> PrintUnqualified
-queryQual s = QueryQualify (qualName s)
- (qualModule s)
- (qualPackage s)
-
-codeStyle :: PprStyle -> Bool
-codeStyle (PprCode _) = True
-codeStyle _ = False
-
-asmStyle :: PprStyle -> Bool
-asmStyle (PprCode AsmStyle) = True
-asmStyle _other = False
-
-dumpStyle :: PprStyle -> Bool
-dumpStyle (PprDump {}) = True
-dumpStyle _other = False
-
-debugStyle :: PprStyle -> Bool
-debugStyle PprDebug = True
-debugStyle _other = False
-
-userStyle :: PprStyle -> Bool
-userStyle (PprUser _ _) = True
-userStyle _other = False
-
-ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
-ifPprDebug d = SDoc $ \ctx ->
- case ctx of
- SDC{sdocStyle=PprDebug} -> runSDoc d ctx
- _ -> Pretty.empty
-\end{code}
-
-\begin{code}
-
-printForUser :: DynFlags -> Handle -> PrintUnqualified -> SDoc -> IO ()
-printForUser dflags handle unqual doc
- = Pretty.printDoc PageMode (pprCols dflags) handle
- (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
-
-printForUserPartWay :: DynFlags -> Handle -> Int -> PrintUnqualified -> SDoc
- -> IO ()
-printForUserPartWay dflags handle d unqual doc
- = Pretty.printDoc PageMode (pprCols dflags) handle
- (runSDoc doc (initSDocContext dflags (mkUserStyle unqual (PartWay d))))
-
--- printForC, printForAsm do what they sound like
-printForC :: DynFlags -> Handle -> SDoc -> IO ()
-printForC dflags handle doc =
- Pretty.printDoc LeftMode (pprCols dflags) handle
- (runSDoc doc (initSDocContext dflags (PprCode CStyle)))
-
-printForAsm :: DynFlags -> Handle -> SDoc -> IO ()
-printForAsm dflags handle doc =
- Pretty.printDoc LeftMode (pprCols dflags) handle
- (runSDoc doc (initSDocContext dflags (PprCode AsmStyle)))
-
-pprCode :: CodeStyle -> SDoc -> SDoc
-pprCode cs d = withPprStyle (PprCode cs) d
-
-mkCodeStyle :: CodeStyle -> PprStyle
-mkCodeStyle = PprCode
-
--- Can't make SDoc an instance of Show because SDoc is just a function type
--- However, Doc *is* an instance of Show
--- showSDoc just blasts it out as a string
-showSDoc :: DynFlags -> SDoc -> String
-showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle
-
-showSDocSimple :: SDoc -> String
-showSDocSimple sdoc = showSDoc unsafeGlobalDynFlags sdoc
-
-showPpr :: Outputable a => DynFlags -> a -> String
-showPpr dflags thing = showSDoc dflags (ppr thing)
-
-showSDocUnqual :: DynFlags -> SDoc -> String
--- Only used by Haddock
-showSDocUnqual dflags sdoc = showSDoc dflags sdoc
-
-showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
--- Allows caller to specify the PrintUnqualified to use
-showSDocForUser dflags unqual doc
- = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay)
-
-showSDocDump :: DynFlags -> SDoc -> String
-showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle
-
-showSDocDebug :: DynFlags -> SDoc -> String
-showSDocDebug dflags d = renderWithStyle dflags d PprDebug
-
-renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
-renderWithStyle dflags sdoc sty
- = Pretty.showDoc PageMode (pprCols dflags) $
- runSDoc sdoc (initSDocContext dflags sty)
-
--- This shows an SDoc, but on one line only. It's cheaper than a full
--- showSDoc, designed for when we're getting results like "Foo.bar"
--- and "foo{uniq strictness}" so we don't want fancy layout anyway.
-showSDocOneLine :: DynFlags -> SDoc -> String
-showSDocOneLine dflags d
- = Pretty.showDoc OneLineMode (pprCols dflags) $
- runSDoc d (initSDocContext dflags defaultUserStyle)
-
-showSDocDumpOneLine :: DynFlags -> SDoc -> String
-showSDocDumpOneLine dflags d
- = Pretty.showDoc OneLineMode irrelevantNCols $
- runSDoc d (initSDocContext dflags defaultDumpStyle)
-
-irrelevantNCols :: Int
--- Used for OneLineMode and LeftMode when number of cols isn't used
-irrelevantNCols = 1
-\end{code}
-
-\begin{code}
-docToSDoc :: Doc -> SDoc
-docToSDoc d = SDoc (\_ -> d)
-
-empty :: SDoc
-char :: Char -> SDoc
-text :: String -> SDoc
-ftext :: FastString -> SDoc
-ptext :: LitString -> SDoc
-ztext :: FastZString -> SDoc
-int :: Int -> SDoc
-integer :: Integer -> SDoc
-float :: Float -> SDoc
-double :: Double -> SDoc
-rational :: Rational -> SDoc
-
-empty = docToSDoc $ Pretty.empty
-char c = docToSDoc $ Pretty.char c
-
-text s = docToSDoc $ Pretty.text s
-{-# INLINE text #-} -- Inline so that the RULE Pretty.text will fire
-
-ftext s = docToSDoc $ Pretty.ftext s
-ptext s = docToSDoc $ Pretty.ptext s
-ztext s = docToSDoc $ Pretty.ztext s
-int n = docToSDoc $ Pretty.int n
-integer n = docToSDoc $ Pretty.integer n
-float n = docToSDoc $ Pretty.float n
-double n = docToSDoc $ Pretty.double n
-rational n = docToSDoc $ Pretty.rational n
-
-parens, braces, brackets, quotes, quote,
- paBrackets, doubleQuotes, angleBrackets :: SDoc -> SDoc
-
-parens d = SDoc $ Pretty.parens . runSDoc d
-braces d = SDoc $ Pretty.braces . runSDoc d
-brackets d = SDoc $ Pretty.brackets . runSDoc d
-quote d = SDoc $ Pretty.quote . runSDoc d
-doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
-angleBrackets d = char '<' <> d <> char '>'
-paBrackets d = ptext (sLit "[:") <> d <> ptext (sLit ":]")
-
-cparen :: Bool -> SDoc -> SDoc
-
-cparen b d = SDoc $ Pretty.cparen b . runSDoc d
-
--- 'quotes' encloses something in single quotes...
--- but it omits them if the thing begins or ends in a single quote
--- so that we don't get `foo''. Instead we just have foo'.
-quotes d =
- sdocWithDynFlags $ \dflags ->
- if useUnicode dflags
- then char '‘' <> d <> char '’'
- else SDoc $ \sty ->
- let pp_d = runSDoc d sty
- str = show pp_d
- in case (str, snocView str) of
- (_, Just (_, '\'')) -> pp_d
- ('\'' : _, _) -> pp_d
- _other -> Pretty.quotes pp_d
-
-semi, comma, colon, equals, space, dcolon, underscore, dot :: SDoc
-arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
-lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
-
-blankLine = docToSDoc $ Pretty.ptext (sLit "")
-dcolon = unicodeSyntax (char '∷') (docToSDoc $ Pretty.ptext (sLit "::"))
-arrow = unicodeSyntax (char '→') (docToSDoc $ Pretty.ptext (sLit "->"))
-larrow = unicodeSyntax (char '←') (docToSDoc $ Pretty.ptext (sLit "<-"))
-darrow = unicodeSyntax (char '⇒') (docToSDoc $ Pretty.ptext (sLit "=>"))
-arrowt = unicodeSyntax (char '↣') (docToSDoc $ Pretty.ptext (sLit ">-"))
-larrowt = unicodeSyntax (char '↢') (docToSDoc $ Pretty.ptext (sLit "-<"))
-arrowtt = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.ptext (sLit ">>-"))
-larrowtt = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.ptext (sLit "-<<"))
-semi = docToSDoc $ Pretty.semi
-comma = docToSDoc $ Pretty.comma
-colon = docToSDoc $ Pretty.colon
-equals = docToSDoc $ Pretty.equals
-space = docToSDoc $ Pretty.space
-underscore = char '_'
-dot = 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
-
-forAllLit :: SDoc
-forAllLit = unicodeSyntax (char '∀') (ptext (sLit "forall"))
-
-unicodeSyntax :: SDoc -> SDoc -> SDoc
-unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->
- if useUnicode dflags && useUnicodeSyntax dflags
- then unicode
- else plain
-
-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
-
-nest n d = SDoc $ Pretty.nest n . runSDoc d
-(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty)
-(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)
-($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty)
-($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
-
-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
--- ^ Catenate: 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
--- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
-
-
-hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
-hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
-vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
-sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds]
-cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds]
-fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
-fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
-
-hang :: SDoc -- ^ The header
- -> Int -- ^ Amount to indent the hung body
- -> SDoc -- ^ The hung body, indented and placed below the header
- -> SDoc
-hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
-
-punctuate :: SDoc -- ^ The punctuation
- -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
- -> [SDoc] -- ^ 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 True doc = doc
-ppWhen False _ = empty
-
-ppUnless True _ = empty
-ppUnless False doc = doc
-
--- | A colour\/style for use with 'coloured'.
-newtype PprColour = PprColour String
-
--- Colours
-
-colType :: PprColour
-colType = PprColour "\27[34m"
-
-colBold :: PprColour
-colBold = PprColour "\27[;1m"
-
-colCoerc :: PprColour
-colCoerc = PprColour "\27[34m"
-
-colDataCon :: PprColour
-colDataCon = PprColour "\27[31m"
-
-colBinder :: PprColour
-colBinder = PprColour "\27[32m"
-
-colReset :: PprColour
-colReset = PprColour "\27[0m"
-
--- | Apply the given colour\/style for the argument.
---
--- Only takes effect if colours are enabled.
-coloured :: PprColour -> SDoc -> SDoc
--- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
-coloured col@(PprColour c) sdoc =
- SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
- let ctx' = ctx{ sdocLastColour = col } in
- Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
-
-bold :: SDoc -> SDoc
-bold = coloured colBold
-
-keyword :: SDoc -> SDoc
-keyword = bold
-
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Outputable-class]{The @Outputable@ class}
-%* *
-%************************************************************************
-
-\begin{code}
--- | Class designating that some type has an 'SDoc' representation
-class Outputable a where
- ppr :: a -> SDoc
- pprPrec :: Rational -> a -> SDoc
- -- 0 binds least tightly
- -- We use Rational because there is always a
- -- Rational between any other two Rationals
-
- ppr = pprPrec 0
- pprPrec _ = ppr
-\end{code}
-
-\begin{code}
-instance Outputable Char where
- ppr c = text [c]
-
-instance Outputable Bool where
- ppr True = ptext (sLit "True")
- ppr False = ptext (sLit "False")
-
-instance Outputable Int32 where
- ppr n = integer $ fromIntegral n
-
-instance Outputable Int64 where
- ppr n = integer $ fromIntegral n
-
-instance Outputable Int where
- ppr n = int n
-
-instance Outputable Word16 where
- ppr n = integer $ fromIntegral n
-
-instance Outputable Word32 where
- ppr n = integer $ fromIntegral n
-
-instance Outputable Word where
- ppr n = integer $ fromIntegral n
-
-instance Outputable () where
- ppr _ = text "()"
-
-instance (Outputable a) => Outputable [a] where
- ppr xs = brackets (fsep (punctuate comma (map ppr xs)))
-
-instance (Outputable a) => Outputable (Set a) where
- ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s))))
-
-instance (Outputable a, Outputable b) => Outputable (a, b) where
- ppr (x,y) = parens (sep [ppr x <> comma, ppr y])
-
-instance Outputable a => Outputable (Maybe a) where
- ppr Nothing = ptext (sLit "Nothing")
- ppr (Just x) = ptext (sLit "Just") <+> ppr x
-
-instance (Outputable a, Outputable b) => Outputable (Either a b) where
- ppr (Left x) = ptext (sLit "Left") <+> ppr x
- ppr (Right y) = ptext (sLit "Right") <+> ppr y
-
--- ToDo: may not be used
-instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c) where
- ppr (x,y,z) =
- parens (sep [ppr x <> comma,
- ppr y <> comma,
- ppr z ])
-
-instance (Outputable a, Outputable b, Outputable c, Outputable d) =>
- Outputable (a, b, c, d) where
- ppr (a,b,c,d) =
- parens (sep [ppr a <> comma,
- ppr b <> comma,
- ppr c <> comma,
- ppr d])
-
-instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e) =>
- Outputable (a, b, c, d, e) where
- ppr (a,b,c,d,e) =
- parens (sep [ppr a <> comma,
- ppr b <> comma,
- ppr c <> comma,
- ppr d <> comma,
- ppr e])
-
-instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) =>
- Outputable (a, b, c, d, e, f) where
- ppr (a,b,c,d,e,f) =
- parens (sep [ppr a <> comma,
- ppr b <> comma,
- ppr c <> comma,
- ppr d <> comma,
- ppr e <> comma,
- ppr f])
-
-instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) =>
- Outputable (a, b, c, d, e, f, g) where
- ppr (a,b,c,d,e,f,g) =
- parens (sep [ppr a <> comma,
- ppr b <> comma,
- ppr c <> comma,
- ppr d <> comma,
- ppr e <> comma,
- ppr f <> comma,
- ppr g])
-
-instance Outputable FastString where
- ppr fs = ftext fs -- Prints an unadorned string,
- -- no double quotes or anything
-
-instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where
- ppr m = ppr (M.toList m)
-instance (Outputable elt) => Outputable (IM.IntMap elt) where
- ppr m = ppr (IM.toList m)
-
-instance Outputable Fingerprint where
- ppr (Fingerprint w1 w2) = text (printf "%016x%016x" w1 w2)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @OutputableBndr@ class}
-%* *
-%************************************************************************
-
-\begin{code}
--- | 'BindingSite' is used to tell the thing that prints binder what
--- language construct is binding the identifier. This can be used
--- to decide how much info to print.
-data BindingSite = LambdaBind | CaseBind | LetBind
-
--- | When we print a binder, we often want to print its type too.
--- The @OutputableBndr@ class encapsulates this idea.
-class Outputable a => OutputableBndr a where
- pprBndr :: BindingSite -> a -> SDoc
- pprBndr _b x = ppr x
-
- pprPrefixOcc, pprInfixOcc :: a -> SDoc
- -- Print an occurrence of the name, suitable either in the
- -- prefix position of an application, thus (f a b) or ((+) x)
- -- or infix position, thus (a `f` b) or (x + y)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Random printing helpers}
-%* *
-%************************************************************************
-
-\begin{code}
--- We have 31-bit Chars and will simply use Show instances of Char and String.
-
--- | Special combinator for showing character literals.
-pprHsChar :: Char -> SDoc
-pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32))
- | otherwise = text (show c)
-
--- | Special combinator for showing string literals.
-pprHsString :: FastString -> SDoc
-pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs)))
-
--- | Special combinator for showing string literals.
-pprHsBytes :: ByteString -> SDoc
-pprHsBytes bs = let escaped = concatMap escape $ BS.unpack bs
- in vcat (map text (showMultiLineString escaped)) <> char '#'
- where escape :: Word8 -> String
- escape w = let c = chr (fromIntegral w)
- in if isAscii c
- then [c]
- else '\\' : show w
-
----------------------
--- Put a name in parens if it's an operator
-pprPrefixVar :: Bool -> SDoc -> SDoc
-pprPrefixVar is_operator pp_v
- | is_operator = parens pp_v
- | otherwise = pp_v
-
--- Put a name in backquotes if it's not an operator
-pprInfixVar :: Bool -> SDoc -> SDoc
-pprInfixVar is_operator pp_v
- | is_operator = pp_v
- | otherwise = char '`' <> pp_v <> char '`'
-
----------------------
-pprFastFilePath :: FastString -> SDoc
-pprFastFilePath path = text $ normalise $ unpackFS path
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Other helper functions}
-%* *
-%************************************************************************
-
-\begin{code}
-pprWithCommas :: (a -> SDoc) -- ^ The pretty printing function to use
- -> [a] -- ^ The things to be pretty printed
- -> SDoc -- ^ 'SDoc' where the things have been pretty printed,
- -- comma-separated and finally packed into a paragraph.
-pprWithCommas pp xs = fsep (punctuate comma (map pp xs))
-
--- | Returns the separated concatenation of the pretty printed things.
-interppSP :: Outputable a => [a] -> SDoc
-interppSP xs = sep (map ppr xs)
-
--- | Returns the comma-separated concatenation of the pretty printed things.
-interpp'SP :: Outputable a => [a] -> SDoc
-interpp'SP xs = sep (punctuate comma (map ppr xs))
-
--- | Returns the comma-separated concatenation of the quoted pretty printed things.
---
--- > [x,y,z] ==> `x', `y', `z'
-pprQuotedList :: Outputable a => [a] -> SDoc
-pprQuotedList = quotedList . map ppr
-
-quotedList :: [SDoc] -> SDoc
-quotedList xs = hsep (punctuate comma (map quotes xs))
-
-quotedListWithOr :: [SDoc] -> SDoc
--- [x,y,z] ==> `x', `y' or `z'
-quotedListWithOr xs@(_:_:_) = quotedList (init xs) <+> ptext (sLit "or") <+> quotes (last xs)
-quotedListWithOr xs = quotedList xs
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Printing numbers verbally}
-%* *
-%************************************************************************
-
-\begin{code}
-intWithCommas :: Integral a => a -> SDoc
--- Prints a big integer with commas, eg 345,821
-intWithCommas n
- | n < 0 = char '-' <> intWithCommas (-n)
- | q == 0 = int (fromIntegral r)
- | otherwise = intWithCommas q <> comma <> zeroes <> int (fromIntegral r)
- where
- (q,r) = n `quotRem` 1000
- zeroes | r >= 100 = empty
- | r >= 10 = char '0'
- | otherwise = ptext (sLit "00")
-
--- | Converts an integer to a verbal index:
---
--- > speakNth 1 = text "first"
--- > speakNth 5 = text "fifth"
--- > speakNth 21 = text "21st"
-speakNth :: Int -> SDoc
-speakNth 1 = ptext (sLit "first")
-speakNth 2 = ptext (sLit "second")
-speakNth 3 = ptext (sLit "third")
-speakNth 4 = ptext (sLit "fourth")
-speakNth 5 = ptext (sLit "fifth")
-speakNth 6 = ptext (sLit "sixth")
-speakNth n = hcat [ int n, text suffix ]
- where
- suffix | n <= 20 = "th" -- 11,12,13 are non-std
- | last_dig == 1 = "st"
- | last_dig == 2 = "nd"
- | last_dig == 3 = "rd"
- | otherwise = "th"
-
- last_dig = n `rem` 10
-
--- | Converts an integer to a verbal multiplicity:
---
--- > speakN 0 = text "none"
--- > speakN 5 = text "five"
--- > speakN 10 = text "10"
-speakN :: Int -> SDoc
-speakN 0 = ptext (sLit "none") -- E.g. "he has none"
-speakN 1 = ptext (sLit "one") -- E.g. "he has one"
-speakN 2 = ptext (sLit "two")
-speakN 3 = ptext (sLit "three")
-speakN 4 = ptext (sLit "four")
-speakN 5 = ptext (sLit "five")
-speakN 6 = ptext (sLit "six")
-speakN n = int n
-
--- | Converts an integer and object description to a statement about the
--- multiplicity of those objects:
---
--- > speakNOf 0 (text "melon") = text "no melons"
--- > speakNOf 1 (text "melon") = text "one melon"
--- > speakNOf 3 (text "melon") = text "three melons"
-speakNOf :: Int -> SDoc -> SDoc
-speakNOf 0 d = ptext (sLit "no") <+> d <> char 's'
-speakNOf 1 d = ptext (sLit "one") <+> d -- E.g. "one argument"
-speakNOf n d = speakN n <+> d <> char 's' -- E.g. "three arguments"
-
--- | Converts a strictly positive integer into a number of times:
---
--- > speakNTimes 1 = text "once"
--- > speakNTimes 2 = text "twice"
--- > speakNTimes 4 = text "4 times"
-speakNTimes :: Int {- >=1 -} -> SDoc
-speakNTimes t | t == 1 = ptext (sLit "once")
- | t == 2 = ptext (sLit "twice")
- | otherwise = speakN t <+> ptext (sLit "times")
-
--- | Determines the pluralisation suffix appropriate for the length of a list:
---
--- > plural [] = char 's'
--- > plural ["Hello"] = empty
--- > plural ["Hello", "World"] = char 's'
-plural :: [a] -> SDoc
-plural [_] = empty -- a bit frightening, but there you are
-plural _ = char 's'
-
--- | Determines the form of to be appropriate for the length of a list:
---
--- > isOrAre [] = ptext (sLit "are")
--- > isOrAre ["Hello"] = ptext (sLit "is")
--- > isOrAre ["Hello", "World"] = ptext (sLit "are")
-isOrAre :: [a] -> SDoc
-isOrAre [_] = ptext (sLit "is")
-isOrAre _ = ptext (sLit "are")
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Error handling}
-%* *
-%************************************************************************
-
-\begin{code}
-
-pprPanic :: String -> SDoc -> a
--- ^ Throw an exception saying "bug in GHC"
-pprPanic = panicDoc
-
-pprSorry :: String -> SDoc -> a
--- ^ Throw an exception saying "this isn't finished yet"
-pprSorry = sorryDoc
-
-
-pprPgmError :: String -> SDoc -> a
--- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)
-pprPgmError = pgmErrorDoc
-
-
-pprTrace :: String -> SDoc -> a -> a
--- ^ If debug output is on, show some 'SDoc' on the screen
-pprTrace str doc x
- | opt_NoDebugOutput = x
- | otherwise = pprDebugAndThen unsafeGlobalDynFlags trace (text str) doc x
-
-pprPanicFastInt :: String -> SDoc -> FastInt
--- ^ Specialization of pprPanic that can be safely used with 'FastInt'
-pprPanicFastInt heading pretty_msg = panicDocFastInt heading pretty_msg
-
-warnPprTrace :: Bool -> String -> Int -> SDoc -> a -> a
--- ^ Just warn about an assertion failure, recording the given file and line number.
--- Should typically be accessed with the WARN macros
-warnPprTrace _ _ _ _ x | not debugIsOn = x
-warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
-warnPprTrace False _file _line _msg x = x
-warnPprTrace True file line msg x
- = pprDebugAndThen unsafeGlobalDynFlags trace heading msg x
- where
- heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]
-
-assertPprPanic :: String -> Int -> SDoc -> a
--- ^ Panic with an assertation failure, recording the given file and line number.
--- Should typically be accessed with the ASSERT family of macros
-assertPprPanic file line msg
- = pprPanic "ASSERT failed!" doc
- where
- doc = sep [ hsep [ text "file", text file
- , text "line", int line ]
- , msg ]
-
-pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a
-pprDebugAndThen dflags cont heading pretty_msg
- = cont (showSDocDump dflags doc)
- where
- doc = sep [heading, nest 2 pretty_msg]
-\end{code}
-