summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/coreSyn/PprCore.hs9
-rw-r--r--compiler/ghc.cabal.in1
-rw-r--r--compiler/ghc.mk1
-rw-r--r--compiler/utils/Outputable.hs20
-rw-r--r--compiler/utils/OutputableAnnotation.hs9
-rw-r--r--compiler/utils/OutputableAnnotation.hs-boot3
-rw-r--r--compiler/utils/Pretty.hs1
7 files changed, 38 insertions, 6 deletions
diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs
index 28d35528fe..da78d1ec90 100644
--- a/compiler/coreSyn/PprCore.hs
+++ b/compiler/coreSyn/PprCore.hs
@@ -12,7 +12,7 @@ module PprCore (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
pprCoreBindingWithSize, pprCoreBindingsWithSize,
- pprRules, pprOptCo
+ pprRules, pprOptCo, pprCoreBindingsWithAnn
) where
import CoreSyn
@@ -32,6 +32,7 @@ import BasicTypes
import Maybes
import Util
import Outputable
+import OutputableAnnotation
import FastString
import SrcLoc ( pprUserRealSpan )
@@ -65,6 +66,9 @@ instance OutputableBndr b => Outputable (Bind b) where
instance OutputableBndr b => Outputable (Expr b) where
ppr expr = pprCoreExpr expr
+pprCoreBindingsWithAnn :: [CoreBind] -> SDoc
+pprCoreBindingsWithAnn = pprTopBinds realAnn
+
{-
************************************************************************
* *
@@ -80,6 +84,9 @@ type Annotation b = Expr b -> SDoc
sizeAnn :: CoreExpr -> SDoc
sizeAnn e = text "-- RHS size:" <+> ppr (exprStats e)
+realAnn :: CoreExpr -> SDoc
+realAnn e = addAnn (PCoreExpr e) (ppr e)
+
-- | No annotation
noAnn :: Expr b -> SDoc
noAnn _ = empty
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 4f2db5e4a5..49c8cb9720 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -506,6 +506,7 @@ Library
MonadUtils
OrdList
Outputable
+ OutputableAnnotation
Pair
Panic
PprColour
diff --git a/compiler/ghc.mk b/compiler/ghc.mk
index bfd75ab26c..95d6fab0da 100644
--- a/compiler/ghc.mk
+++ b/compiler/ghc.mk
@@ -526,6 +526,7 @@ compiler_stage2_dll0_MODULES = \
OptCoercion \
OrdList \
Outputable \
+ OutputableAnnotation \
PackageConfig \
Packages \
Pair \
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 08e5719be9..ba4bc7e498 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, ImplicitParams #-}
+{-# LANGUAGE CPP, ImplicitParams, GADTs #-}
{-
(c) The University of Glasgow 2006-2012
(c) The GRASP Project, Glasgow University, 1992-1998
@@ -40,6 +40,8 @@ module Outputable (
coloured, keyword,
+ addAnn,
+
-- * Converting 'SDoc' into strings and outputing it
printSDoc, printSDocLn, printForUser, printForUserPartWay,
printForC, bufLeftRenderSDoc,
@@ -82,6 +84,7 @@ module Outputable (
pprTrace, pprTraceDebug, pprTraceIt, warnPprTrace, pprSTrace,
trace, pgmError, panic, sorry, assertPanic,
pprDebugAndThen, callStackDoc
+
) where
import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput,
@@ -91,13 +94,15 @@ import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput,
import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName )
import {-# SOURCE #-} OccName( OccName )
+import {-# SOURCE #-} OutputableAnnotation
+
import BufWrite (BufHandle)
import FastString
import qualified Pretty
import Util
import Platform
import qualified PprColour as Col
-import Pretty ( Doc, Mode(..) )
+import Pretty ( Doc, Mode(..), annotate )
import Panic
import GHC.Serialized
import GHC.LanguageExtensions (Extension)
@@ -122,6 +127,7 @@ import Data.List (intersperse)
import GHC.Fingerprint
import GHC.Show ( showMultiLineString )
+import Data.Void
{-
************************************************************************
@@ -306,6 +312,7 @@ code (either C or assembly), or generating interface files.
************************************************************************
-}
+
-- | Represents a pretty-printable document.
--
-- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc',
@@ -313,7 +320,10 @@ code (either C or assembly), or generating interface files.
-- abstraction layer.
-- Note that for now, it is Doc (). This should be changed to hold
-- annotation.
-newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc () }
+newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc PExpr }
+
+addAnn :: PExpr -> SDoc -> SDoc
+addAnn pe (SDoc s) = (SDoc (\ctx -> annotate pe (s ctx)))
data SDocContext = SDC
{ sdocStyle :: !PprStyle
@@ -338,7 +348,7 @@ withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
-- | This is not a recommended way to render 'SDoc', since it breaks the
-- abstraction layer of 'SDoc'. Prefer to use 'printSDoc', 'printSDocLn',
-- 'bufLeftRenderSDoc', or 'renderWithStyle' instead.
-withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc ()
+withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc PExpr
withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
sdocWithPprDebug :: (Bool -> SDoc) -> SDoc
@@ -541,7 +551,7 @@ isEmpty :: DynFlags -> SDoc -> Bool
isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext
where dummySDocContext = initSDocContext dflags PprDebug
-docToSDoc :: Doc () -> SDoc
+docToSDoc :: Doc PExpr -> SDoc
docToSDoc d = SDoc (\_ -> d)
empty :: SDoc
diff --git a/compiler/utils/OutputableAnnotation.hs b/compiler/utils/OutputableAnnotation.hs
new file mode 100644
index 0000000000..f506a0b20b
--- /dev/null
+++ b/compiler/utils/OutputableAnnotation.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE GADTs #-}
+module OutputableAnnotation (PExpr(..)) where
+
+import CoreSyn
+
+data PExpr where
+ PCoreExpr :: CoreExpr -> PExpr
+
+
diff --git a/compiler/utils/OutputableAnnotation.hs-boot b/compiler/utils/OutputableAnnotation.hs-boot
new file mode 100644
index 0000000000..d71f632aca
--- /dev/null
+++ b/compiler/utils/OutputableAnnotation.hs-boot
@@ -0,0 +1,3 @@
+module OutputableAnnotation where
+
+data PExpr
diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs
index a7969e61d7..f35d692289 100644
--- a/compiler/utils/Pretty.hs
+++ b/compiler/utils/Pretty.hs
@@ -108,6 +108,7 @@ module Pretty (
-- ** GHC-specific rendering
printDoc, printDoc_,
-- bufLeftRender -- performance hack
+ annotate
) where
View Lorry Controller Status