minor cleanup; remove one use of fromJust

[ghc-hetmet.git] / ghc / compiler / rename / RnEnv.lhs

diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index bdaa9f1..2be3bfd 100644 (file)
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -11,7 +11,7 @@ module RnEnv (
        lookupLocatedOccRn, lookupOccRn, 
        lookupLocatedGlobalOccRn, lookupGlobalOccRn,
        lookupLocalDataTcNames, lookupSrcOcc_maybe,
-       lookupFixityRn, lookupLocatedSigOccRn, 
+       lookupFixityRn, lookupTyFixityRn, lookupLocatedSigOccRn, 
        lookupLocatedInstDeclBndr,
        lookupSyntaxName, lookupSyntaxTable, lookupImportedName,
 
@@ -33,8 +33,8 @@ module RnEnv (
 import LoadIface       ( loadHomeInterface, loadSrcInterface )
 import IfaceEnv                ( lookupOrig, newGlobalBinder, newIPName )
 import HsSyn           ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable,
-                         HsType(..), HsExplicitForAll(..), LHsTyVarBndr, LHsType, 
-                         LSig, Sig(..), Fixity, hsLTyVarName, hsLTyVarLocNames, replaceTyVarName )
+                         LHsTyVarBndr, LHsType, 
+                         Fixity, hsLTyVarLocNames, replaceTyVarName )
 import RdrHsSyn                ( extractHsTyRdrTyVars )
 import RdrName         ( RdrName, rdrNameModule, isQual, isUnqual, isOrig,
                          mkRdrUnqual, setRdrNameSpace, rdrNameOcc,
@@ -47,10 +47,11 @@ import RdrName              ( RdrName, rdrNameModule, isQual, isUnqual, isOrig,
                        )
 import HscTypes                ( availNames, ModIface(..), FixItem(..), lookupFixity )
 import TcRnMonad
-import Name            ( Name, nameIsLocalOrFrom, mkInternalName, 
+import Name            ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName,
                          nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName )
 import NameSet
-import OccName         ( tcName, isDataOcc, occNameFlavour, reportIfUnused )
+import OccName         ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace,
+                         reportIfUnused )
 import Module          ( Module )
 import PrelNames       ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey )
 import UniqSupply
@@ -61,6 +62,7 @@ import Outputable
 import Util            ( sortLe )
 import ListSetOps      ( removeDups )
 import List            ( nubBy )
+import Monad           ( when )
 import DynFlags
 \end{code}
 
@@ -439,6 +441,15 @@ lookupFixityRn name
   where
     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
@@ -632,32 +643,15 @@ bindPatSigTyVarsFV tys thing_inside
     thing_inside               `thenM` \ (result,fvs) ->
     returnM (result, fvs `delListFromNameSet` tvs)
 
-bindSigTyVarsFV :: [LSig Name]
+bindSigTyVarsFV :: [Name]
                -> RnM (a, FreeVars)
                -> RnM (a, FreeVars)
--- Bind the top-level forall'd type variables in the sigs.
--- E.g         f :: a -> a
---     f = rhs
---     The 'a' scopes over the rhs
---
--- NB: there'll usually be just one (for a function binding)
---     but if there are many, one may shadow the rest; too bad!
---     e.g  x :: [a] -> [a]
---          y :: [(a,a)] -> a
---          (x,y) = e
---      In e, 'a' will be in scope, and it'll be the one from 'y'!
-bindSigTyVarsFV sigs thing_inside
+bindSigTyVarsFV tvs thing_inside
   = do { scoped_tyvars <- doptM Opt_ScopedTypeVariables
        ; if not scoped_tyvars then 
                thing_inside 
          else
                bindLocalNamesFV tvs thing_inside }
-  where
-    tvs = [ hsLTyVarName ltv 
-         | L _ (Sig _ (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs, ltv <- ltvs ]
-       -- Note the pattern-match on "Explicit"; we only bind
-       -- type variables from signatures with an explicit top-level for-all
-                               
 
 extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
        -- This function is used only in rnSourceDecl on InstDecl
@@ -716,10 +710,13 @@ warnUnusedModules mods
   = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods)
   where
     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",
-                        parens (ptext SLIT("except perhaps instances visible in") <+>
-                                  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") 
+                       <+> 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)
@@ -739,7 +736,11 @@ 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)
 
 -------------------------
 
@@ -747,7 +748,8 @@ warnUnusedName :: (Name, Maybe Provenance) -> RnM ()
 warnUnusedName (name, prov)
   = addWarnAt loc $
     sep [msg <> colon, 
-        nest 2 $ occNameFlavour (nameOccName name) <+> quotes (ppr name)]
+        nest 2 $ pprNonVarNameSpace (occNameSpace (nameOccName name))
+                       <+> quotes (ppr name)]
        -- TODO should be a proper span
   where
     (loc,msg) = case prov of
@@ -778,7 +780,8 @@ shadowedNameWarn doc shadow
 
 unknownNameErr rdr_name
   = sep [ptext SLIT("Not in scope:"), 
-        nest 2 $ occNameFlavour (rdrNameOcc rdr_name) <+> quotes (ppr rdr_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)
@@ -801,4 +804,8 @@ dupNamesErr descriptor located_names
     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}