Add outputable instances for the types in GHC.Iface.Ext.Types, add -ddump-hie

flag to dump pretty printed contents of the .hie file

Metric Increase:
   hie002

Because of the regression on i386:

compile_time/bytes allocated increased from i386-linux-deb9 baseline @ HEAD~10:
    Expected    hie002 (normal) compile_time/bytes allocated: 583014888.0 +/-10%
    Lower bound hie002 (normal) compile_time/bytes allocated:   524713399
    Upper bound hie002 (normal) compile_time/bytes allocated:   641316377
    Actual      hie002 (normal) compile_time/bytes allocated:   877986292
    Deviation   hie002 (normal) compile_time/bytes allocated:        50.6 %
*** unexpected stat test failure for hie002(normal)

5 files changed, 101 insertions, 47 deletions

diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 57c06ae7a3..3655f76564 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -79,6 +79,7 @@ data DumpFlag
    | Opt_D_dump_cpr_signatures
    | Opt_D_dump_tc
    | Opt_D_dump_tc_ast
+   | Opt_D_dump_hie
    | Opt_D_dump_types
    | Opt_D_dump_rules
    | Opt_D_dump_cse
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 3eb00cd03c..a1246863b2 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -425,14 +425,14 @@ extract_renamed_stuff mod_summary tc_result = do
         hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
         let out_file = ml_hie_file $ ms_location mod_summary
         liftIO $ writeHieFile out_file hieFile
+        liftIO $ dumpIfSet_dyn dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
 
         -- Validate HIE files
         when (gopt Opt_ValidateHie dflags) $ do
             hs_env <- Hsc $ \e w -> return (e, w)
             liftIO $ do
               -- Validate Scopes
-              let mdl = hie_module hieFile
-              case validateScopes mdl $ getAsts $ hie_asts hieFile of
+              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of
                   [] -> putMsg dflags $ text "Got valid scopes"
                   xs -> do
                     putMsg dflags $ text "Got invalid scopes"
@@ -445,7 +445,7 @@ extract_renamed_stuff mod_summary tc_result = do
                   putMsg dflags $ text "Got no roundtrip errors"
                 xs -> do
                   putMsg dflags $ text "Got roundtrip errors"
-                  mapM_ (putMsg dflags) xs
+                  mapM_ (putMsg (dopt_set dflags Opt_D_ppr_debug)) xs
     return rn_info
 
 
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index f500aa3501..93c2a870b5 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -2741,6 +2741,8 @@ dynamic_flags_deps = [
         (setDumpFlag Opt_D_dump_tc)
   , make_ord_flag defGhcFlag "ddump-tc-ast"
         (setDumpFlag Opt_D_dump_tc_ast)
+  , make_ord_flag defGhcFlag "ddump-hie"
+        (setDumpFlag Opt_D_dump_hie)
   , make_ord_flag defGhcFlag "ddump-types"
         (setDumpFlag Opt_D_dump_types)
   , make_ord_flag defGhcFlag "ddump-rules"
diff --git a/compiler/GHC/Iface/Ext/Debug.hs b/compiler/GHC/Iface/Ext/Debug.hs
index e28f7ab03d..292668fe23 100644
--- a/compiler/GHC/Iface/Ext/Debug.hs
+++ b/compiler/GHC/Iface/Ext/Debug.hs
@@ -23,35 +23,6 @@ import qualified Data.Map as M
 import qualified Data.Set as S
 import Data.Function    ( on )
 import Data.List        ( sortOn )
-import Data.Foldable    ( toList )
-
-ppHies :: Outputable a => (HieASTs a) -> SDoc
-ppHies (HieASTs asts) = M.foldrWithKey go "" asts
-  where
-    go k a rest = vcat $
-      [ "File: " <> ppr k
-      , ppHie a
-      , rest
-      ]
-
-ppHie :: Outputable a => HieAST a -> SDoc
-ppHie = go 0
-  where
-    go n (Node inf sp children) = hang header n rest
-      where
-        rest = vcat $ map (go (n+2)) children
-        header = hsep
-          [ "Node"
-          , ppr sp
-          , ppInfo inf
-          ]
-
-ppInfo :: Outputable a => NodeInfo a -> SDoc
-ppInfo ni = hsep
-  [ ppr $ toList $ nodeAnnotations ni
-  , ppr $ nodeType ni
-  , ppr $ M.toList $ nodeIdentifiers ni
-  ]
 
 type Diff a = a -> a -> [SDoc]
 
diff --git a/compiler/GHC/Iface/Ext/Types.hs b/compiler/GHC/Iface/Ext/Types.hs
index 3f87a91d34..edd6540e80 100644
--- a/compiler/GHC/Iface/Ext/Types.hs
+++ b/compiler/GHC/Iface/Ext/Types.hs
@@ -5,9 +5,11 @@ For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files
 -}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE TypeSynonymInstances #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
 module GHC.Iface.Ext.Types where
 
 import GhcPrelude
@@ -21,6 +23,7 @@ import GHC.Types.Name             ( Name )
 import Outputable hiding ( (<>) )
 import GHC.Types.SrcLoc           ( RealSrcSpan )
 import GHC.Types.Avail
+import qualified Outputable as O ( (<>) )
 
 import qualified Data.Array as A
 import qualified Data.Map as M
@@ -210,6 +213,15 @@ instance Binary (HieASTs TypeIndex) where
   put_ bh asts = put_ bh $ M.toAscList $ getAsts asts
   get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)
 
+instance Outputable a => Outputable (HieASTs a) where
+  ppr (HieASTs asts) = M.foldrWithKey go "" asts
+    where
+      go k a rest = vcat $
+        [ "File: " O.<> ppr k
+        , ppr a
+        , rest
+        ]
+
 
 data HieAST a =
   Node
@@ -229,6 +241,11 @@ instance Binary (HieAST TypeIndex) where
     <*> get bh
     <*> get bh
 
+instance Outputable a => Outputable (HieAST a) where
+  ppr (Node ni sp ch) = hang header 2 rest
+    where
+      header = text "Node@" O.<> ppr sp O.<> ":" <+> ppr ni
+      rest = vcat (map ppr ch)
 
 -- | The information stored in one AST node.
 --
@@ -255,6 +272,22 @@ instance Binary (NodeInfo TypeIndex) where
     <*> get bh
     <*> fmap (M.fromList) (get bh)
 
+instance Outputable a => Outputable (NodeInfo a) where
+  ppr (NodeInfo anns typs idents) = braces $ fsep $ punctuate ", "
+    [ parens (text "annotations:" <+> ppr anns)
+    , parens (text "types:" <+> ppr typs)
+    , parens (text "identifier info:" <+> pprNodeIdents idents)
+    ]
+
+pprNodeIdents :: Outputable a => NodeIdentifiers a -> SDoc
+pprNodeIdents ni = braces $ fsep $ punctuate ", " $ map go $ M.toList ni
+  where
+    go (i,id) = parens $ hsep $ punctuate ", " [pprIdentifier i, ppr id]
+
+pprIdentifier :: Identifier -> SDoc
+pprIdentifier (Left mod) = text "module" <+> ppr mod
+pprIdentifier (Right name) = text "name" <+> ppr name
+
 type Identifier = Either ModuleName Name
 
 type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a)
@@ -269,7 +302,7 @@ data IdentifierDetails a = IdentifierDetails
   } deriving (Eq, Functor, Foldable, Traversable)
 
 instance Outputable a => Outputable (IdentifierDetails a) where
-  ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x)
+  ppr x = text "Details: " <+> ppr (identType x) <+> ppr (identInfo x)
 
 instance Semigroup (IdentifierDetails a) where
   d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2)
@@ -284,7 +317,7 @@ instance Binary (IdentifierDetails TypeIndex) where
     put_ bh $ S.toAscList $ identInfo dets
   get bh =  IdentifierDetails
     <$> get bh
-    <*> fmap (S.fromDistinctAscList) (get bh)
+    <*> fmap S.fromDistinctAscList (get bh)
 
 
 -- | Different contexts under which identifiers exist
@@ -330,10 +363,32 @@ data ContextInfo
 
   -- | Record field
   | RecField RecFieldContext (Maybe Span)
-    deriving (Eq, Ord, Show)
+    deriving (Eq, Ord)
 
 instance Outputable ContextInfo where
-  ppr = text . show
+ ppr (Use) = text "usage"
+ ppr (MatchBind) = text "LHS of a match group"
+ ppr (IEThing x) = ppr x
+ ppr (TyDecl) = text "bound in a type signature declaration"
+ ppr (ValBind t sc sp) =
+   ppr t <+> text "value bound with scope:" <+> ppr sc <+> pprBindSpan sp
+ ppr (PatternBind sc1 sc2 sp) =
+   text "bound in a pattern with scope:"
+     <+> ppr sc1 <+> "," <+> ppr sc2
+     <+> pprBindSpan sp
+ ppr (ClassTyDecl sp) =
+   text "bound in a class type declaration" <+> pprBindSpan sp
+ ppr (Decl d sp) =
+   text "declaration of" <+> ppr d <+> pprBindSpan sp
+ ppr (TyVarBind sc1 sc2) =
+   text "type variable binding with scope:"
+     <+> ppr sc1 <+> "," <+> ppr sc2
+ ppr (RecField ctx sp) =
+   text "record field" <+> ppr ctx <+> pprBindSpan sp
+
+pprBindSpan :: Maybe Span -> SDoc
+pprBindSpan Nothing = text ""
+pprBindSpan (Just sp) = text "at:" <+> ppr sp
 
 instance Binary ContextInfo where
   put_ bh Use = putByte bh 0
@@ -383,14 +438,19 @@ instance Binary ContextInfo where
       9 -> return MatchBind
       _ -> panic "Binary ContextInfo: invalid tag"
 
-
 -- | Types of imports and exports
 data IEType
   = Import
   | ImportAs
   | ImportHiding
   | Export
-    deriving (Eq, Enum, Ord, Show)
+    deriving (Eq, Enum, Ord)
+
+instance Outputable IEType where
+  ppr Import = text "import"
+  ppr ImportAs = text "import as"
+  ppr ImportHiding = text "import hiding"
+  ppr Export = text "export"
 
 instance Binary IEType where
   put_ bh b = putByte bh (fromIntegral (fromEnum b))
@@ -402,7 +462,13 @@ data RecFieldContext
   | RecFieldAssign
   | RecFieldMatch
   | RecFieldOcc
-    deriving (Eq, Enum, Ord, Show)
+    deriving (Eq, Enum, Ord)
+
+instance Outputable RecFieldContext where
+  ppr RecFieldDecl = text "declaration"
+  ppr RecFieldAssign = text "assignment"
+  ppr RecFieldMatch = text "pattern match"
+  ppr RecFieldOcc = text "occurence"
 
 instance Binary RecFieldContext where
   put_ bh b = putByte bh (fromIntegral (fromEnum b))
@@ -412,13 +478,16 @@ instance Binary RecFieldContext where
 data BindType
   = RegularBind
   | InstanceBind
-    deriving (Eq, Ord, Show, Enum)
+    deriving (Eq, Ord, Enum)
+
+instance Outputable BindType where
+  ppr RegularBind = "regular"
+  ppr InstanceBind = "instance"
 
 instance Binary BindType where
   put_ bh b = putByte bh (fromIntegral (fromEnum b))
   get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
 
-
 data DeclType
   = FamDec     -- ^ type or data family
   | SynDec     -- ^ type synonym
@@ -427,18 +496,26 @@ data DeclType
   | PatSynDec  -- ^ pattern synonym
   | ClassDec   -- ^ class declaration
   | InstDec    -- ^ instance declaration
-    deriving (Eq, Ord, Show, Enum)
+    deriving (Eq, Ord, Enum)
+
+instance Outputable DeclType where
+  ppr FamDec = text "type or data family"
+  ppr SynDec = text "type synonym"
+  ppr DataDec = text "data"
+  ppr ConDec = text "constructor"
+  ppr PatSynDec = text "pattern synonym"
+  ppr ClassDec = text "class"
+  ppr InstDec = text "instance"
 
 instance Binary DeclType where
   put_ bh b = putByte bh (fromIntegral (fromEnum b))
   get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))
 
-
 data Scope
   = NoScope
   | LocalScope Span
   | ModuleScope
-    deriving (Eq, Ord, Show, Typeable, Data)
+    deriving (Eq, Ord, Typeable, Data)
 
 instance Outputable Scope where
   ppr NoScope = text "NoScope"
@@ -488,9 +565,12 @@ data TyVarScope
                       -- method type signature
     deriving (Eq, Ord)
 
-instance Show TyVarScope where
-  show (ResolvedScopes sc) = show sc
-  show _ = error "UnresolvedScope"
+instance Outputable TyVarScope where
+  ppr (ResolvedScopes xs) =
+    text "type variable scopes:" <+> hsep (punctuate ", " $ map ppr xs)
+  ppr (UnresolvedScope ns sp) =
+    text "unresolved type variable scope for name" O.<> plural ns
+      <+> pprBindSpan sp
 
 instance Binary TyVarScope where
   put_ bh (ResolvedScopes xs) = do