Commit e12e0bb7 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-12-23 09:07:30 by simonpj]

---------------------------------
          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'.
parent 20e39e0e
...@@ -911,7 +911,7 @@ globalVar name ...@@ -911,7 +911,7 @@ globalVar name
| otherwise | otherwise
= do { MkC occ <- occNameLit name = do { MkC occ <- occNameLit name
; MkC uni <- coreIntLit (getKey (getUnique name)) ; MkC uni <- coreIntLit (getKey (getUnique name))
; rep2 mkNameUName [occ,uni] } ; rep2 mkNameLName [occ,uni] }
where where
name_mod = moduleUserString (nameModule name) name_mod = moduleUserString (nameModule name)
name_occ = nameOccName name name_occ = nameOccName name
...@@ -1326,7 +1326,7 @@ templateHaskellNames :: [Name] ...@@ -1326,7 +1326,7 @@ templateHaskellNames :: [Name]
templateHaskellNames = [ templateHaskellNames = [
returnQName, bindQName, sequenceQName, newNameName, liftName, returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameUName, mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
-- Lit -- Lit
charLName, stringLName, integerLName, intPrimLName, charLName, stringLName, integerLName, intPrimLName,
...@@ -1422,7 +1422,7 @@ mkNameName = thFun FSLIT("mkName") mkNameIdKey ...@@ -1422,7 +1422,7 @@ mkNameName = thFun FSLIT("mkName") mkNameIdKey
mkNameG_vName = thFun FSLIT("mkNameG_v") mkNameG_vIdKey mkNameG_vName = thFun FSLIT("mkNameG_v") mkNameG_vIdKey
mkNameG_dName = thFun FSLIT("mkNameG_d") mkNameG_dIdKey mkNameG_dName = thFun FSLIT("mkNameG_d") mkNameG_dIdKey
mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey mkNameG_tcName = thFun FSLIT("mkNameG_tc") mkNameG_tcIdKey
mkNameUName = thFun FSLIT("mkNameU") mkNameUIdKey mkNameLName = thFun FSLIT("mkNameL") mkNameLIdKey
-------------------- TH.Lib ----------------------- -------------------- TH.Lib -----------------------
...@@ -1604,7 +1604,7 @@ mkNameIdKey = mkPreludeMiscIdUnique 205 ...@@ -1604,7 +1604,7 @@ mkNameIdKey = mkPreludeMiscIdUnique 205
mkNameG_vIdKey = mkPreludeMiscIdUnique 206 mkNameG_vIdKey = mkPreludeMiscIdUnique 206
mkNameG_dIdKey = mkPreludeMiscIdUnique 207 mkNameG_dIdKey = mkPreludeMiscIdUnique 207
mkNameG_tcIdKey = mkPreludeMiscIdUnique 208 mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
mkNameUIdKey = mkPreludeMiscIdUnique 209 mkNameLIdKey = mkPreludeMiscIdUnique 209
-- data Lit = ... -- data Lit = ...
......
...@@ -15,7 +15,8 @@ import Language.Haskell.TH.Syntax as TH ...@@ -15,7 +15,8 @@ import Language.Haskell.TH.Syntax as TH
import HsSyn as Hs import HsSyn as Hs
import qualified Class (FunDep) 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 Module ( Module, mkModule )
import RdrHsSyn ( mkClassDecl, mkTyData ) import RdrHsSyn ( mkClassDecl, mkTyData )
import qualified OccName import qualified OccName
...@@ -28,9 +29,10 @@ import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..), ...@@ -28,9 +29,10 @@ import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
CExportSpec(..)) CExportSpec(..))
import Char ( isAscii, isAlphaNum, isAlpha ) import Char ( isAscii, isAlphaNum, isAlpha )
import List ( partition ) 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 Bag ( emptyBag, consBag )
import FastString import FastString
import Outputable import Outputable
...@@ -406,10 +408,11 @@ thRdrName :: OccName.NameSpace -> TH.Name -> RdrName ...@@ -406,10 +408,11 @@ thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
thRdrName ns (TH.Name occ TH.NameS) = mkRdrUnqual (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.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.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)) thRdrName ns (TH.Name occ (TH.NameU uniq))
= mkRdrUnqual (OccName.mkOccName ns uniq_str) = mkRdrUnqual (OccName.mkOccName ns uniq_str)
where 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 -- The idea here is to make a name that
-- a) the user could not possibly write, and -- a) the user could not possibly write, and
-- b) cannot clash with another NameU -- b) cannot clash with another NameU
...@@ -425,5 +428,8 @@ mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ)) ...@@ -425,5 +428,8 @@ mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
mk_mod :: TH.ModName -> Module mk_mod :: TH.ModName -> Module
mk_mod mod = mkModule (TH.modString mod) mk_mod mod = mkModule (TH.modString mod)
mk_uniq :: Int# -> Unique
mk_uniq u = mkUniqueGrimily (I# u)
\end{code} \end{code}
...@@ -656,6 +656,10 @@ reifyName :: NamedThing n => n -> TH.Name ...@@ -656,6 +656,10 @@ reifyName :: NamedThing n => n -> TH.Name
reifyName thing reifyName thing
| isExternalName name = mk_varg mod occ_str | isExternalName name = mk_varg mod occ_str
| otherwise = TH.mkNameU occ_str (getKey (getUnique name)) | 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 where
name = getName thing name = getName thing
mod = moduleUserString (nameModule name) mod = moduleUserString (nameModule 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