Start of annotating core

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