From: simonpj <unknown>
Date: Thu, 23 Dec 2004 09:07:39 +0000 (+0000)
Subject: [project @ 2004-12-23 09:07:30 by simonpj]
X-Git-Tag: Initial_conversion_from_CVS_complete~1316
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e12e0bb72881bd814f449e27b6d870646997864f;p=ghc-hetmet.git

[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'.
---

diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs
index 34eb1ae..150b90e 100644
--- a/ghc/compiler/deSugar/DsMeta.hs
+++ b/ghc/compiler/deSugar/DsMeta.hs
@@ -911,7 +911,7 @@ globalVar 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
@@ -1326,7 +1326,7 @@ templateHaskellNames :: [Name]
 
 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,
@@ -1422,7 +1422,7 @@ mkNameName     = thFun FSLIT("mkName")     mkNameIdKey
 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 -----------------------
@@ -1604,7 +1604,7 @@ mkNameIdKey          = mkPreludeMiscIdUnique 205
 mkNameG_vIdKey       = mkPreludeMiscIdUnique 206
 mkNameG_dIdKey       = mkPreludeMiscIdUnique 207
 mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208
-mkNameUIdKey         = mkPreludeMiscIdUnique 209
+mkNameLIdKey         = mkPreludeMiscIdUnique 209
 
 
 -- data Lit = ...
diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index 08d0cc6..3839c7b 100644
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -15,7 +15,8 @@ import Language.Haskell.TH.Syntax as TH
 
 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
@@ -28,9 +29,10 @@ import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
                      CExportSpec(..)) 
 import Char 	( isAscii, isAlphaNum, isAlpha )
 import List	( partition )
-import Unique	( mkUniqueGrimily )
+import Unique	( Unique, mkUniqueGrimily )
 import ErrUtils (Message)
-import GLAEXTS	( Int(..) )
+import GLAEXTS	( Int(..), Int# )
+import SrcLoc	( noSrcLoc )
 import Bag	( emptyBag, consBag )
 import FastString
 import Outputable
@@ -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.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
-    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
@@ -425,5 +428,8 @@ mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
 
 mk_mod :: TH.ModName -> Module
 mk_mod mod = mkModule (TH.modString mod)
+
+mk_uniq :: Int# -> Unique
+mk_uniq u = mkUniqueGrimily (I# u)
 \end{code}
 
diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index dcd4195..982ac91 100644
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -656,6 +656,10 @@ reifyName :: NamedThing n => n -> TH.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)