Refactor the way in which type (and other) signatures are renamed

This was a trickier change than I had anticipated, but I think
it's considerably tidier now.

Fixes Trac #5533.

5 files changed, 129 insertions, 112 deletions

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 7bc74e295b..7a5cd3b95a 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -727,25 +727,6 @@ isDefaultMethod (SpecPrags {})  = False
 \end{code}
 
 \begin{code}
-okBindSig :: Sig a -> Bool
-okBindSig _ = True
-
-okHsBootSig :: Sig a -> Bool
-okHsBootSig (TypeSig  _ _)    = True
-okHsBootSig (GenericSig  _ _) = False
-okHsBootSig (FixSig _) 	      = True
-okHsBootSig _                 = False
-
-okClsDclSig :: Sig a -> Bool
-okClsDclSig (SpecInstSig _) = False
-okClsDclSig _               = True        -- All others OK
-
-okInstDclSig :: Sig a -> Bool
-okInstDclSig (TypeSig _ _)    = False
-okInstDclSig (GenericSig _ _) = False
-okInstDclSig (FixSig _)       = False
-okInstDclSig _ 	              = True
-
 isFixityLSig :: LSig name -> Bool
 isFixityLSig (L _ (FixSig {})) = True
 isFixityLSig _	               = False
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index ad46cb038b..e60632321d 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -11,7 +11,7 @@ they may be affected by renaming (which isn't fully worked out yet).
 \begin{code}
 module RnBinds (
    -- Renaming top-level bindings
-   rnTopBinds, rnTopBindsLHS, rnTopBindsRHS, 
+   rnTopBindsLHS, rnTopBindsRHS, rnValBindsRHS,
 
    -- Renaming local bindings
    rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
@@ -20,7 +20,7 @@ module RnBinds (
    rnMethodBinds, renameSigs, mkSigTvFn,
    rnMatchGroup, rnGRHSs,
    makeMiniFixityEnv, MiniFixityEnv,
-   misplacedSigErr
+   HsSigCtxt(..)
    ) where
 
 import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
@@ -169,28 +169,14 @@ rnTopBindsRHS binds
   = do { is_boot <- tcIsHsBoot
        ; if is_boot 
          then rnTopBindsBoot binds
-         else rnValBindsRHS Nothing   -- Allow SPEC prags for imports
-                            binds }
-
--- Wrapper if we don't need to do anything in between the left and right,
--- or anything else in the scope of the left
---
--- Never used when there are fixity declarations
-rnTopBinds :: HsValBinds RdrName 
-           -> RnM (HsValBinds Name, DefUses)
-rnTopBinds b
-  = do { nl <- rnTopBindsLHS emptyFsEnv b
-       ; let bound_names = collectHsValBinders nl
-       ; bindLocalNames bound_names $ 
-         rnValBindsRHS (Just (mkNameSet bound_names)) nl }
-       
+         else rnValBindsRHS TopSigCtxt binds }
 
 rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
 -- A hs-boot file has no bindings. 
 -- Return a single HsBindGroup with empty binds and renamed signatures
 rnTopBindsBoot (ValBindsIn mbinds sigs)
   = do	{ checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
-	; sigs' <- renameSigs Nothing okHsBootSig sigs
+	; sigs' <- renameSigs HsBootCtxt sigs
 	; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }
 rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
 \end{code}
@@ -292,13 +278,12 @@ rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
 -- Assumes the LHS vars are in scope
 --
 -- Does not bind the local fixity declarations
-rnValBindsRHS :: Maybe NameSet	-- Names bound by the LHSes
-	       	  		-- Nothing if expect sigs for imports
-               -> HsValBindsLR Name RdrName
-               -> RnM (HsValBinds Name, DefUses)
+rnValBindsRHS :: HsSigCtxt 
+              -> HsValBindsLR Name RdrName
+              -> RnM (HsValBinds Name, DefUses)
 
-rnValBindsRHS mb_bound_names (ValBindsIn mbinds sigs)
-  = do { sigs' <- renameSigs mb_bound_names okBindSig sigs
+rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
+  = do { sigs' <- renameSigs ctxt sigs
        ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs')) mbinds
        ; case depAnalBinds binds_w_dus of
            (anal_binds, anal_dus) -> return (valbind', valbind'_dus)
@@ -322,7 +307,7 @@ rnLocalValBindsRHS :: NameSet  -- names bound by the LHSes
                    -> HsValBindsLR Name RdrName
                    -> RnM (HsValBinds Name, DefUses)
 rnLocalValBindsRHS bound_names binds
-  = rnValBindsRHS (Just bound_names) binds
+  = rnValBindsRHS (LocalBindCtxt bound_names) binds
 
 -- for local binds
 -- wrapper that does both the left- and right-hand sides 
@@ -654,12 +639,11 @@ At the moment we don't gather free-var info from the types in
 signatures.  We'd only need this if we wanted to report unused tyvars.
 
 \begin{code}
-renameSigs :: Maybe NameSet		-- If (Just ns) complain if the sig isn't for one of ns
-	   -> (Sig Name -> Bool) 	-- Complain about the wrong kind of signature if this is False
+renameSigs :: HsSigCtxt 
 	   -> [LSig RdrName]
 	   -> RnM [LSig Name]
 -- Renames the signatures and performs error checks
-renameSigs mb_names ok_sig sigs 
+renameSigs ctxt sigs 
   = do	{ mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs)  -- Duplicate
 	  	-- Check for duplicates on RdrName version, 
 		-- because renamed version has unboundName for
@@ -670,9 +654,9 @@ renameSigs mb_names ok_sig sigs
 		--	       op :: a -> a
  		--             default op :: Eq a => a -> a
 		
-	; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs
+	; sigs' <- mapM (wrapLocM (renameSig ctxt)) sigs
 
-	; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs'
+	; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
 	; mapM_ misplacedSigErr bad_sigs		 -- Misplaced
 
 	; return good_sigs } 
@@ -687,19 +671,20 @@ renameSigs mb_names ok_sig sigs
 -- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)
 -- Doesn't seem worth much trouble to sort this.
 
-renameSig :: Maybe NameSet -> Sig RdrName -> RnM (Sig Name)
+renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name)
 -- FixitySig is renamed elsewhere.
 renameSig _ (IdSig x)
   = return (IdSig x)	  -- Actually this never occurs
-renameSig mb_names sig@(TypeSig vs ty)
-  = do	{ new_vs <- mapM (lookupSigOccRn mb_names sig) vs
+
+renameSig ctxt sig@(TypeSig vs ty)
+  = do	{ new_vs <- mapM (lookupSigOccRn ctxt sig) vs
 	; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty
 	; return (TypeSig new_vs new_ty) }
 
-renameSig mb_names sig@(GenericSig vs ty)
+renameSig ctxt sig@(GenericSig vs ty)
   = do	{ defaultSigs_on <- xoptM Opt_DefaultSignatures
         ; unless defaultSigs_on (addErr (defaultSigErr sig))
-        ; new_v <- mapM (lookupSigOccRn mb_names sig) vs
+        ; new_v <- mapM (lookupSigOccRn ctxt sig) vs
 	; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty
 	; return (GenericSig new_v new_ty) }
 
@@ -711,23 +696,49 @@ renameSig _ (SpecInstSig ty)
 -- so, in the top-level case (when mb_names is Nothing)
 -- we use lookupOccRn.  If there's both an imported and a local 'f'
 -- then the SPECIALISE pragma is ambiguous, unlike all other signatures
-renameSig mb_names sig@(SpecSig v ty inl)
-  = do	{ new_v <- case mb_names of
-                     Just {} -> lookupSigOccRn mb_names sig v
-                     Nothing -> lookupLocatedOccRn v
+renameSig ctxt sig@(SpecSig v ty inl)
+  = do	{ new_v <- case ctxt of 
+                     TopSigCtxt -> lookupLocatedOccRn v
+                     _          -> lookupSigOccRn ctxt sig v
 	; new_ty <- rnHsSigType (quotes (ppr v)) ty
 	; return (SpecSig new_v new_ty inl) }
 
-renameSig mb_names sig@(InlineSig v s)
-  = do	{ new_v <- lookupSigOccRn mb_names sig v
+renameSig ctxt sig@(InlineSig v s)
+  = do	{ new_v <- lookupSigOccRn ctxt sig v
 	; return (InlineSig new_v s) }
 
-renameSig mb_names sig@(FixSig (FixitySig v f))
-  = do	{ new_v <- lookupSigOccRn mb_names sig v
+renameSig ctxt sig@(FixSig (FixitySig v f))
+  = do	{ new_v <- lookupSigOccRn ctxt sig v
 	; return (FixSig (FixitySig new_v f)) }
 
 ppr_sig_bndrs :: [Located RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
+
+okHsSig :: HsSigCtxt -> LSig a -> Bool
+okHsSig ctxt (L _ sig) 
+  = case (sig, ctxt) of
+     (GenericSig {}, ClsDeclCtxt {}) -> True
+     (GenericSig {}, _)              -> False
+
+     (TypeSig {}, InstDeclCtxt {}) -> False
+     (TypeSig {}, _)               -> True
+
+     (FixSig {}, InstDeclCtxt {}) -> False
+     (FixSig {}, _)               -> True
+
+     (IdSig {}, TopSigCtxt) -> True
+     (IdSig {}, _)          -> False
+
+     (InlineSig {}, HsBootCtxt) -> False
+     (InlineSig {}, _)          -> True
+
+     (SpecSig {}, TopSigCtxt)       -> True
+     (SpecSig {}, LocalBindCtxt {}) -> True
+     (SpecSig {}, InstDeclCtxt {})  -> True
+     (SpecSig {}, _)                -> False
+
+     (SpecInstSig {}, InstDeclCtxt {}) -> True
+     (SpecInstSig {}, _)               -> False
 \end{code}
 
 
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 9771ab16a8..a7007111a0 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -9,7 +9,9 @@ module RnEnv (
 	lookupLocatedTopBndrRn, lookupTopBndrRn,
 	lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe,
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
-	lookupLocalDataTcNames, lookupSigOccRn,
+
+	HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn,
+
 	lookupFixityRn, lookupTyFixityRn, 
 	lookupInstDeclBndr, lookupSubBndr, 
         lookupSubBndrGREs, lookupConstructorFields,
@@ -427,14 +429,16 @@ lookupLocalOccRn_maybe rdr_name
        ; return (lookupLocalRdrEnv local_env rdr_name) }
 
 -- lookupOccRn looks up an occurrence of a RdrName
-lookupOccRn :: RdrName -> RnM Name
-lookupOccRn rdr_name
+lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)
+lookupOccRn_maybe rdr_name
   = do { local_env <- getLocalRdrEnv
-       ; case lookupLocalRdrEnv local_env rdr_name of {
-          Just name -> return name ;
-          Nothing   -> do
+       ; case lookupLocalRdrEnv local_env rdr_name of 
+          Just name -> return (Just name)
+          Nothing   -> lookupGlobalOccRn_maybe rdr_name }
 
-       { mb_name <- lookupGlobalOccRn_maybe rdr_name
+lookupOccRn :: RdrName -> RnM Name
+lookupOccRn rdr_name
+  = do { mb_name <- lookupOccRn_maybe rdr_name
        ; case mb_name of {
 		Just n  -> return n ;
 		Nothing -> do
@@ -449,7 +453,7 @@ lookupOccRn rdr_name
        ; if isQual rdr_name && allow_qual && is_ghci
          then lookupQualifiedName rdr_name
          else do { traceRn (text "lookupOccRn" <+> ppr rdr_name)
-                 ; unboundName WL_Any rdr_name } } } } } }
+                 ; unboundName WL_Any rdr_name } } } }
 
 
 lookupGlobalOccRn :: RdrName -> RnM Name
@@ -588,67 +592,88 @@ return the imported 'f', so that later on the reanamer will
 correctly report "misplaced type sig".
 
 \begin{code}
-lookupSigOccRn :: Maybe NameSet	   -- Just ns => these are the binders
-				   -- 	 	 in the same group
-				   -- Nothing => signatures without 
-				   -- 		 binders are expected
-				   --		 (a) top-level (SPECIALISE prags)
-				   -- 		 (b) class decls
-				   --		 (c) hs-boot files
+data HsSigCtxt 
+  = HsBootCtxt		     -- Top level of a hs-boot file
+  | TopSigCtxt		     -- At top level
+  | LocalBindCtxt NameSet    -- In a local binding, binding these names
+  | ClsDeclCtxt   Name	     -- Class decl for this class
+  | InstDeclCtxt  Name	     -- Intsance decl for this class
+
+lookupSigOccRn :: HsSigCtxt
 	       -> Sig RdrName
 	       -> Located RdrName -> RnM (Located Name)
-lookupSigOccRn mb_bound_names sig
+lookupSigOccRn ctxt sig
   = wrapLocM $ \ rdr_name -> 
-    do { mb_name <- lookupBindGroupOcc mb_bound_names (hsSigDoc sig) rdr_name
+    do { mb_name <- lookupBindGroupOcc ctxt (hsSigDoc sig) rdr_name
        ; case mb_name of
 	   Left err   -> do { addErr err; return (mkUnboundName rdr_name) }
 	   Right name -> return name }
 
-lookupBindGroupOcc :: Maybe NameSet  -- See notes on the (Maybe NameSet)
-	           -> SDoc           --  in lookupSigOccRn
+lookupBindGroupOcc :: HsSigCtxt
+	           -> SDoc     
 	           -> RdrName -> RnM (Either Message Name)
 -- Looks up the RdrName, expecting it to resolve to one of the 
 -- bound names passed in.  If not, return an appropriate error message
 --
 -- See Note [Looking up signature names]
-lookupBindGroupOcc mb_bound_names what rdr_name
+lookupBindGroupOcc ctxt what rdr_name
   | Just n <- isExact_maybe rdr_name
   = do { n' <- lookupExactOcc n
-       ; check_local_name n' }
+       ; return (Right n') }  -- Maybe we should check the side conditions
+       	 	      	      -- but it's a pain, and Exact things only show
+			      -- up when you know what you are doing
   | otherwise
-  = do  { local_env <- getLocalRdrEnv
-        ; case lookupLocalRdrEnv local_env rdr_name of {
-            Just n  -> check_local_name n;
-            Nothing -> do       -- Not defined in a nested scope
-
-        { env <- getGlobalRdrEnv 
-        ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
-        ; case (filter isLocalGRE gres) of
-            (gre:_) -> check_local_name (gre_name gre)
+  = case ctxt of 
+      HsBootCtxt       -> lookup_top		    
+      TopSigCtxt       -> lookup_top
+      LocalBindCtxt ns -> lookup_group ns
+      ClsDeclCtxt  cls -> lookup_cls_op cls
+      InstDeclCtxt cls -> lookup_cls_op cls
+  where
+    lookup_cls_op cls
+      = do { env <- getGlobalRdrEnv 
+           ; let gres = lookupSubBndrGREs env (ParentIs cls) rdr_name
+           ; case gres of
+               []      -> return (Left (unknownSubordinateErr doc rdr_name))
+               (gre:_) -> return (Right (gre_name gre)) }
                         -- If there is more than one local GRE for the 
                         -- same OccName 'f', that will be reported separately
                         -- as a duplicate top-level binding for 'f'
-            [] | null gres -> bale_out_with empty
-               | otherwise -> bale_out_with import_msg
-        }}}
-  where
-      check_local_name name 	-- The name is in scope, and not imported
-  	  = case mb_bound_names of
-  		  Just bound_names | not (name `elemNameSet` bound_names)
-				   -> bale_out_with local_msg
-	 	  _other -> return (Right name)
-
-      bale_out_with msg 
+      where
+        doc = ptext (sLit "method of class") <+> quotes (ppr cls)
+
+    lookup_top
+      = do { env <- getGlobalRdrEnv 
+           ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
+           ; case filter isLocalGRE gres of
+               [] | null gres -> bale_out_with empty
+                  | otherwise -> bale_out_with (bad_msg (ptext (sLit "an imported value")))
+               (gre:_) 
+                  | ParentIs {} <- gre_par gre
+		  -> bale_out_with (bad_msg (ptext (sLit "a record selector or class method")))
+		  | otherwise
+                  -> return (Right (gre_name gre)) }
+
+    lookup_group bound_names
+      = do { mb_name <- lookupOccRn_maybe rdr_name
+           ; case mb_name of
+               Just n  
+                 | n `elemNameSet` bound_names -> return (Right n)
+                 | otherwise                   -> bale_out_with local_msg
+               Nothing                         -> bale_out_with empty }
+
+    bale_out_with msg 
   	= return (Left (sep [ ptext (sLit "The") <+> what
   				<+> ptext (sLit "for") <+> quotes (ppr rdr_name)
   			   , nest 2 $ ptext (sLit "lacks an accompanying binding")]
   		       $$ nest 2 msg))
 
-      local_msg = parens $ ptext (sLit "The")  <+> what <+> ptext (sLit "must be given where")
+    local_msg = parens $ ptext (sLit "The")  <+> what <+> ptext (sLit "must be given where")
   			   <+> quotes (ppr rdr_name) <+> ptext (sLit "is declared")
 
-      import_msg = parens $ ptext (sLit "You cannot give a") <+> what
-    			  <+> ptext (sLit "for an imported value")
+    bad_msg thing = parens $ ptext (sLit "You cannot give a") <+> what
+    			  <+> ptext (sLit "for") <+> thing
+
 
 ---------------
 lookupLocalDataTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name]
@@ -660,7 +685,7 @@ lookupLocalDataTcNames bndr_set what rdr_name
 	-- Special case for (:), which doesn't get into the GlobalRdrEnv
   = do { n' <- lookupExactOcc n; return [n'] }	-- For this we don't need to try the tycon too
   | otherwise
-  = do	{ mb_gres <- mapM (lookupBindGroupOcc (Just bndr_set) what)
+  = do	{ mb_gres <- mapM (lookupBindGroupOcc (LocalBindCtxt bndr_set) what)
 			  (dataTcOccs rdr_name)
 	; let (errs, names) = splitEithers mb_gres
 	; when (null names) (addErr (head errs))	-- Bleat about one only
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 1f58e42065..9c8afae1fe 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -449,9 +449,8 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	--
 	-- But the (unqualified) method names are in scope
        ; let binders = collectHsBindsBinders mbinds'
-	     bndr_set = mkNameSet binders
        ; uprags' <- bindLocalNames binders $
-	            renameSigs (Just bndr_set) okInstDclSig uprags
+	            renameSigs (InstDeclCtxt cls) uprags
 
        ; return (InstDecl inst_ty' mbinds' uprags' ats',
 	         meth_fvs `plusFV` at_fvs
@@ -798,7 +797,7 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
 	     ; fds'  <- rnFds cls_doc fds
              ; let rn_at = rnTyClDecl (Just cls')
              ; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats
-	     ; sigs' <- renameSigs Nothing okClsDclSig sigs
+	     ; sigs' <- renameSigs (ClsDeclCtxt cls') sigs
              ; (at_defs', fv_at_defs) <- mapAndUnzipM (wrapLocFstM rn_at) at_defs
 	     ; let fvs = extractHsCtxtTyNames context'	`plusFV`
 	                 hsSigsFVs sigs'                `plusFV`
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index f28d728c1f..1a7db7abf5 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -382,8 +382,9 @@ renameDeriv is_boot inst_infos bagBinds
 	; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds
 	; let aux_val_binds = ValBindsIn aux_binds (bagToList aux_sigs)
 	; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
-	; bindLocalNames (collectHsValBinders rn_aux_lhs) $
-    do	{ (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs
+        ; let bndrs = collectHsValBinders rn_aux_lhs
+	; bindLocalNames bndrs $ 
+    do	{ (rn_aux, dus_aux) <- rnValBindsRHS (LocalBindCtxt (mkNameSet bndrs)) rn_aux_lhs
 	; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
 	; return (listToBag rn_inst_infos, rn_aux,
                   dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }