X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnEnv.lhs;h=c6468b4e304137e44ad68011bae4858c144d8d0d;hb=08a9d7341402232672fcff9062454e6ba1ae8bd1;hp=f6f725ff15c8ab88db3d2e1ecdeed32fb871a83e;hpb=459870b70715b066aadd6a9defc87fb1ffb45bf4;p=ghc-hetmet.git diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index f6f725f..c6468b4 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -4,21 +4,14 @@ \section[RnEnv]{Environment manipulation for the renamer monad} \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module RnEnv ( newTopSrcBinder, lookupFamInstDeclBndr, lookupLocatedBndrRn, lookupBndrRn, lookupBndrRn_maybe, - lookupLocatedTopBndrRn, lookupTopBndrRn, lookupBndrRn_maybe, + lookupLocatedTopBndrRn, lookupTopBndrRn, lookupLocatedOccRn, lookupOccRn, lookupLocatedGlobalOccRn, lookupGlobalOccRn, lookupLocalDataTcNames, lookupSrcOcc_maybe, - lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, + lookupFixityRn, lookupTyFixityRn, lookupInstDeclBndr, lookupRecordBndr, lookupConstructorFields, lookupSyntaxName, lookupSyntaxTable, lookupImportedName, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, @@ -37,20 +30,18 @@ module RnEnv ( mapFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedModules, warnUnusedImports, warnUnusedTopBinds, warnUnusedLocalBinds, - dataTcOccs, unknownNameErr + dataTcOccs, unknownNameErr, perhapsForallMsg ) where #include "HsVersions.h" import LoadIface ( loadInterfaceForName, loadSrcInterface ) import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) -import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable, - LHsTyVarBndr, LHsType, - Fixity, hsLTyVarLocNames, replaceTyVarName ) +import HsSyn import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity) -import TcEnv ( tcLookupDataCon ) +import TcEnv ( tcLookupDataCon, isBrackStage ) import TcRnMonad import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, nameSrcLoc, nameSrcSpan, nameOccName, nameModule, isExternalName ) @@ -64,8 +55,7 @@ import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey, forall_tv_RDR ) import UniqSupply import BasicTypes ( IPName, mapIPName, Fixity ) -import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, - srcLocSpan, getLoc, combineSrcSpans, isOneLineSpan ) +import SrcLoc import Outputable import Util import Maybes @@ -150,7 +140,16 @@ newTopSrcBinder this_mod (L loc rdr_name) (addErrAt loc (badQualBndrErr rdr_name)) -- Binders should not be qualified; if they are, and with a different -- module name, we we get a confusing "M.T is not in scope" error later - ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } + + ; stage <- getStage + ; if isBrackStage stage then + -- We are inside a TH bracket, so make an *Internal* name + -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames + do { uniq <- newUnique + ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) } + else + -- Normal case + newGlobalBinder this_mod (rdrNameOcc rdr_name) loc } \end{code} %********************************************************* @@ -225,35 +224,6 @@ lookupTopBndrRn_maybe rdr_name Nothing -> returnM Nothing Just gre -> returnM (Just $ gre_name gre) } --- lookupLocatedSigOccRn is used for type signatures and pragmas --- Is this valid? --- module A --- import M( f ) --- f :: Int -> Int --- f x = x --- It's clear that the 'f' in the signature must refer to A.f --- The Haskell98 report does not stipulate this, but it will! --- So we must treat the 'f' in the signature in the same way --- as the binding occurrence of 'f', using lookupBndrRn --- --- However, consider this case: --- import M( f ) --- f :: Int -> Int --- g x = x --- We don't want to say 'f' is out of scope; instead, we want to --- return the imported 'f', so that later on the reanamer will --- correctly report "misplaced type sig". -lookupLocatedSigOccRn :: Located RdrName -> RnM (Located Name) -lookupLocatedSigOccRn = wrapLocM $ \ rdr_name -> do - { local_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv local_env rdr_name of { - Just n -> return n ; - Nothing -> do - { mb_gre <- lookupGreLocalRn rdr_name - ; case mb_gre of - Just gre -> return (gre_name gre) - Nothing -> lookupGlobalOccRn rdr_name - }}} ----------------------------------------------- lookupInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) @@ -270,9 +240,9 @@ lookupInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) -- an instance decl lookupInstDeclBndr cls rdr = lookup_located_sub_bndr is_op doc rdr where - doc = ptext SLIT("method of class") <+> quotes (ppr cls) - is_op gre@(GRE {gre_par = ParentIs n}) = n == cls - is_op other = False + doc = ptext (sLit "method of class") <+> quotes (ppr cls) + is_op (GRE {gre_par = ParentIs n}) = n == cls + is_op _ = False ----------------------------------------------- lookupRecordBndr :: Maybe (Located Name) -> Located RdrName -> RnM (Located Name) @@ -292,7 +262,7 @@ lookupRecordBndr (Just (L _ data_con)) rdr_name ; lookup_located_sub_bndr is_field doc rdr_name }} where - doc = ptext SLIT("field of constructor") <+> quotes (ppr data_con) + doc = ptext (sLit "field of constructor") <+> quotes (ppr data_con) lookupConstructorFields :: Name -> RnM [Name] @@ -321,6 +291,7 @@ lookup_located_sub_bndr :: (GlobalRdrElt -> Bool) lookup_located_sub_bndr is_good doc rdr_name = wrapLocM (lookup_sub_bndr is_good doc) rdr_name +lookup_sub_bndr :: (GlobalRdrElt -> Bool) -> SDoc -> RdrName -> RnM Name lookup_sub_bndr is_good doc rdr_name | isUnqual rdr_name -- Find all the things the rdr-name maps to = do { -- and pick the one with the right parent name @@ -360,7 +331,7 @@ lookupFamInstDeclBndr :: Module -> Located RdrName -> RnM Name lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name) = do { mb_gre <- lookupGreRn_maybe rdr_name ; case mb_gre of - Just gre -> returnM (gre_name gre) ; + Just gre -> returnM (gre_name gre) Nothing -> newTopSrcBinder mod lrdr_name } -------------------------------------------------- @@ -397,23 +368,27 @@ lookupGlobalOccRn rdr_name = lookupImportedName rdr_name | otherwise - = -- First look up the name in the normal environment. - lookupGreRn_maybe rdr_name `thenM` \ mb_gre -> + = do + -- First look up the name in the normal environment. + mb_gre <- lookupGreRn_maybe rdr_name case mb_gre of { Just gre -> returnM (gre_name gre) ; - Nothing -> + Nothing -> do -- We allow qualified names on the command line to refer to -- *any* name exported by any module in scope, just as if -- there was an "import qualified M" declaration for every -- module. - getModule `thenM` \ mod -> - if isQual rdr_name && mod == iNTERACTIVE then - -- This test is not expensive, - lookupQualifiedName rdr_name -- and only happens for failed lookups - else do + allow_qual <- doptM Opt_ImplicitImportQualified + mod <- getModule + -- This test is not expensive, + -- and only happens for failed lookups + if isQual rdr_name && allow_qual && mod == iNTERACTIVE + then lookupQualifiedName rdr_name + else do traceRn $ text "lookupGlobalOccRn" - unboundName rdr_name } + unboundName rdr_name + } lookupImportedName :: RdrName -> TcRnIf m n Name -- Lookup the occurrence of an imported name @@ -439,7 +414,7 @@ unboundName rdr_name = do { addErr (unknownNameErr rdr_name) ; env <- getGlobalRdrEnv; ; traceRn (vcat [unknownNameErr rdr_name, - ptext SLIT("Global envt is:"), + ptext (sLit "Global envt is:"), nest 3 (pprGlobalRdrEnv env)]) ; returnM (mkUnboundName rdr_name) } @@ -504,7 +479,7 @@ lookupQualifiedName rdr_name | Just (mod,occ) <- isQual_maybe rdr_name -- Note: we want to behave as we would for a source file import here, -- and respect hiddenness of modules/packages, hence loadSrcInterface. - = loadSrcInterface doc mod False `thenM` \ iface -> + = loadSrcInterface doc mod False Nothing `thenM` \ iface -> case [ (mod,occ) | (mod,avails) <- mi_exports iface, @@ -518,7 +493,7 @@ lookupQualifiedName rdr_name | otherwise = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name) where - doc = ptext SLIT("Need to find") <+> ppr rdr_name + doc = ptext (sLit "Need to find") <+> ppr rdr_name \end{code} %********************************************************* @@ -621,11 +596,11 @@ lookupFixityRn name returnM (mi_fix_fn iface (nameOccName name)) } where - doc = ptext SLIT("Checking fixity for") <+> ppr name + doc = ptext (sLit "Checking fixity for") <+> ppr name --------------- lookupTyFixityRn :: Located Name -> RnM Fixity -lookupTyFixityRn (L loc n) = lookupFixityRn n +lookupTyFixityRn (L _ n) = lookupFixityRn n --------------- lookupLocalDataTcNames :: RdrName -> RnM [Name] @@ -881,7 +856,7 @@ checkShadowedNames doc_str (global_env,local_env) loc_rdr_names ; mappM_ check_shadow loc_rdr_names } where check_shadow (loc, occ) - | Just n <- mb_local = complain [ptext SLIT("bound at") <+> ppr (nameSrcLoc n)] + | Just n <- mb_local = complain [ptext (sLit "bound at") <+> ppr (nameSrcLoc n)] | not (null gres) = complain (map pprNameProvenance gres) | otherwise = return () where @@ -901,11 +876,10 @@ checkShadowedNames doc_str (global_env,local_env) loc_rdr_names \begin{code} -- A useful utility -mapFvRn f xs = mappM f xs `thenM` \ stuff -> - let - (ys, fvs_s) = unzip stuff - in - returnM (ys, plusFVs fvs_s) +mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars) +mapFvRn f xs = do stuff <- mappM f xs + case unzip stuff of + (ys, fvs_s) -> returnM (ys, plusFVs fvs_s) -- because some of the rename functions are CPSed: -- maps the function across the list from left to right; @@ -932,12 +906,12 @@ warnUnusedModules mods = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) where bleat (mod,loc) = addWarnAt loc (mk_warn mod) - mk_warn m = vcat [ptext SLIT("Module") <+> quotes (ppr m) + mk_warn m = vcat [ptext (sLit "Module") <+> quotes (ppr m) <+> text "is imported, but nothing from it is used,", - nest 2 (ptext SLIT("except perhaps instances visible in") + nest 2 (ptext (sLit "except perhaps instances visible in") <+> quotes (ppr m)), - ptext SLIT("To suppress this warning, use:") - <+> ptext SLIT("import") <+> ppr m <> parens empty ] + ptext (sLit "To suppress this warning, use:") + <+> ptext (sLit "import") <+> ppr m <> parens empty ] warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () @@ -954,9 +928,11 @@ check_unused flag bound_names used_names ------------------------- -- Helpers +warnUnusedGREs :: [GlobalRdrElt] -> RnM () warnUnusedGREs gres = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres] +warnUnusedLocals :: [Name] -> RnM () warnUnusedLocals names = warnUnusedBinds [(n,LocalDef) | n<-names] @@ -973,7 +949,7 @@ warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) warnUnusedName :: (Name, Provenance) -> RnM () warnUnusedName (name, LocalDef) = addUnusedWarning name (srcLocSpan (nameSrcLoc name)) - (ptext SLIT("Defined but not used")) + (ptext (sLit "Defined but not used")) warnUnusedName (name, Imported is) = mapM_ warn is @@ -982,8 +958,9 @@ warnUnusedName (name, Imported is) where span = importSpecLoc spec pp_mod = quotes (ppr (importSpecModule spec)) - msg = ptext SLIT("Imported from") <+> pp_mod <+> ptext SLIT("but not used") + msg = ptext (sLit "Imported from") <+> pp_mod <+> ptext (sLit "but not used") +addUnusedWarning :: Name -> SrcSpan -> SDoc -> RnM () addUnusedWarning name span msg = addWarnAt span $ sep [msg <> colon, @@ -992,52 +969,62 @@ addUnusedWarning name span msg \end{code} \begin{code} +addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () addNameClashErrRn rdr_name names - = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), - ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) + = addErr (vcat [ptext (sLit "Ambiguous occurrence") <+> quotes (ppr rdr_name), + ptext (sLit "It could refer to") <+> vcat (msg1 : msgs)]) where (np1:nps) = names - msg1 = ptext SLIT("either") <+> mk_ref np1 - msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] + msg1 = ptext (sLit "either") <+> mk_ref np1 + msgs = [ptext (sLit " or") <+> mk_ref np | np <- nps] mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre +shadowedNameWarn :: SDoc -> OccName -> [SDoc] -> SDoc shadowedNameWarn doc occ shadowed_locs - = sep [ptext SLIT("This binding for") <+> quotes (ppr occ) - <+> ptext SLIT("shadows the existing binding") <> plural shadowed_locs, + = sep [ptext (sLit "This binding for") <+> quotes (ppr occ) + <+> ptext (sLit "shadows the existing binding") <> plural shadowed_locs, nest 2 (vcat shadowed_locs)] $$ doc +unknownNameErr :: RdrName -> SDoc unknownNameErr rdr_name - = vcat [ hang (ptext SLIT("Not in scope:")) + = vcat [ hang (ptext (sLit "Not in scope:")) 2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) <+> quotes (ppr rdr_name)) , extra ] where - extra | rdr_name == forall_tv_RDR - = ptext SLIT("Perhaps you intended to use -XRankNTypes or similar flag") - | otherwise = empty + extra | rdr_name == forall_tv_RDR = perhapsForallMsg + | otherwise = empty + +perhapsForallMsg :: SDoc +perhapsForallMsg + = vcat [ ptext (sLit "Perhaps you intended to use -XRankNTypes or similar flag") + , ptext (sLit "to enable explicit-forall syntax: forall . ")] +unknownSubordinateErr :: SDoc -> RdrName -> SDoc unknownSubordinateErr doc op -- Doc is "method of class" or -- "field of constructor" - = quotes (ppr op) <+> ptext SLIT("is not a (visible)") <+> doc + = quotes (ppr op) <+> ptext (sLit "is not a (visible)") <+> doc +badOrigBinding :: RdrName -> SDoc badOrigBinding name - = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) + = ptext (sLit "Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) -- The rdrNameOcc is because we don't want to print Prelude.(,) dupNamesErr :: Outputable n => (n -> SrcSpan) -> SDoc -> [n] -> RnM () dupNamesErr get_loc descriptor names = addErrAt big_loc $ - vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr (head names)), + vcat [ptext (sLit "Conflicting definitions for") <+> quotes (ppr (head names)), locations, descriptor] where locs = map get_loc names big_loc = foldr1 combineSrcSpans locs one_line = isOneLineSpan big_loc locations | one_line = empty - | otherwise = ptext SLIT("Bound at:") <+> + | otherwise = ptext (sLit "Bound at:") <+> vcat (map ppr (sortLe (<=) locs)) +badQualBndrErr :: RdrName -> SDoc badQualBndrErr rdr_name - = ptext SLIT("Qualified name in binding position:") <+> ppr rdr_name + = ptext (sLit "Qualified name in binding position:") <+> ppr rdr_name \end{code}