From bd0d26527ddd4a3d3c853331f27839ab822c8f80 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 31 Jan 2005 15:48:22 +0000 Subject: [PATCH] [project @ 2005-01-31 15:48:13 by simonpj] --------------------------- Some Template Haskell fixes --------------------------- * Tidy up conversion from TH.Name to RdrName.RdrName. It was partly duplicated between Convert.thRdrName and TcSplice.lookupThName. Now it's all in one place: Convert.thRdrName * Fix a bug in TH.tupleTypeName/TH.tupleDataName (GHC.Tuple -> Data.Tuple) * Export appEs from Language.Haskell.TH --- ghc/compiler/hsSyn/Convert.lhs | 28 ++++++++++------ ghc/compiler/typecheck/TcExpr.lhs | 6 ++-- ghc/compiler/typecheck/TcRnTypes.lhs | 7 ++-- ghc/compiler/typecheck/TcSplice.lhs | 59 +++++++++++++++------------------- 4 files changed, 51 insertions(+), 49 deletions(-) diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 3839c7b..522fe12 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -6,7 +6,7 @@ This module converts Template Haskell syntax into HsSyn \begin{code} -module Convert( convertToHsExpr, convertToHsDecls, convertToHsType ) where +module Convert( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) where #include "HsVersions.h" @@ -404,15 +404,18 @@ tconName = thRdrName OccName.tcName thRdrName :: OccName.NameSpace -> TH.Name -> RdrName -- This turns a Name into a 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 (mk_uniq uniq) "]" +-- 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 +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) + +mk_uniq_occ :: OccName.NameSpace -> TH.OccName -> Int# -> OccName.OccName +mk_uniq_occ ns occ uniq + = OccName.mkOccName ns (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 @@ -422,6 +425,11 @@ thRdrName ns (TH.Name occ (TH.NameU uniq)) -- rapidly baked into data constructors and the like. Baling out -- and generating an unqualified RdrName here is the simple solution +mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace +mk_ghc_ns 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)) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 3d42d8d..e898180 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -25,8 +25,7 @@ import TcRnMonad import TcUnify ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, tcSubExp, tcGen, unifyFunTys, zapToListTy, zapToTyConApp ) import BasicTypes ( isMarkedStrict ) -import Inst ( InstOrigin(..), - newOverloadedLit, newMethodFromName, newIPDict, +import Inst ( newOverloadedLit, newMethodFromName, newIPDict, newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcLookup, tcLookupId, checkProcLevel, @@ -776,7 +775,8 @@ tcId id_name -- Look up the Id and instantiate its type -> do { checkProcLevel id proc_level ; tc_local_id id th_level } - ; other -> pprPanic "tcId" (ppr id_name $$ ppr thing) + -- THis + ; other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected")) } where diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 063017e..2abdfa5 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -409,9 +409,10 @@ data TcTyThing -- tycons and clases in this recursive group instance Outputable TcTyThing where -- Debugging only - ppr (AGlobal g) = text "AGlobal" <+> ppr g - ppr (ATcId g tl pl) = text "ATcId" <+> ppr g <+> ppr tl <+> ppr pl - ppr (ATyVar tv ty) = text "ATyVar" <+> ppr tv <+> pprParendType ty + ppr (AGlobal g) = ppr g + ppr (ATcId g tl pl) = text "Identifier" <> + ifPprDebug (brackets (ppr g <> comma <> ppr tl <> comma <> ppr pl)) + ppr (ATyVar tv ty) = text "Type variable" <+> quotes (ppr tv) <+> pprParendType ty ppr (AThing k) = text "AThing" <+> ppr k \end{code} diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index b51bfdc..67b4e28 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -19,10 +19,10 @@ import qualified Language.Haskell.TH.Syntax as TH import HsSyn ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl, HsType, LHsType ) -import Convert ( convertToHsExpr, convertToHsDecls, convertToHsType ) +import Convert ( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) import RnExpr ( rnLExpr ) -import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe ) -import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, lookupLocalRdrEnv ) +import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe, lookupImportedName ) +import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, lookupLocalRdrEnv, isSrcRdrName ) import RnTypes ( rnLHsType ) import TcExpr ( tcCheckRho, tcMonoExpr ) import TcHsSyn ( mkHsLet, zonkTopLExpr ) @@ -452,44 +452,37 @@ reify th_name ; thing <- tcLookupTh name -- ToDo: this tcLookup could fail, which would give a -- rather unhelpful error message + ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name) ; reifyThing thing } + where + ppr_ns (TH.Name _ (TH.NameG TH.DataName mod)) = text "data" + ppr_ns (TH.Name _ (TH.NameG TH.TcClsName mod)) = text "tc" + ppr_ns (TH.Name _ (TH.NameG TH.VarName mod)) = text "var" lookupThName :: TH.Name -> TcM Name -lookupThName (TH.Name occ (TH.NameG th_ns mod)) - = lookupOrig (mkModule (TH.modString mod)) - (OccName.mkOccName ghc_ns (TH.occString occ)) - where - ghc_ns = case th_ns of - TH.DataName -> dataName - TH.TcClsName -> tcClsName - TH.VarName -> varName +lookupThName th_name + = do { let rdr_name = thRdrName guessed_ns th_name -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 + -- Repeat much of lookupOccRn, becase we want + -- to report errors in a TH-relevant way ; rdr_env <- getLocalRdrEnv ; case lookupLocalRdrEnv rdr_env rdr_name of - Just name -> return name - Nothing -> do - { mb_name <- lookupSrcOcc_maybe rdr_name - ; case mb_name of - Just name -> return name ; - Nothing -> failWithTc (notInScope th_name) - }} + Just name -> return name + Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig + -> lookupImportedName rdr_name + | otherwise -- Unqual, Qual + -> do { + mb_name <- lookupSrcOcc_maybe rdr_name + ; case mb_name of + Just name -> return name ; + Nothing -> failWithTc (notInScope th_name) } + } where - ns | isLexCon occ_fs = OccName.dataName - | otherwise = OccName.varName - occ_fs = mkFastString (TH.occString occ) + -- 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) tcLookupTh :: Name -> TcM TcTyThing -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that -- 1.7.10.4