[commit: ghc] ghc-7.8: Issue an error for pattern synonyms defined in a local scope (#8757) (4c5b195)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.8
Link       : http://ghc.haskell.org/trac/ghc/changeset/4c5b195b6846e83845cb2d5df9385906c19fd172/ghc

>---------------------------------------------------------------

commit 4c5b195b6846e83845cb2d5df9385906c19fd172
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Sun Feb 9 17:20:34 2014 +0800

    Issue an error for pattern synonyms defined in a local scope (#8757)
    
    This also fixes the internal crash when using pattern synonyms
    in GHCi (#8749)
    
    (cherry picked from commit e0a55415545074bc7a757462624079f54f7785e2)


>---------------------------------------------------------------

4c5b195b6846e83845cb2d5df9385906c19fd172
 compiler/rename/RnBinds.lhs              |    9 ++++++++-
 compiler/rename/RnPat.lhs                |    5 +++++
 testsuite/tests/patsyn/should_fail/all.T |    1 +
 3 files changed, 14 insertions(+), 1 deletion(-)

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index ed1343f..ba94a39 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -434,9 +434,16 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) })
        ; return (bind { fun_id = L nameLoc newname }) } 
 
 rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) })
-  = do { addLocM checkConName rdrname
+  = do { unless (isTopRecNameMaker name_maker) $
+           addErr localPatternSynonymErr
+       ; addLocM checkConName rdrname
        ; name <- applyNameMaker name_maker rdrname
        ; return (bind{ patsyn_id = L nameLoc name }) }
+  where
+    localPatternSynonymErr :: SDoc
+    localPatternSynonymErr
+      = hang (ptext (sLit "Illegal pattern synonym declaration"))
+           2 (ptext (sLit "Pattern synonym declarations are only valid in the top-level scope"))
 
 rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
 
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 3fde563..3c48f34 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -23,6 +23,7 @@ module RnPat (-- main entry points
               NameMaker, applyNameMaker,     -- a utility for making names:
               localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,
                                              --   sometimes we want to make top (qualified) names.
+              isTopRecNameMaker,
 
               rnHsRecFields1, HsRecFieldContext(..),
 
@@ -193,6 +194,10 @@ data NameMaker
 topRecNameMaker :: MiniFixityEnv -> NameMaker
 topRecNameMaker fix_env = LetMk TopLevel fix_env
 
+isTopRecNameMaker :: NameMaker -> Bool
+isTopRecNameMaker (LetMk TopLevel _) = True
+isTopRecNameMaker _ = False
+
 localRecNameMaker :: MiniFixityEnv -> NameMaker
 localRecNameMaker fix_env = LetMk NotTopLevel fix_env 
 
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index e1708d2..0a07aed 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -1,3 +1,4 @@
 
 test('mono', normal, compile_fail, [''])
 test('unidir', normal, compile_fail, [''])
+test('local', normal, compile_fail, [''])