X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnEnv.lhs;h=2be3bfd5c0b464e30c0a1ca339365b931f612b09;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=417d873092dc73bfcd1418c4e02d8a01ba71cb2a;hpb=568d3f41cb2da3fe4887e13d69f152d66cbcb755;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 417d873..2be3bfd 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -10,15 +10,15 @@ module RnEnv ( lookupLocatedTopBndrRn, lookupTopBndrRn, lookupLocatedOccRn, lookupOccRn, lookupLocatedGlobalOccRn, lookupGlobalOccRn, - lookupTopFixSigNames, lookupSrcOcc_maybe, - lookupFixityRn, lookupLocatedSigOccRn, + lookupLocalDataTcNames, lookupSrcOcc_maybe, + lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, lookupLocatedInstDeclBndr, - lookupSyntaxName, lookupSyntaxNames, lookupImportedName, + lookupSyntaxName, lookupSyntaxTable, lookupImportedName, newLocalsRn, newIPNameRn, bindLocalNames, bindLocalNamesFV, bindLocatedLocalsFV, bindLocatedLocalsRn, - bindPatSigTyVars, bindPatSigTyVarsFV, + bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalFixities, @@ -30,37 +30,40 @@ module RnEnv ( #include "HsVersions.h" -import LoadIface ( loadSrcInterface ) +import LoadIface ( loadHomeInterface, loadSrcInterface ) import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) -import HsSyn +import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable, + LHsTyVarBndr, LHsType, + Fixity, hsLTyVarLocNames, replaceTyVarName ) import RdrHsSyn ( extractHsTyRdrTyVars ) -import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, +import RdrName ( RdrName, rdrNameModule, isQual, isUnqual, isOrig, mkRdrUnqual, setRdrNameSpace, rdrNameOcc, pprGlobalRdrEnv, lookupGRE_RdrName, isExact_maybe, isSrcRdrName, GlobalRdrElt(..), GlobalRdrEnv, lookupGlobalRdrEnv, isLocalGRE, extendLocalRdrEnv, elemLocalRdrEnv, lookupLocalRdrEnv, - Provenance(..), pprNameProvenance, ImportSpec(..) + Provenance(..), pprNameProvenance, + importSpecLoc, importSpecModule ) -import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) import TcRnMonad -import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName, - nameSrcLoc, nameOccName, nameModuleName, nameParent ) +import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, + nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName ) import NameSet -import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused, - isVarOcc ) -import Module ( Module, ModuleName, moduleName, mkHomeModule ) -import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE ) +import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, + reportIfUnused ) +import Module ( Module ) +import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) import UniqSupply import BasicTypes ( IPName, mapIPName ) -import SrcLoc ( srcSpanStart, Located(..), eqLocated, unLoc, - srcLocSpan ) +import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, + srcLocSpan, getLoc, combineSrcSpans, srcSpanStartLine, srcSpanEndLine ) import Outputable +import Util ( sortLe ) import ListSetOps ( removeDups ) import List ( nubBy ) -import CmdLineOpts -import FastString ( FastString ) +import Monad ( when ) +import DynFlags \end{code} %********************************************************* @@ -71,29 +74,50 @@ import FastString ( FastString ) \begin{code} newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name -newTopSrcBinder mod mb_parent (L loc rdr_name) +newTopSrcBinder this_mod mb_parent (L loc rdr_name) | Just name <- isExact_maybe rdr_name - = returnM name + = -- This is here to catch + -- (a) Exact-name binders created by Template Haskell + -- (b) The PrelBase defn of (say) [] and similar, for which + -- the parser reads the special syntax and returns an Exact RdrName + -- We are at a binding site for the name, so check first that it + -- the current module is the correct one; otherwise GHC can get + -- very confused indeed. This test rejects code like + -- data T = (,) Int Int + -- unless we are in GHC.Tup + ASSERT2( isExternalName name, ppr name ) + do checkErr (this_mod == nameModule name) + (badOrigBinding rdr_name) + returnM name + | isOrig rdr_name - = ASSERT( rdr_mod == moduleName mod || rdr_mod == rOOT_MAIN_Name ) + = do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) + (badOrigBinding rdr_name) -- When reading External Core we get Orig names as binders, -- but they should agree with the module gotten from the monad -- - -- Except for the ":Main.main = ..." definition inserted into - -- the Main module + -- We can get built-in syntax showing up here too, sadly. If you type + -- data T = (,,,) + -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon + -- uses setRdrNameSpace to make it into a data constructors. At that point + -- the nice Exact name for the TyCon gets swizzled to an Orig name. + -- Hence the badOrigBinding error message. -- - -- Because of this latter case, we take the module from the RdrName, - -- not from the environment. In principle, it'd be fine to have an - -- arbitrary mixture of external core definitions in a single module, + -- Except for the ":Main.main = ..." definition inserted into + -- the Main module; ugh! + + -- Because of this latter case, we call newGlobalBinder with a module from + -- the RdrName, not from the environment. In principle, it'd be fine to + -- have an arbitrary mixture of external core definitions in a single module, -- (apart from module-initialisation issues, perhaps). - newGlobalBinder (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) mb_parent - (srcSpanStart loc) --TODO, should pass the whole span + newGlobalBinder rdr_mod (rdrNameOcc rdr_name) mb_parent + (srcSpanStart loc) --TODO, should pass the whole span | otherwise - = newGlobalBinder mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) + = newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) where - rdr_mod = rdrNameModule rdr_name + rdr_mod = rdrNameModule rdr_name \end{code} %********************************************************* @@ -109,7 +133,7 @@ lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedBndrRn = wrapLocM lookupBndrRn lookupBndrRn :: RdrName -> RnM Name --- NOTE: assumes that the SrcSpan of the binder has already been addSrcSpan'd +-- NOTE: assumes that the SrcSpan of the binder has already been setSrcSpan'd lookupBndrRn rdr_name = getLocalRdrEnv `thenM` \ local_env -> case lookupLocalRdrEnv local_env rdr_name of @@ -138,29 +162,15 @@ lookupTopBndrRn :: RdrName -> RnM Name lookupTopBndrRn rdr_name | Just name <- isExact_maybe rdr_name - -- This is here to catch - -- (a) Exact-name binders created by Template Haskell - -- (b) The PrelBase defn of (say) [] and similar, for which - -- the parser reads the special syntax and returns an Exact RdrName - -- - -- We are at a binding site for the name, so check first that it - -- the current module is the correct one; otherwise GHC can get - -- very confused indeed. This test rejects code like - -- data T = (,) Int Int - -- unless we are in GHC.Tup - = getModule `thenM` \ mod -> - checkErr (isInternalName name || moduleName mod == nameModuleName name) - (badOrigBinding rdr_name) `thenM_` - returnM name + = returnM name | isOrig rdr_name -- This deals with the case of derived bindings, where -- we don't bother to call newTopSrcBinder first -- We assume there is no "parent" name - = do - loc <- getSrcSpanM - newGlobalBinder (mkHomeModule (rdrNameModule rdr_name)) - (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) + = do { loc <- getSrcSpanM + ; newGlobalBinder (rdrNameModule rdr_name) + (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) } | otherwise = do { mb_gre <- lookupGreLocalRn rdr_name @@ -246,7 +256,7 @@ lookupGlobalOccRn rdr_name Nothing -> -- We allow qualified names on the command line to refer to - -- *any* name exported by any module in scope, just as if + -- *any* name exported by any module in scope, just as if -- there was an "import qualified M" declaration for every -- module. getModule `thenM` \ mod -> @@ -331,6 +341,8 @@ lookupQualifiedName rdr_name mod = rdrNameModule rdr_name occ = rdrNameOcc rdr_name in + -- 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 -> case [ (mod,occ) | @@ -352,16 +364,21 @@ lookupQualifiedName rdr_name %********************************************************* \begin{code} -lookupTopFixSigNames :: RdrName -> RnM [Name] +lookupLocalDataTcNames :: RdrName -> RnM [Name] -- GHC extension: look up both the tycon and data con -- for con-like things -lookupTopFixSigNames rdr_name +-- Complain if neither is in scope +lookupLocalDataTcNames rdr_name | Just n <- isExact_maybe rdr_name -- Special case for (:), which doesn't get into the GlobalRdrEnv = return [n] -- For this we don't need to try the tycon too | otherwise = do { mb_gres <- mapM lookupGreLocalRn (dataTcOccs rdr_name) - ; return [gre_name gre | Just gre <- mb_gres] } + ; case [gre_name gre | Just gre <- mb_gres] of + [] -> do { addErr (unknownNameErr rdr_name) + ; return [] } + names -> return names + } -------------------------------- bindLocalFixities :: [FixitySig RdrName] -> RnM a -> RnM a @@ -416,26 +433,43 @@ lookupFixityRn name -- nothing from B will be used). When we come across a use of -- 'f', we need to know its fixity, and it's then, and only -- then, that we load B.hi. That is what's happening here. - loadSrcInterface doc name_mod False `thenM` \ iface -> + -- + -- loadHomeInterface will find B.hi even if B is a hidden module, + -- and that's what we want. + loadHomeInterface doc name `thenM` \ iface -> returnM (mi_fix_fn iface (nameOccName name)) where - doc = ptext SLIT("Checking fixity for") <+> ppr name - name_mod = nameModuleName name + doc = ptext SLIT("Checking fixity for") <+> ppr name + +--------------- +lookupTyFixityRn :: Located Name -> RnM Fixity +lookupTyFixityRn (L loc n) + = doptM Opt_GlasgowExts `thenM` \ glaExts -> + when (not glaExts) + (setSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_` + lookupFixityRn n +--------------- dataTcOccs :: RdrName -> [RdrName] -- If the input is a data constructor, return both it and a type -- constructor. This is useful when we aren't sure which we are -- looking at. --- --- ToDo: If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, --- and we don't have a systematic way to find the TyCon's Name from --- the DataCon's name. Sigh dataTcOccs rdr_name - | isDataOcc occ = [rdr_name_tc, rdr_name] - | otherwise = [rdr_name] + | Just n <- isExact_maybe rdr_name -- Ghastly special case + , n `hasKey` consDataConKey = [rdr_name] -- see note below + | isDataOcc occ = [rdr_name_tc, rdr_name] + | otherwise = [rdr_name] where occ = rdrNameOcc rdr_name rdr_name_tc = setRdrNameSpace rdr_name tcName + +-- If the user typed "[]" or "(,,)", we'll generate an Exact RdrName, +-- and setRdrNameSpace generates an Orig, which is fine +-- But it's not fine for (:), because there *is* no corresponding type +-- constructor. If we generate an Orig tycon for GHC.Base.(:), it'll +-- appear to be in scope (because Orig's simply allocate a new name-cache +-- entry) and then we get an error when we use dataTcOccs in +-- TcRnDriver.tcRnGetInfo. Large sigh. \end{code} %************************************************************************ @@ -468,7 +502,7 @@ At the moment this just happens for We store the relevant Name in the HsSyn tree, in * HsIntegral/HsFractional * NegApp - * NPlusKPatIn + * NPlusKPat * HsDo respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName, fromRationalName etc), but the renamer changes this to the appropriate user @@ -478,30 +512,30 @@ We treat the orignal (standard) names as free-vars too, because the type checker checks the type of the user thing against the type of the standard thing. \begin{code} -lookupSyntaxName :: Name -- The standard name - -> RnM (Name, FreeVars) -- Possibly a non-standard name +lookupSyntaxName :: Name -- The standard name + -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name - = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> - if not no_prelude then normal_case + = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude -> + if implicit_prelude then normal_case else -- Get the similarly named thing from the local environment lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> - returnM (usr_name, unitFV usr_name) + returnM (HsVar usr_name, unitFV usr_name) where - normal_case = returnM (std_name, emptyFVs) + normal_case = returnM (HsVar std_name, emptyFVs) -lookupSyntaxNames :: [Name] -- Standard names - -> RnM (ReboundNames Name, FreeVars) -- See comments with HsExpr.ReboundNames -lookupSyntaxNames std_names - = doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> - if not no_prelude then normal_case +lookupSyntaxTable :: [Name] -- Standard names + -> RnM (SyntaxTable Name, FreeVars) -- See comments with HsExpr.ReboundNames +lookupSyntaxTable std_names + = doptM Opt_ImplicitPrelude `thenM` \ implicit_prelude -> + if implicit_prelude then normal_case else -- Get the similarly named thing from the local environment mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> - returnM (std_names `zip` map nlHsVar usr_names, mkFVs usr_names) + returnM (std_names `zip` map HsVar usr_names, mkFVs usr_names) where - normal_case = returnM (std_names `zip` map nlHsVar std_names, emptyFVs) + normal_case = returnM (std_names `zip` map HsVar std_names, emptyFVs) \end{code} @@ -544,15 +578,16 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope (enclosed_scope names) +bindLocalNames :: [Name] -> RnM a -> RnM a bindLocalNames names enclosed_scope = getLocalRdrEnv `thenM` \ name_env -> setLocalRdrEnv (extendLocalRdrEnv name_env names) enclosed_scope +bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) bindLocalNamesFV names enclosed_scope - = bindLocalNames names $ - enclosed_scope `thenM` \ (thing, fvs) -> - returnM (thing, delListFromNameSet fvs names) + = do { (result, fvs) <- bindLocalNames names enclosed_scope + ; returnM (result, delListFromNameSet fvs names) } ------------------------------------- @@ -566,18 +601,13 @@ bindLocatedLocalsFV doc rdr_names enclosed_scope returnM (thing, delListFromNameSet fvs names) ------------------------------------- -extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) - -- This tiresome function is used only in rnSourceDecl on InstDecl -extendTyVarEnvFVRn tyvars enclosed_scope - = bindLocalNames tyvars enclosed_scope `thenM` \ (thing, fvs) -> - returnM (thing, delListFromNameSet fvs tyvars) - bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName] -> ([LHsTyVarBndr Name] -> RnM a) -> RnM a +-- Haskell-98 binding of type variables; e.g. within a data type decl bindTyVarsRn doc_str tyvar_names enclosed_scope = let - located_tyvars = [L loc (hsTyVarName tv) | L loc tv <- tyvar_names] + located_tyvars = hsLTyVarLocNames tyvar_names in bindLocatedLocalsRn doc_str located_tyvars $ \ names -> enclosed_scope (zipWith replace tyvar_names names) @@ -588,19 +618,22 @@ bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a -- Find the type variables in the pattern type -- signatures that must be brought into scope bindPatSigTyVars tys thing_inside - = getLocalRdrEnv `thenM` \ name_env -> - let - located_tyvars = nubBy eqLocated [ tv | ty <- tys, - tv <- extractHsTyRdrTyVars ty, - not (unLoc tv `elemLocalRdrEnv` name_env) - ] + = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside [] + else + do { name_env <- getLocalRdrEnv + ; let locd_tvs = [ tv | ty <- tys + , tv <- extractHsTyRdrTyVars ty + , not (unLoc tv `elemLocalRdrEnv` name_env) ] + nubbed_tvs = nubBy eqLocated locd_tvs -- The 'nub' is important. For example: -- f (x :: t) (y :: t) = .... -- We don't want to complain about binding t twice! - doc_sig = text "In a pattern type-signature" - in - bindLocatedLocalsRn doc_sig located_tyvars thing_inside + ; bindLocatedLocalsRn doc_sig nubbed_tvs thing_inside }} + where + doc_sig = text "In a pattern type-signature" bindPatSigTyVarsFV :: [LHsType RdrName] -> RnM (a, FreeVars) @@ -610,6 +643,20 @@ bindPatSigTyVarsFV tys thing_inside thing_inside `thenM` \ (result,fvs) -> returnM (result, fvs `delListFromNameSet` tvs) +bindSigTyVarsFV :: [Name] + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) +bindSigTyVarsFV tvs thing_inside + = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } + +extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) + -- This function is used only in rnSourceDecl on InstDecl +extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside + ------------------------------------- checkDupNames :: SDoc -> [Located RdrName] @@ -628,7 +675,7 @@ checkShadowing doc_str loc_rdr_names check_shadow (L loc rdr_name) | rdr_name `elemLocalRdrEnv` local_env || not (null (lookupGRE_RdrName rdr_name global_env )) - = addSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) + = setSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) | otherwise = returnM () in mappM_ check_shadow loc_rdr_names @@ -658,14 +705,18 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [ModuleName] -> RnM () +warnUnusedModules :: [(Module,SrcSpan)] -> RnM () warnUnusedModules mods - = ifOptM Opt_WarnUnusedImports (mappM_ (addWarn . unused_mod) mods) + = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) where - unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> - text "is imported, but nothing from it is used", - parens (ptext SLIT("except perhaps instances visible in") <+> - quotes (ppr m))] + bleat (mod,loc) = setSrcSpan loc $ addWarn (mk_warn mod) + 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") + <+> quotes (ppr m)), + ptext SLIT("To suppress this warning, use:") + <+> ptext SLIT("import") <+> ppr m <> parens empty ] + warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) @@ -685,22 +736,28 @@ warnUnusedLocals names warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) - where reportable (name,_) = reportIfUnused (nameOccName name) + where reportable (name,_) + | isWiredInName name = False -- Don't report unused wired-in names + -- Otherwise we get a zillion warnings + -- from Data.Tuple + | otherwise = reportIfUnused (nameOccName name) ------------------------- warnUnusedName :: (Name, Maybe Provenance) -> RnM () warnUnusedName (name, prov) - = addWarnAt loc (sep [msg <> colon, nest 4 (ppr name)]) + = addWarnAt loc $ + sep [msg <> colon, + nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name)) + <+> quotes (ppr name)] -- TODO should be a proper span where (loc,msg) = case prov of - Just (Imported is _) -> - ( is_loc (head is), imp_from (is_mod imp_spec) ) - where - imp_spec = head is - other -> - ( srcLocSpan (nameSrcLoc name), unused_msg ) + Just (Imported is) + -> (importSpecLoc imp_spec, imp_from (importSpecModule imp_spec)) + where + imp_spec = head is + other -> (srcLocSpan (nameSrcLoc name), unused_msg) unused_msg = text "Defined but not used" imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used" @@ -721,13 +778,10 @@ shadowedNameWarn doc shadow ptext SLIT("shadows an existing binding")] $$ doc -unknownNameErr name +unknownNameErr rdr_name = sep [ptext SLIT("Not in scope:"), - if isVarOcc occ_name then quotes (ppr name) - else text (occNameFlavour occ_name) - <+> quotes (ppr name)] - where - occ_name = rdrNameOcc name + nest 2 $ pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + <+> quotes (ppr rdr_name)] unknownInstBndrErr cls op = quotes (ppr op) <+> ptext SLIT("is not a (visible) method of class") <+> quotes (ppr cls) @@ -736,9 +790,22 @@ badOrigBinding name = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) -- The rdrNameOcc is because we don't want to print Prelude.(,) -dupNamesErr descriptor (L loc name : dup_things) - = addSrcSpan loc $ - addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) - $$ - descriptor) +dupNamesErr :: SDoc -> [Located RdrName] -> RnM () +dupNamesErr descriptor located_names + = setSrcSpan big_loc $ + addErr (vcat [ptext SLIT("Conflicting definitions for") <+> quotes (ppr name1), + locations, + descriptor]) + where + L _ name1 = head located_names + locs = map getLoc located_names + big_loc = foldr1 combineSrcSpans locs + one_line = srcSpanStartLine big_loc == srcSpanEndLine big_loc + locations | one_line = empty + | otherwise = ptext SLIT("Bound at:") <+> + vcat (map ppr (sortLe (<=) locs)) + +infixTyConWarn op + = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op), + ftext FSLIT("Use -fglasgow-exts to avoid this warning")] \end{code}