Only use locally bound variables in pattern synonym declarations

Summary:
We were using the unconstrainted `lookupOccRn` function which looked up
any variable in scope. Instead we only want to consider variables brought into
scope by renaming the pattern on the RHS.

A few more changes to make reporting of unbound names suggest the correct
things.

Fixes #13470

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj

Subscribers: rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3377

5 files changed, 89 insertions, 12 deletions

diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index 705befd1bb..21d6095c27 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -635,13 +635,13 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
             case details of
                PrefixPatSyn vars ->
                    do { checkDupRdrNames vars
-                      ; names <- mapM lookupVar vars
+                      ; names <- mapM lookupPatSynBndr vars
                       ; return ( (pat', PrefixPatSyn names)
                                , mkFVs (map unLoc names)) }
                InfixPatSyn var1 var2 ->
                    do { checkDupRdrNames [var1, var2]
-                      ; name1 <- lookupVar var1
-                      ; name2 <- lookupVar var2
+                      ; name1 <- lookupPatSynBndr var1
+                      ; name2 <- lookupPatSynBndr var2
                       -- ; checkPrecMatch -- TODO
                       ; return ( (pat', InfixPatSyn name1 name2)
                                , mkFVs (map unLoc [name1, name2])) }
@@ -651,7 +651,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
                               (RecordPatSynField { recordPatSynSelectorId = visible
                                                  , recordPatSynPatVar = hidden })
                               = do { visible' <- lookupLocatedTopBndrRn visible
-                                   ; hidden'  <- lookupVar hidden
+                                   ; hidden'  <- lookupPatSynBndr hidden
                                    ; return $ RecordPatSynField { recordPatSynSelectorId = visible'
                                                                 , recordPatSynPatVar = hidden' } }
                       ; names <- mapM rnRecordPatSynField  vars
@@ -688,7 +688,8 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
           -- Why fvs1?  See Note [Pattern synonym builders don't yield dependencies]
       }
   where
-    lookupVar = wrapLocM lookupOccRn
+    -- See Note [Renaming pattern synonym variables]
+    lookupPatSynBndr = wrapLocM lookupLocalOccRn
 
     patternSynonymErr :: SDoc
     patternSynonymErr
@@ -696,6 +697,36 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name
            2 (text "Use -XPatternSynonyms to enable this extension")
 
 {-
+Note [Renaming pattern synonym variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We rename pattern synonym declaractions backwards to normal to reuse
+the logic already implemented for renaming patterns.
+
+We first rename the RHS of a declaration which brings into
+scope the variables bound by the pattern (as they would be
+in normal function definitions). We then lookup the variables
+which we want to bind in this local environment.
+
+It is crucial that we then only lookup in the *local* environment which
+only contains the variables brought into scope by the pattern and nothing
+else. Amazingly no-one encountered this bug for 3 GHC versions but
+it was possible to define a pattern synonym which referenced global
+identifiers and worked correctly.
+
+```
+x = 5
+
+pattern P :: Int -> ()
+pattern P x <- _
+
+f (P x) = x
+
+> f () = 5
+```
+
+See #13470 for the original report.
+
 Note [Pattern synonym builders don't yield dependencies]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When renaming a pattern synonym that has an explicit builder,
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index ae647f19a9..509e26e1fc 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -11,7 +11,7 @@ module RnEnv (
         lookupLocatedTopBndrRn, lookupTopBndrRn,
         lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,
         lookupLocalOccRn_maybe, lookupInfoOccRn,
-        lookupLocalOccThLvl_maybe,
+        lookupLocalOccThLvl_maybe, lookupLocalOccRn,
         lookupTypeOccRn, lookupKindOccRn,
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
         lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,
@@ -691,6 +691,15 @@ lookupOccRn rdr_name
            Just name -> return name
            Nothing   -> reportUnboundName rdr_name }
 
+-- Only used in one place, to rename pattern synonym binders.
+-- See Note [Renaming pattern synonym variables] in RnBinds
+lookupLocalOccRn :: RdrName -> RnM Name
+lookupLocalOccRn rdr_name
+  = do { mb_name <- lookupLocalOccRn_maybe rdr_name
+       ; case mb_name of
+           Just name -> return name
+           Nothing   -> unboundName WL_LocalOnly rdr_name }
+
 lookupKindOccRn :: RdrName -> RnM Name
 -- Looking up a name occurring in a kind
 lookupKindOccRn rdr_name
@@ -1795,6 +1804,10 @@ checkShadowedOccs (global_env,local_env) get_loc_occ ns
 data WhereLooking = WL_Any        -- Any binding
                   | WL_Global     -- Any top-level binding (local or imported)
                   | WL_LocalTop   -- Any top-level binding in this module
+                  | WL_LocalOnly
+                        -- Only local bindings
+                        -- (pattern synonyms declaractions,
+                        -- see Note [Renaming pattern synonym variables])
 
 reportUnboundName :: RdrName -> RnM Name
 reportUnboundName rdr = unboundName WL_Any rdr
@@ -1843,7 +1856,7 @@ unknownNameSuggestions_ :: WhereLooking -> DynFlags
                        -> RdrName -> SDoc
 unknownNameSuggestions_ where_look dflags global_env local_env imports tried_rdr_name =
     similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$
-    importSuggestions imports tried_rdr_name
+    importSuggestions where_look imports tried_rdr_name
 
 
 similarNameSuggestions :: WhereLooking -> DynFlags
@@ -1890,7 +1903,9 @@ similarNameSuggestions where_look dflags global_env
         -- This heuristic avoids things like
         --      Not in scope 'f'; perhaps you meant '+' (from Prelude)
 
-    local_ok = case where_look of { WL_Any -> True; _ -> False }
+    local_ok = case where_look of { WL_Any -> True
+                                  ; WL_LocalOnly -> True
+                                  ; _ -> False }
     local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]
     local_possibilities env
       | tried_is_qual = []
@@ -1902,8 +1917,9 @@ similarNameSuggestions where_look dflags global_env
 
     gre_ok :: GlobalRdrElt -> Bool
     gre_ok = case where_look of
-                   WL_LocalTop -> isLocalGRE
-                   _           -> \_ -> True
+                   WL_LocalTop  -> isLocalGRE
+                   WL_LocalOnly -> const False
+                   _            -> const True
 
     global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]
     global_possibilities global_env
@@ -1964,8 +1980,9 @@ similarNameSuggestions where_look dflags global_env
         | i <- is, let ispec = is_decl i, is_qual ispec ]
 
 -- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.
-importSuggestions :: ImportAvails -> RdrName -> SDoc
-importSuggestions imports rdr_name
+importSuggestions :: WhereLooking -> ImportAvails -> RdrName -> SDoc
+importSuggestions where_look imports rdr_name
+  | WL_LocalOnly <- where_look                 = Outputable.empty
   | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty
   | null interesting_imports
   , Just name <- mod_name
diff --git a/testsuite/tests/patsyn/should_fail/T13470.hs b/testsuite/tests/patsyn/should_fail/T13470.hs
new file mode 100644
index 0000000000..ec263b9f0a
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T13470.hs
@@ -0,0 +1,20 @@
+{-# Language PatternSynonyms #-}
+module T13470 where
+
+
+-- Used to suggest importing not
+pattern XInstrProxy :: (Bool -> Bool) -> a
+pattern XInstrProxy not <- _
+
+
+-- Used to suggest 'tan' from another module
+pattern P nan <- _
+
+
+
+-- Should suggest the inscope similar variable
+pattern P1 x12345 <- Just x123456
+
+
+-- But not this one
+x1234567 = True
diff --git a/testsuite/tests/patsyn/should_fail/T13470.stderr b/testsuite/tests/patsyn/should_fail/T13470.stderr
new file mode 100644
index 0000000000..748b5d1da2
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T13470.stderr
@@ -0,0 +1,8 @@
+
+T13470.hs:7:21: error: Not in scope: ‘not’
+
+T13470.hs:11:11: error: Not in scope: ‘nan’
+
+T13470.hs:16:12: error:
+    Not in scope: ‘x12345’
+    Perhaps you meant ‘x123456’ (line 16)
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index f674a8b258..86ec79a50c 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -35,3 +35,4 @@ test('T12165', normal, compile_fail, [''])
 test('T12819', normal, compile_fail, [''])
 test('UnliftedPSBind', normal, compile_fail, [''])
 test('T13349', normal, compile_fail, [''])
+test('T13470', normal, compile_fail, [''])