Fix bug preventing information about patterns from being serialized in .hie files

4 files changed, 72 insertions, 18 deletions

diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs
index e1047692ff..f0b10a3efa 100644
--- a/compiler/hieFile/HieAst.hs
+++ b/compiler/hieFile/HieAst.hs
@@ -38,6 +38,7 @@ import TysWiredIn                 ( mkListTy, mkSumTy )
 import Var                        ( Id, Var, setVarName, varName, varType )
 import TcRnTypes
 import MkIface                    ( mkIfaceExports )
+import Panic
 
 import HieTypes
 import HieUtils
@@ -161,7 +162,7 @@ getRealSpan _ = Nothing
 
 grhss_span :: GRHSs p body -> SrcSpan
 grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)
-grhss_span (XGRHSs _) = error "XGRHS has no span"
+grhss_span (XGRHSs _) = panic "XGRHS has no span"
 
 bindingsOnly :: [Context Name] -> [HieAST a]
 bindingsOnly [] = []
@@ -245,7 +246,7 @@ patScopes
   -> [LPat (GhcPass p)]
   -> [PScoped (LPat (GhcPass p))]
 patScopes rsp useScope patScope xs =
-  map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $
+  map (\(RS sc a) -> PS rsp useScope sc (composeSrcSpan a)) $
     listScopes patScope (map dL xs)
 
 -- | 'listScopes' specialised to 'TVScoped' things
@@ -300,7 +301,8 @@ instance ProtectSig GhcTc where
 instance ProtectSig GhcRn where
   protectSig sc (HsWC a (HsIB b sig)) =
     HsWC a (HsIB b (SH sc sig))
-  protectSig _ _ = error "protectSig not given HsWC (HsIB)"
+  protectSig _ (HsWC _ (XHsImplicitBndrs nec)) = noExtCon nec
+  protectSig _ (XHsWildCardBndrs nec) = noExtCon nec
 
 class HasLoc a where
   -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can
@@ -351,6 +353,21 @@ instance HasLoc (HsDataDefn GhcRn) where
 instance HasLoc (Pat (GhcPass a)) where
   loc (dL -> L l _) = l
 
+{- Note [Real DataCon Name]
+The typechecker subtitutes the conLikeWrapId for the name, but we don't want
+this showing up in the hieFile, so we replace the name in the Id with the
+original datacon name
+See also Note [Data Constructor Naming]
+-}
+class HasRealDataConName p where
+  getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p)
+
+instance HasRealDataConName GhcRn where
+  getRealDataCon _ n = n
+instance HasRealDataConName GhcTc where
+  getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =
+    L sp (setVarName var (conLikeName con))
+
 -- | The main worker class
 class ToHie a where
   toHie :: a -> HieM [HieAST Type]
@@ -737,6 +754,7 @@ instance ( a ~ GhcPass p
          , Data (HsSplice a)
          , Data (HsTupArg a)
          , Data (AmbiguousFieldOcc a)
+         , (HasRealDataConName a)
          ) => ToHie (LHsExpr (GhcPass p)) where
   toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of
       HsVar _ (L _ var) ->
@@ -817,8 +835,9 @@ instance ( a ~ GhcPass p
       ExplicitList _ _ exprs ->
         [ toHie exprs
         ]
-      RecordCon {rcon_con_name = name, rcon_flds = binds}->
-        [ toHie $ C Use name
+      RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->
+        [ toHie $ C Use (getRealDataCon @a mrealcon name)
+            -- See Note [Real DataCon Name]
         , toHie $ RC RecFieldAssign $ binds
         ]
       RecordUpd {rupd_expr = expr, rupd_flds = upds}->
diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs
index 61e3d01d0e..a0d0881d9e 100644
--- a/compiler/hieFile/HieBin.hs
+++ b/compiler/hieFile/HieBin.hs
@@ -2,7 +2,7 @@
 Binary serialization for .hie files.
 -}
 {-# LANGUAGE ScopedTypeVariables #-}
-module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic) where
+module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic, hieNameOcc) where
 
 import GHC.Settings               ( maybeRead )
 
@@ -59,6 +59,15 @@ instance Outputable HieName where
   ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp
   ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u
 
+hieNameOcc :: HieName -> OccName
+hieNameOcc (ExternalName _ occ _) = occ
+hieNameOcc (LocalName occ _) = occ
+hieNameOcc (KnownKeyName u) =
+  case lookupKnownKeyName u of
+    Just n -> nameOccName n
+    Nothing -> pprPanic "hieNameOcc:unknown known-key unique"
+                        (ppr (unpkUnique u))
+
 
 data HieSymbolTable = HieSymbolTable
   { hie_symtab_next :: !FastMutInt
diff --git a/compiler/hieFile/HieDebug.hs b/compiler/hieFile/HieDebug.hs
index ffdfe431d3..855b89861e 100644
--- a/compiler/hieFile/HieDebug.hs
+++ b/compiler/hieFile/HieDebug.hs
@@ -16,6 +16,7 @@ import Outputable
 import HieTypes
 import HieBin
 import HieUtils
+import Name
 
 import qualified Data.Map as M
 import qualified Data.Set as S
@@ -56,20 +57,30 @@ type Diff a = a -> a -> [SDoc]
 diffFile :: Diff HieFile
 diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)
 
-diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (M.Map FastString (HieAST a))
+diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (M.Map FastString (HieAST a))
 diffAsts f = diffList (diffAst f) `on` M.elems
 
-diffAst :: (Outputable a, Eq a) => Diff a -> Diff (HieAST a)
+diffAst :: (Outputable a, Eq a,Ord a) => Diff a -> Diff (HieAST a)
 diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
     infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2
   where
     spanDiff
       | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]
       | otherwise = []
-    infoDiff
+    infoDiff'
       = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2
      ++ (diffList diffType `on` nodeType) info1 info2
      ++ (diffIdents `on` nodeIdentifiers) info1 info2
+    infoDiff = case infoDiff' of
+      [] -> []
+      xs -> xs ++ [vcat ["In Node:",ppr (nodeIdentifiers info1,span1)
+                           , "and", ppr (nodeIdentifiers info2,span2)
+                        , "While comparing"
+                        , ppr (normalizeIdents $ nodeIdentifiers info1), "and"
+                        , ppr (normalizeIdents $ nodeIdentifiers info2)
+                        ]
+                  ]
+
     diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b
     diffIdent (a,b) (c,d) = diffName a c
                          ++ eqDiff b d
@@ -81,10 +92,11 @@ diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =
 
 type DiffIdent = Either ModuleName HieName
 
-normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
-normalizeIdents = sortOn fst . map (first toHieName) . M.toList
+normalizeIdents :: Ord a => NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]
+normalizeIdents = sortOn go . map (first toHieName) . M.toList
   where
     first f (a,b) = (fmap f a, b)
+    go (a,b) = (hieNameOcc <$> a,identInfo b,identType b)
 
 diffList :: Diff a -> Diff [a]
 diffList f xs ys
@@ -122,10 +134,14 @@ validAst (Node _ span children) = do
 
 -- | Look for any identifiers which occur outside of their supposed scopes.
 -- Returns a list of error messages.
-validateScopes :: M.Map FastString (HieAST a) -> [SDoc]
-validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
+validateScopes :: Module -> M.Map FastString (HieAST a) -> [SDoc]
+validateScopes mod asts = validScopes
   where
     refMap = generateReferencesMap asts
+    -- We use a refmap for most of the computation
+
+    -- Check if all the names occur in their calculated scopes
+    validScopes = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
     valid (Left _) _ = []
     valid (Right n) refs = concatMap inScope refs
       where
@@ -134,13 +150,22 @@ validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap
           Just xs -> xs
           Nothing -> []
         inScope (sp, dets)
-          |  definedInAsts asts n
+          |  (definedInAsts asts n)
           && any isOccurrence (identInfo dets)
+          -- We validate scopes for names which are defined locally, and occur
+          -- in this span
             = case scopes of
-              [] -> []
+              [] | (nameIsLocalOrFrom mod n
+                   && not (isDerivedOccName $ nameOccName n))
+                   -- If we don't get any scopes for a local name then its an error.
+                   -- We can ignore derived names.
+                   -> return $ hsep $
+                     [ "Locally defined Name", ppr n,pprDefinedAt n , "at position", ppr sp
+                     , "Doesn't have a calculated scope: ", ppr scopes]
+                 | otherwise -> []
               _ -> if any (`scopeContainsSpan` sp) scopes
                    then []
                    else return $ hsep $
-                     [ "Name", ppr n, "at position", ppr sp
+                     [ "Name", ppr n, pprDefinedAt n, "at position", ppr sp
                      , "doesn't occur in calculated scope", ppr scopes]
           | otherwise = []
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 52501ec15f..47e23edf57 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -175,7 +175,7 @@ import qualified Data.Set as S
 import Data.Set (Set)
 
 import HieAst           ( mkHieFile )
-import HieTypes         ( getAsts, hie_asts )
+import HieTypes         ( getAsts, hie_asts, hie_module )
 import HieBin           ( readHieFile, writeHieFile , hie_file_result)
 import HieDebug         ( diffFile, validateScopes )
 
@@ -428,7 +428,8 @@ extract_renamed_stuff mod_summary tc_result = do
             hs_env <- Hsc $ \e w -> return (e, w)
             liftIO $ do
               -- Validate Scopes
-              case validateScopes $ getAsts $ hie_asts hieFile of
+              let mdl = hie_module hieFile
+              case validateScopes mdl $ getAsts $ hie_asts hieFile of
                   [] -> putMsg dflags $ text "Got valid scopes"
                   xs -> do
                     putMsg dflags $ text "Got invalid scopes"