Commit 46c19a89 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent d670b6f4
......@@ -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
......
......@@ -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))
......
......@@ -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.
......@@ -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
......
......@@ -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
......@@ -221,6 +221,17 @@ lookupTopBndrRn_maybe rdr_name
Just gre -> return (Just $ gre_name gre) }
-----------------------------------------------
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
......@@ -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))
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment