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

diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs
index ea58cbc..756d6a9 100644 (file)
--- 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 d8cfe6c..96623bb 100644 (file)
--- 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 500e194..2844ab4 100644 (file)
--- 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