Another run at binders in Template Haskell (fixes Trac #5379)

TH quotation was using mkName rather than newName for
top-level definitions, which is plain wrong as #5379
points out.

5 files changed, 33 insertions, 52 deletions

diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index 053c6ecb18..68b5116749 100644
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -320,7 +320,6 @@ extendLocalRdrEnvList env names
   = extendOccEnvList env [(nameOccName n, n) | n <- names]
 
 lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name
-lookupLocalRdrEnv _   (Exact name) = Just name
 lookupLocalRdrEnv env (Unqual occ) = lookupOccEnv env occ
 lookupLocalRdrEnv _   _            = Nothing
 
@@ -437,7 +436,8 @@ globalRdrEnvElts :: GlobalRdrEnv -> [GlobalRdrElt]
 globalRdrEnvElts env = foldOccEnv (++) [] env
 
 instance Outputable GlobalRdrElt where
-  ppr gre = ppr name <+> parens (ppr (gre_par gre) <+> pprNameProvenance gre)
+  ppr gre = hang (ppr name)
+               2 (parens (ppr (gre_par gre) <+> pprNameProvenance gre))
 	  where
 	    name = gre_name gre
 
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 8d0082ad21..6157843f2c 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -103,7 +103,7 @@ dsBracket brack splices
 repTopP :: LPat Name -> DsM (Core TH.PatQ)
 repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) 
                  ; pat' <- addBinds ss (repLP pat)
-                 ; wrapNongenSyms ss pat' }
+                 ; wrapGenSyms ss pat' }
 
 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 repTopDs group
@@ -132,8 +132,7 @@ repTopDs group
 	dec_ty <- lookupType decTyConName ;
 	q_decs  <- repSequenceQ dec_ty core_list ;
 
-	wrapNongenSyms ss q_decs
-	-- Do *not* gensym top-level binders
+	wrapGenSyms ss q_decs
       }
 
 
@@ -311,11 +310,9 @@ repInstD' (L loc (InstDecl ty binds _ ats))	-- Ignore user pragmas for now
 		   ; ss <- mkGenSyms (collectHsBindsBinders binds)
 		   ; binds1 <- addBinds ss (rep_binds binds)
                    ; ats1   <- repLAssocFamInst ats
-		   ; decls1 <- coreList decQTyConName (ats1 ++ binds1)
-		   ; decls2 <- wrapNongenSyms ss decls1
-		   -- wrapNongenSyms: do not clone the class op names!
-		   -- They must be called 'op' etc, not 'op34'
-		   ; repInst cxt1 inst_ty1 (decls2)
+		   ; decls <- coreList decQTyConName (ats1 ++ binds1)
+		   ; inst_decl <- repInst cxt1 inst_ty1 decls
+		   ; wrapGenSyms ss inst_decl
                    }
 	; return (loc, i)}
  where
@@ -1255,21 +1252,6 @@ wrapGenSyms binds body@(MkC b)
 	   ; repBindQ var_ty elt_ty 
 		      gensym_app (MkC (Lam id body')) }
 
--- Just like wrapGenSym, but don't actually do the gensym
--- Instead use the existing name:
---	let x = "x" in ...
--- Only used for [Decl], and for the class ops in class 
--- and instance decls
-wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a)
-wrapNongenSyms binds (MkC body)
-  = do { binds' <- mapM do_one binds ;
-	 return (MkC (mkLets binds' body)) }
-  where
-    do_one (name,id) 
-	= do { MkC lit_str <- occNameLit name
-	     ; MkC var <- rep2 mkNameName [lit_str]
-	     ; return (NonRec id var) }
-
 occNameLit :: Name -> DsM (Core String)
 occNameLit n = coreStringLit (occNameString (nameOccName n))
 
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 7a86c8180f..158a9c73d2 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -928,7 +928,8 @@ badOcc ctxt_ns occ
 	<+> ptext (sLit "name:") <+> quotes (text occ)
 
 thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
--- This turns a Name into a RdrName
+-- This turns a TH Name into a RdrName; used for both binders and occurrences
+-- See Note [Binders in Template Haskell]
 -- The passed-in name space tells what the context is expecting;
 --	use it unless the TH name knows what name-space it comes
 -- 	from, in which case use the latter
@@ -1023,7 +1024,7 @@ a) We don't want to complain about "x" being bound twice in
    the pattern [x1,x2]
 b) We don't want x3 to shadow the x1,x2
 c) We *do* want 'x' (dynamically bound with mkName) to bind 
-   to the innermost binding of "x", namely x3.. (In this
+   to the innermost binding of "x", namely x3.
 d) When pretty printing, we want to print a unique with x1,x2 
    etc, else they'll all print as "x" which isn't very helpful
 
@@ -1038,7 +1039,7 @@ Achieving (a) is a bit awkward, because
      RdrNames arising from TH and the Unqual RdrNames that would
      come from a user writing \[x,x] -> blah
 
-So in Convert (here) we translate
+So in Convert.thRdrName we translate
    TH Name		            RdrName
    --------------------------------------------------------
    NameU (arising from newName) --> Exact (Name{ System })
@@ -1063,4 +1064,4 @@ So RnEnv.newGlobalBinder we spot Exact RdrNames that wrap a
 non-External Name, and make an External name for.  (Remember, 
 constructors and the like need External Names.)  Oddly, the 
 *occurrences* will continue to be that (non-External) System Name, 
-but that will come out in the wash.
+but the first sweep of the optimiser will fix that.
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index fcf7c31c08..befee32e3e 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -870,7 +870,7 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
         | isWiredInName name = mv_map  -- ignore wired-in names
         | otherwise
         = case nameModule_maybe name of
-             Nothing  -> ASSERT( isSystemName name ) mv_map
+             Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map
 	     	-- See Note [Internal used_names]
 
              Just mod -> -- This lambda function is really just a
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index e2f9805f97..f2a0649f6e 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module RnEnv ( 
-	newTopSrcBinder, lookupFamInstDeclBndr,
+	newTopSrcBinder, 
 	lookupLocatedTopBndrRn, lookupTopBndrRn,
 	lookupLocatedOccRn, lookupOccRn, 
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
@@ -197,7 +197,7 @@ lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)
 
 lookupTopBndrRn_maybe rdr_name
   | Just name <- isExact_maybe rdr_name
-  = return (Just name)
+  = do { name' <- lookupExactOcc name; return (Just name') }
 
   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name	
 	-- This deals with the case of derived bindings, where
@@ -222,6 +222,17 @@ lookupTopBndrRn_maybe rdr_name
 	      
 
 -----------------------------------------------
+lookupExactOcc :: Name -> RnM Name
+lookupExactOcc name
+  | isExternalName name = return name
+  | otherwise           = do { env <- getGlobalRdrEnv
+    			     ; let gres = lookupGRE_Name env name
+                             ; case gres of
+                                 []    -> return name
+                                 [gre] -> return (gre_name gre)
+                                 _     -> pprPanic "lookupExactOcc" (ppr name $$ ppr gres) }
+
+-----------------------------------------------
 lookupInstDeclBndr :: Name -> RdrName -> RnM Name
 -- This is called on the method name on the left-hand side of an 
 -- instance declaration binding. eg.  instance Functor T where
@@ -283,7 +294,7 @@ lookupSubBndr :: Parent  -- NoParent   => just look it up as usual
               -> RnM Name
 lookupSubBndr parent doc rdr_name
   | Just n <- isExact_maybe rdr_name   -- This happens in derived code
-  = return n
+  = lookupExactOcc n
 
   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
   = lookupOrig rdr_mod rdr_occ
@@ -339,18 +350,6 @@ lookupSubBndrGREs env parent rdr_name
 
 newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name)
 newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr)
-
--- If the family is declared locally, it will not yet be in the main
--- environment; hence, we pass in an extra one here, which we check first.
--- See "Note [Looking up family names in family instances]" in 'RnNames'.
---
-lookupFamInstDeclBndr :: GlobalRdrEnv -> Located RdrName -> RnM Name
-lookupFamInstDeclBndr tyclGroupEnv (L loc rdr_name)
-  = setSrcSpan loc $
-      case lookupGRE_RdrName rdr_name tyclGroupEnv of
-        (gre:_) -> return $ gre_name gre
-          -- if there is more than one, an error will be raised elsewhere
-        []      -> lookupOccRn rdr_name
 \end{code}
 
 Note [Usage for sub-bndrs]
@@ -425,10 +424,11 @@ lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)
 
 lookupGlobalOccRn_maybe rdr_name
   | Just n <- isExact_maybe rdr_name   -- This happens in derived code
-  = return (Just n)
+  = do { n' <- lookupExactOcc n; return (Just n') }
 
   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-  = do { n <- lookupOrig rdr_mod rdr_occ; return (Just n) }
+  = do { n <- lookupOrig rdr_mod rdr_occ
+       ; return (Just n) }
 
   | otherwise
   = do	{ mb_gre <- lookupGreRn_maybe rdr_name
@@ -453,8 +453,7 @@ lookupGreRn rdr_name
 	; case mb_gre of {
 	    Just gre -> return gre ;
 	    Nothing  -> do
-	{ traceRn $ text "lookupGreRn"
-        ; name <- unboundName WL_Global rdr_name
+	{ name <- unboundName WL_Global rdr_name
 	; return (GRE { gre_name = name, gre_par = NoParent,
 		        gre_prov = LocalDef }) }}}
 
@@ -610,7 +609,7 @@ lookupLocalDataTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name]
 lookupLocalDataTcNames bound_names what rdr_name
   | Just n <- isExact_maybe rdr_name	
 	-- Special case for (:), which doesn't get into the GlobalRdrEnv
-  = return [n]	-- For this we don't need to try the tycon too
+  = do { n' <- lookupExactOcc n; return [n'] }	-- For this we don't need to try the tycon too
   | otherwise
   = do	{ mb_gres <- mapM (lookupBindGroupOcc (Just bound_names) what)
 			  (dataTcOccs rdr_name)
@@ -834,8 +833,7 @@ newLocalBndrRn :: Located RdrName -> RnM Name
 newLocalBndrRn (L loc rdr_name)
   | Just name <- isExact_maybe rdr_name 
   = return name	-- This happens in code generated by Template Haskell
-		-- although I'm not sure why. Perhpas it's the call
-		-- in RnPat.newName LetMk?
+    	   	-- See Note [Binders in Template Haskell] in Convert.lhs
   | otherwise
   = do { unless (isUnqual rdr_name)
 	        (addErrAt loc (badQualBndrErr rdr_name))