---------------------------------
Template Haskell: names again
---------------------------------
On 2 Dec 04 I made this commit (1.58 in Convert.lhs)
Fix a Template Haskell bug that meant that top-level names created
with newName were not made properly unique.
But that just introduced a new bug! THe trouble is that names created by
newName are NameUs; but I was *also* using NameU for names of free varaibles,
such as the 'x' in the quoted code here
f x = $( g [| \y -> (x,y) |])
But when converting to HsSyn, the x and y must be treated diffferently.
The 'x' must convert to an Exact RdrName, so that it binds to the 'x' that's
in the type environment; but the 'y' must generate a nice unique RdrName.
So this commit adds NameL for the lexically-scoped bindings like 'x'.
| otherwise
= do { MkC occ <- occNameLit name
; MkC uni <- coreIntLit (getKey (getUnique name))
| otherwise
= do { MkC occ <- occNameLit name
; MkC uni <- coreIntLit (getKey (getUnique name))
- ; rep2 mkNameUName [occ,uni] }
+ ; rep2 mkNameLName [occ,uni] }
where
name_mod = moduleUserString (nameModule name)
name_occ = nameOccName name
where
name_mod = moduleUserString (nameModule name)
name_occ = nameOccName name
templateHaskellNames = [
returnQName, bindQName, sequenceQName, newNameName, liftName,
templateHaskellNames = [
returnQName, bindQName, sequenceQName, newNameName, liftName,
- mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameUName,
+ mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
-- Lit
charLName, stringLName, integerLName, intPrimLName,
-- Lit
charLName, stringLName, integerLName, intPrimLName,
mkNameG_vName = thFun FSLIT("mkNameG_v") mkNameG_vIdKey
mkNameG_dName = thFun FSLIT("mkNameG_d") mkNameG_dIdKey
mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
mkNameG_vName = thFun FSLIT("mkNameG_v") mkNameG_vIdKey
mkNameG_dName = thFun FSLIT("mkNameG_d") mkNameG_dIdKey
mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
-mkNameUName = thFun FSLIT("mkNameU") mkNameUIdKey
+mkNameLName = thFun FSLIT("mkNameL") mkNameLIdKey
-------------------- TH.Lib -----------------------
-------------------- TH.Lib -----------------------
mkNameG_vIdKey = mkPreludeMiscIdUnique 206
mkNameG_dIdKey = mkPreludeMiscIdUnique 207
mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
mkNameG_vIdKey = mkPreludeMiscIdUnique 206
mkNameG_dIdKey = mkPreludeMiscIdUnique 207
mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
-mkNameUIdKey = mkPreludeMiscIdUnique 209
+mkNameLIdKey = mkPreludeMiscIdUnique 209
import HsSyn as Hs
import qualified Class (FunDep)
import HsSyn as Hs
import qualified Class (FunDep)
-import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName )
+import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName, nameRdrName )
+import Name ( mkInternalName )
import Module ( Module, mkModule )
import RdrHsSyn ( mkClassDecl, mkTyData )
import qualified OccName
import Module ( Module, mkModule )
import RdrHsSyn ( mkClassDecl, mkTyData )
import qualified OccName
CExportSpec(..))
import Char ( isAscii, isAlphaNum, isAlpha )
import List ( partition )
CExportSpec(..))
import Char ( isAscii, isAlphaNum, isAlpha )
import List ( partition )
-import Unique ( mkUniqueGrimily )
+import Unique ( Unique, mkUniqueGrimily )
import ErrUtils (Message)
import ErrUtils (Message)
-import GLAEXTS ( Int(..) )
+import GLAEXTS ( Int(..), Int# )
+import SrcLoc ( noSrcLoc )
import Bag ( emptyBag, consBag )
import FastString
import Outputable
import Bag ( emptyBag, consBag )
import FastString
import Outputable
thRdrName ns (TH.Name occ TH.NameS) = mkRdrUnqual (mk_occ ns occ)
thRdrName ns (TH.Name occ (TH.NameQ mod)) = mkRdrQual (mk_mod mod) (mk_occ ns occ)
thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ)
thRdrName ns (TH.Name occ TH.NameS) = mkRdrUnqual (mk_occ ns occ)
thRdrName ns (TH.Name occ (TH.NameQ mod)) = mkRdrQual (mk_mod mod) (mk_occ ns occ)
thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ)
+thRdrName ns (TH.Name occ (TH.NameL uniq)) = nameRdrName (mkInternalName (mk_uniq uniq) (mk_occ ns occ) noSrcLoc)
thRdrName ns (TH.Name occ (TH.NameU uniq))
= mkRdrUnqual (OccName.mkOccName ns uniq_str)
where
thRdrName ns (TH.Name occ (TH.NameU uniq))
= mkRdrUnqual (OccName.mkOccName ns uniq_str)
where
- uniq_str = TH.occString occ ++ '[' : shows (mkUniqueGrimily (I# uniq)) "]"
+ uniq_str = TH.occString occ ++ '[' : shows (mk_uniq uniq) "]"
-- The idea here is to make a name that
-- a) the user could not possibly write, and
-- b) cannot clash with another NameU
-- The idea here is to make a name that
-- a) the user could not possibly write, and
-- b) cannot clash with another NameU
mk_mod :: TH.ModName -> Module
mk_mod mod = mkModule (TH.modString mod)
mk_mod :: TH.ModName -> Module
mk_mod mod = mkModule (TH.modString mod)
+
+mk_uniq :: Int# -> Unique
+mk_uniq u = mkUniqueGrimily (I# u)
reifyName thing
| isExternalName name = mk_varg mod occ_str
| otherwise = TH.mkNameU occ_str (getKey (getUnique name))
reifyName thing
| isExternalName name = mk_varg mod occ_str
| otherwise = TH.mkNameU occ_str (getKey (getUnique name))
+ -- Many of the things we reify have local bindings, and
+ -- NameL's aren't supposed to appear in binding positions, so
+ -- we use NameU. When/if we start to reify nested things, that
+ -- have free variables, we may need to generate NameL's for them.
where
name = getName thing
mod = moduleUserString (nameModule name)
where
name = getName thing
mod = moduleUserString (nameModule name)