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

11 files changed, 159 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"
diff --git a/testsuite/tests/hiefile/should_compile/Scopes.hs b/testsuite/tests/hiefile/should_compile/Scopes.hs
new file mode 100644
index 0000000000..e3cbd8558f
--- /dev/null
+++ b/testsuite/tests/hiefile/should_compile/Scopes.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE RecordWildCards #-}
+module Scopes where
+data T = C { x :: Int, y :: Char }
+
+-- Verify that names generated from record construction are in scope
+foo = C { x = 1 , y = 'a' }
+
+-- Verify that record wildcards are in scope
+sdaf :: T
+sdaf = C{..}
+  where
+    x = 1
+    y = 'a'
diff --git a/testsuite/tests/hiefile/should_compile/Scopes.stderr b/testsuite/tests/hiefile/should_compile/Scopes.stderr
new file mode 100644
index 0000000000..f31d37d99f
--- /dev/null
+++ b/testsuite/tests/hiefile/should_compile/Scopes.stderr
@@ -0,0 +1,2 @@
+Got valid scopes
+Got no roundtrip errors
diff --git a/testsuite/tests/hiefile/should_compile/all.T b/testsuite/tests/hiefile/should_compile/all.T
index fb8092df95..fe0d6d74eb 100644
--- a/testsuite/tests/hiefile/should_compile/all.T
+++ b/testsuite/tests/hiefile/should_compile/all.T
@@ -11,3 +11,4 @@ test('hie009',       normal,                   compile, ['-fno-code -fwrite-ide-
 test('hie010',       normal,                   compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
 test('CPP',          normal,                   compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
 test('Constructors', normal,                   compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
+test('Scopes',       normal,                   compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
diff --git a/testsuite/tests/hiefile/should_run/PatTypes.hs b/testsuite/tests/hiefile/should_run/PatTypes.hs
new file mode 100644
index 0000000000..af5c42defa
--- /dev/null
+++ b/testsuite/tests/hiefile/should_run/PatTypes.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+module Main where
+
+import System.Environment
+
+import NameCache
+import SrcLoc
+import UniqSupply
+import Name
+
+import HieBin
+import HieTypes
+import HieUtils
+
+import DynFlags
+import SysTools
+
+import qualified Data.Map as M
+import Data.Foldable
+
+foo :: Maybe Char -> Char
+foo Nothing = 'a'
+--  1^
+foo (Just c) | c == 'a' =  c
+-- 2^    3^
+foo x = 'b'
+-- 4^
+
+p1,p2,p3,p4 :: (Int,Int)
+p1 = (22,6)
+p2 = (24,5)
+p3 = (24,11)
+p4 = (26,5)
+
+makeNc :: IO NameCache
+makeNc = do
+  uniq_supply <- mkSplitUniqSupply 'z'
+  return $ initNameCache uniq_supply []
+
+dynFlagsForPrinting :: String -> IO DynFlags
+dynFlagsForPrinting libdir = do
+  systemSettings <- initSysTools libdir
+  return $ defaultDynFlags systemSettings ([], [])
+
+selectPoint :: HieFile -> (Int,Int) -> HieAST Int
+selectPoint hf (sl,sc) = case M.toList (getAsts $ hie_asts hf) of
+    [(fs,ast)] ->
+      case selectSmallestContaining (sp fs) ast of
+        Nothing -> error "point not found"
+        Just ast' -> ast'
+    _ -> error "map should only contain a single AST"
+ where
+   sloc fs = mkRealSrcLoc fs sl sc
+   sp fs = mkRealSrcSpan (sloc fs) (sloc fs)
+
+main = do
+  libdir:_ <- getArgs
+  df <- dynFlagsForPrinting libdir
+  nc <- makeNc
+  (hfr, nc') <- readHieFile nc "PatTypes.hie"
+  let hf = hie_file_result hfr
+  forM_ [p1,p2,p3,p4] $ \point -> do
+    putStr $ "At " ++ show point ++ ", got type: "
+    let types = nodeType $ nodeInfo $ selectPoint hf point
+    forM_ types $ \typ -> do
+      putStrLn (renderHieType df $ recoverFullType typ (hie_types hf))
diff --git a/testsuite/tests/hiefile/should_run/PatTypes.stdout b/testsuite/tests/hiefile/should_run/PatTypes.stdout
new file mode 100644
index 0000000000..e86d3cc12a
--- /dev/null
+++ b/testsuite/tests/hiefile/should_run/PatTypes.stdout
@@ -0,0 +1,4 @@
+At (22,6), got type: Maybe Char
+At (24,5), got type: Maybe Char
+At (24,11), got type: Char
+At (26,5), got type: Maybe Char
diff --git a/testsuite/tests/hiefile/should_run/all.T b/testsuite/tests/hiefile/should_run/all.T
new file mode 100644
index 0000000000..738dadcbe5
--- /dev/null
+++ b/testsuite/tests/hiefile/should_run/all.T
@@ -0,0 +1 @@
+test('PatTypes', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info'])
diff --git a/utils/haddock b/utils/haddock
-Subproject 658ad4af237f3da196cca083ad525375260e38a
+Subproject 75f71980dfcd9a009e2eeb3a8690a473f47fcdf