From 893d7df5edea93ef247a4fbd57c72db09830ee36 Mon Sep 17 00:00:00 2001
From: simonpj <unknown>
Date: Tue, 21 Dec 2004 17:09:02 +0000
Subject: [PATCH] [project @ 2004-12-21 17:08:59 by simonpj]
 ---------------------------------      Template Haskell:
 dynamically scoped qualified names 
 ---------------------------------

This commit adds a constructor to TH.Name, so that

	nameBase (mkName "Foo.baz")    == "baz"
	nameModule (MkName "Foo.baz") == "Foo"

We always did parse the module name off the front, but it used to
be done in hsSyn/Convert, but now it's done in TH.Syntax, which is
a better place.
---
 ghc/compiler/hsSyn/Convert.lhs      |   22 +++-------------------
 ghc/compiler/typecheck/TcSplice.lhs |   23 +++++++++++++----------
 2 files changed, 16 insertions(+), 29 deletions(-)

diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index 9a7d0b6..08d0cc6 100644
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -403,8 +403,9 @@ tconName = thRdrName OccName.tcName
 thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
 -- This turns a Name into a RdrName
 
-thRdrName ns (TH.Name occ (TH.NameG ns' mod)) = mkOrig (mk_mod mod) (mk_occ ns occ)
-thRdrName ns (TH.Name occ TH.NameS)           = mkDynName 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.NameU uniq))    
   = mkRdrUnqual (OccName.mkOccName ns uniq_str)
   where
@@ -424,22 +425,5 @@ mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
 
 mk_mod :: TH.ModName -> Module
 mk_mod mod = mkModule (TH.modString mod)
-
-mkDynName :: OccName.NameSpace -> TH.OccName -> RdrName
--- Parse the string to see if it has a "." in it
--- so we know whether to generate a qualified or unqualified name
--- It's a bit tricky because we need to parse 
---	Foo.Baz.x as Qual Foo.Baz x
--- So we parse it from back to front
-
-mkDynName ns th_occ
-  = split [] (reverse (TH.occString th_occ))
-  where
-    split occ []        = mkRdrUnqual (mk_occ occ)
-    split occ ('.':rev)	= mkRdrQual (mk_mod (reverse rev)) (mk_occ occ)
-    split occ (c:rev)   = split (c:occ) rev
-
-    mk_occ occ = OccName.mkOccFS ns (mkFastString occ)
-    mk_mod mod = mkModule mod
 \end{code}
 
diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index b5e13f7..dcd4195 100644
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -22,7 +22,7 @@ import HsSyn		( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl,
 import Convert		( convertToHsExpr, convertToHsDecls, convertToHsType )
 import RnExpr		( rnLExpr )
 import RnEnv		( lookupFixityRn, lookupSrcOcc_maybe )
-import RdrName		( RdrName, mkRdrUnqual, lookupLocalRdrEnv )
+import RdrName		( RdrName, mkRdrQual, mkRdrUnqual, lookupLocalRdrEnv )
 import RnTypes		( rnLHsType )
 import TcExpr		( tcCheckRho, tcMonoExpr )
 import TcHsSyn		( mkHsLet, zonkTopLExpr )
@@ -465,8 +465,18 @@ lookupThName (TH.Name occ (TH.NameG th_ns mod))
 		TH.TcClsName -> tcClsName
 		TH.VarName   -> varName
 
-lookupThName th_name@(TH.Name occ TH.NameS) 
-  =  do { let rdr_name = mkRdrUnqual (OccName.mkOccFS ns occ_fs)
+lookupThName (TH.Name occ (TH.NameU uniq)) 
+  = return (mkInternalName (mk_uniq uniq) (OccName.mkOccFS bogus_ns occ_fs) noSrcLoc)
+  where
+    occ_fs = mkFastString (TH.occString occ)
+    bogus_ns = OccName.varName	-- Not yet recorded in the TH name
+				-- but only the unique matters
+
+lookupThName th_name@(TH.Name occ flavour) 	-- NameS or NameQ
+  =  do { let occ = OccName.mkOccFS ns occ_fs
+	      rdr_name = case flavour of
+			    TH.NameS   -> mkRdrUnqual occ
+			    TH.NameQ m -> mkRdrQual (mkModule (TH.modString m)) occ
 	; rdr_env <- getLocalRdrEnv
 	; case lookupLocalRdrEnv rdr_env rdr_name of
 		Just name -> return name
@@ -481,13 +491,6 @@ lookupThName th_name@(TH.Name occ TH.NameS)
        | otherwise	 = OccName.varName
     occ_fs = mkFastString (TH.occString occ)
 
-lookupThName (TH.Name occ (TH.NameU uniq)) 
-  = return (mkInternalName (mk_uniq uniq) (OccName.mkOccFS bogus_ns occ_fs) noSrcLoc)
-  where
-    occ_fs = mkFastString (TH.occString occ)
-    bogus_ns = OccName.varName	-- Not yet recorded in the TH name
-				-- but only the unique matters
-
 tcLookupTh :: Name -> TcM TcTyThing
 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
 -- it gives a reify-related error message on failure, whereas in the normal
-- 
1.7.10.4