From: simonpj Date: Wed, 30 Nov 2005 14:20:06 +0000 (+0000) Subject: [project @ 2005-11-30 14:20:06 by simonpj] X-Git-Tag: final_switch_to_darcs,_this_repo_is_now_live~109 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=10dd2a6d050e4779782800184014b8738fadc679 [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 --- 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 --- 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 --- 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