[project @ 2005-11-30 14:20:06 by simonpj]

-----------------------------------------
	Fix 'mkName' operator in Template Haskell
	so that it handles built-in syntax
	-----------------------------------------

	Merge to stable branch

The 'mkName' function in Template Haskell wasn't dealing correctly with
built-in syntax.  The parser generates Exact RdrNames for built-in syntax
operators, such as ':' and '[]'; and hence so should Convert.

At the same time I'm now generating a better error message in TH when
you use a constructor as a variable or vice versa.

3 files changed, 85 insertions, 31 deletions

diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs
index ea58cbcac5..756d6a955a 100644
--- a/ghc/compiler/basicTypes/OccName.lhs
+++ b/ghc/compiler/basicTypes/OccName.lhs
@@ -35,7 +35,7 @@ module OccName (
 	mkDataConWrapperOcc, mkDataConWorkerOcc,
 	
 	isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
-	parenSymOcc, reportIfUnused,
+	parenSymOcc, reportIfUnused, isTcClsName, isVarName,
 
 	occNameFS, occNameString, occNameUserString, occNameSpace, 
 	occNameFlavour, briefOccNameFlavour,
@@ -52,8 +52,8 @@ module OccName (
 	-- The basic form of names
 	isLexCon, isLexVar, isLexId, isLexSym,
 	isLexConId, isLexConSym, isLexVarId, isLexVarSym,
-	isLowerISO, isUpperISO
-
+	isLowerISO, isUpperISO,
+	startsVarSym, startsVarId, startsConSym, startsConId
     ) where
 
 #include "HsVersions.h"
@@ -146,11 +146,21 @@ srcDataName = DataName	-- Haskell-source data constructors should be
 tvName      = TvName
 varName     = VarName
 
+isTcClsName :: NameSpace -> Bool
+isTcClsName TcClsName = True
+isTcClsName _	      = False
+
+isVarName :: NameSpace -> Bool	-- Variables or type variables, but not constructors
+isVarName TvName  = True
+isVarName VarName = True
+isVarName other   = False
+
+
 nameSpaceString :: NameSpace -> String
-nameSpaceString DataName  = "Data constructor"
-nameSpaceString VarName   = "Variable"
-nameSpaceString TvName    = "Type variable"
-nameSpaceString TcClsName = "Type constructor or class"
+nameSpaceString DataName  = "data constructor"
+nameSpaceString VarName   = "variable"
+nameSpaceString TvName    = "type variable"
+nameSpaceString TcClsName = "type constructor or class"
 \end{code}
 
 
diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs
index d8cfe6c2d4..96623bbd5c 100644
--- a/ghc/compiler/hsSyn/Convert.lhs
+++ b/ghc/compiler/hsSyn/Convert.lhs
@@ -16,13 +16,14 @@ import Language.Haskell.TH.Syntax as TH
 import HsSyn as Hs
 import qualified Class (FunDep)
 import RdrName	( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName, nameRdrName )
-import Name	( mkInternalName )
+import qualified Name	( Name, mkInternalName, getName )
 import Module   ( Module, mkModule )
 import RdrHsSyn	( mkClassDecl, mkTyData )
 import qualified OccName
+import OccName	( startsVarId, startsVarSym, startsConId, startsConSym )
 import SrcLoc	( Located(..), SrcSpan )
 import Type	( Type )
-import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon )
+import TysWiredIn ( unitTyCon, tupleTyCon, tupleCon, trueDataCon, nilDataCon, consDataCon )
 import BasicTypes( Boxity(..) ) 
 import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
                      CExportSpec(..)) 
@@ -521,35 +522,78 @@ vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
 vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 
 vNameL n = wrapL (vName n)
-vName n = force (thRdrName OccName.varName n)
+vName n = cvtName OccName.varName n
 
 -- Constructor function names; this is Haskell source, hence srcDataName
 cNameL n = wrapL (cName n)
-cName n = force (thRdrName OccName.srcDataName n)
+cName n = cvtName OccName.dataName n 
 
 -- Type variable names
-tName n = force (thRdrName OccName.tvName n)
+tName n = cvtName OccName.tvName n
 
 -- Type Constructor names
 tconNameL n = wrapL (tconName n)
-tconName n = force (thRdrName OccName.tcName n)
+tconName n = cvtName OccName.tcClsName n
 
-thRdrName :: OccName.NameSpace -> TH.Name -> RdrName
+cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName
+cvtName ctxt_ns (TH.Name occ flavour)
+  | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)
+  | otherwise 		        = force (thRdrName ctxt_ns occ_str flavour)
+  where
+    occ_str = TH.occString occ
+
+okOcc :: OccName.NameSpace -> String -> Bool
+okOcc _  []      = False
+okOcc ns str@(c:_) 
+  | OccName.isVarName ns = startsVarId c || startsVarSym c
+  | otherwise 	 	 = startsConId c || startsConSym c || str == "[]"
+
+badOcc :: OccName.NameSpace -> String -> SDoc
+badOcc ctxt_ns occ 
+  = ptext SLIT("Illegal") <+> text (OccName.nameSpaceString ctxt_ns) 
+	<+> ptext SLIT("name:") <+> quotes (text occ)
+
+thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 -- This turns a Name into a RdrName
 -- 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
+--
+-- ToDo: we may generate silly RdrNames, by passing a name space
+--       that doesn't match the string, like VarName ":+", 
+-- 	 which will give confusing error messages later
 -- 
 -- The strict applications ensure that any buried exceptions get forced
-thRdrName ctxt_ns (TH.Name occ (TH.NameG th_ns mod)) = (mkOrig      $! (mk_mod mod)) $! (mk_occ (mk_ghc_ns th_ns) occ)
-thRdrName ctxt_ns (TH.Name occ (TH.NameL uniq))      = nameRdrName $! (((mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcLoc)
-thRdrName ctxt_ns (TH.Name occ (TH.NameQ mod))       = (mkRdrQual   $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
-thRdrName ctxt_ns (TH.Name occ TH.NameS)             = mkRdrUnqual $! (mk_occ ctxt_ns occ)
-thRdrName ctxt_ns (TH.Name occ (TH.NameU uniq))      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
+thRdrName ctxt_ns occ (TH.NameG th_ns mod) = (mkOrig     $! (mk_mod mod)) $! (mk_occ (mk_ghc_ns th_ns) occ)
+thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcLoc)
+thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
+thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
+thRdrName ctxt_ns occ TH.NameS
+  | Just name <- isBuiltInOcc ctxt_ns occ  = nameRdrName $! name
+  | otherwise			           = mkRdrUnqual $! (mk_occ ctxt_ns occ)
+
+isBuiltInOcc :: OccName.NameSpace -> String -> Maybe Name.Name
+-- Built in syntax isn't "in scope" so an Unqual RdrName won't do
+-- We must generate an Exact name, just as the parser does
+isBuiltInOcc ctxt_ns occ
+  = case occ of
+	":" 		 -> Just (Name.getName consDataCon)
+	"[]"		 -> Just (Name.getName nilDataCon)
+	"()"		 -> Just (tup_name 0)
+	'(' : ',' : rest -> go_tuple 2 rest
+	other		 -> Nothing
+  where
+    go_tuple n ")" 	    = Just (tup_name n)
+    go_tuple n (',' : rest) = go_tuple (n+1) rest
+    go_tuple n other	    = Nothing
 
-mk_uniq_occ :: OccName.NameSpace -> TH.OccName -> Int# -> OccName.OccName
+    tup_name n 
+	| OccName.isTcClsName ctxt_ns = Name.getName (tupleTyCon Boxed n)
+	| otherwise 		      = Name.getName (tupleCon Boxed n)
+
+mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName
 mk_uniq_occ ns occ uniq 
-  = OccName.mkOccName ns (TH.occString occ ++ '[' : shows (mk_uniq uniq) "]")
+  = OccName.mkOccName ns (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
@@ -559,15 +603,15 @@ mk_uniq_occ ns occ uniq
 	-- rapidly baked into data constructors and the like.  Baling out
 	-- and generating an unqualified RdrName here is the simple solution
 
+-- The packing and unpacking is rather turgid :-(
+mk_occ :: OccName.NameSpace -> String -> OccName.OccName
+mk_occ ns occ = OccName.mkOccFS ns (mkFastString occ)
+
 mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace
-mk_ghc_ns DataName     = OccName.dataName
+mk_ghc_ns TH.DataName  = OccName.dataName
 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 mk_ghc_ns TH.VarName   = OccName.varName
 
--- The packing and unpacking is rather turgid :-(
-mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName
-mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ))
-
 mk_mod :: TH.ModName -> Module
 mk_mod mod = mkModule (TH.modString mod)
 
diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index 500e1941a2..2844ab42a7 100644
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -472,8 +472,8 @@ reify th_name
     ppr_ns (TH.Name _ (TH.NameG TH.VarName mod)) = text "var"
 
 lookupThName :: TH.Name -> TcM Name
-lookupThName th_name
-  =  do { let rdr_name = thRdrName guessed_ns th_name
+lookupThName th_name@(TH.Name occ flavour)
+  =  do { let rdr_name = thRdrName guessed_ns occ_str flavour
 
 	-- Repeat much of lookupOccRn, becase we want
 	-- to report errors in a TH-relevant way
@@ -491,9 +491,9 @@ lookupThName th_name
 	}
   where
 	-- guessed_ns is the name space guessed from looking at the TH name
-    guessed_ns | isLexCon occ_fs = OccName.dataName
-	       | otherwise	 = OccName.varName
-    occ_fs = mkFastString (TH.nameBase th_name)
+    guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName
+	       | otherwise			 = OccName.varName
+    occ_str = TH.occString occ
 
 tcLookupTh :: Name -> TcM TcTyThing
 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that