[project @ 1996-05-16 09:42:08 by partain]

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

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index dadfc61..6050153 100644 (file)
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -21,14 +21,15 @@ import RnUtils              ( lookupGlobalRnEnv, lubExportFlag )
 
 import Bag             ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
 import Class           ( derivableClassKeys )
-import ErrUtils                ( addErrLoc, addShortErrLocLine )
+import ErrUtils                ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
 import FiniteMap       ( emptyFM, lookupFM, addListToFM_C )
 import ListSetOps      ( unionLists, minusList )
 import Maybes          ( maybeToBool, catMaybes )
 import Name            ( Name, isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), 
                          nameImportFlag, RdrName, pprNonSym )
-import Outputable -- ToDo:rm
-import PprStyle -- ToDo:rm 
+import Outputable      -- ToDo:rm
+import PprStyle        -- ToDo:rm 
+import PrelInfo                ( consDataCon )
 import Pretty
 import SrcLoc          ( SrcLoc )
 import Unique          ( Unique )
@@ -52,7 +53,7 @@ Checks the (..) etc constraints in the export list.
 
 
 \begin{code}
-rnSource :: [Module]
+rnSource :: [Module]                   -- imported modules
         -> Bag (Module,RnName)         -- unqualified imports from module
         -> Bag RenamedFixityDecl       -- fixity info for imported names
         -> RdrNameHsModule
@@ -71,10 +72,10 @@ rnSource imp_mods unqual_imps imp_fixes
     rnExports (mod:imp_mods) unqual_imps exports       `thenRn` \ exported_fn ->
     rnFixes fixes                                      `thenRn` \ src_fixes ->
     let
-       pair_name inf = (nameFixDecl inf, inf)
+       all_fixes     = src_fixes ++ bagToList imp_fixes
+       all_fixes_fm  = listToUFM (map pair_name all_fixes)
 
-       all_fixes    = src_fixes ++ bagToList imp_fixes
-       all_fixes_fm = listToUFM (map pair_name all_fixes)
+       pair_name inf = (fixDeclName inf, inf)
     in
     setExtraRn all_fixes_fm $
 
@@ -192,8 +193,9 @@ rnIE mods (IEThingAll name)
     checkIEAll (RnData n cons fields) = returnRn (exp_all n `consBag` listToBag (map exp_all cons)
                                                          `unionBags` listToBag (map exp_all fields))
     checkIEAll (RnClass n ops)        = returnRn (exp_all n `consBag` listToBag (map exp_all ops))
-    checkIEAll rn@(RnSyn _)           = getSrcLocRn `thenRn` \ src_loc ->
-                                       warnAndContinueRn emptyBag (synAllExportErr rn src_loc)
+    checkIEAll rn@(RnSyn n)           = getSrcLocRn `thenRn` \ src_loc ->
+                                       warnAndContinueRn (unitBag (n, ExportAbs))
+                                           (synAllExportErr False{-warning-} rn src_loc)
     checkIEAll rn                     = returnRn emptyBag
 
     exp_all n = (n, ExportAll)
@@ -217,7 +219,7 @@ rnIE mods (IEThingWith name names)
        = rnWithErr "class ops" rn ops rns
     checkIEWith rn@(RnSyn _) rns
        = getSrcLocRn `thenRn` \ src_loc ->
-         failButContinueRn emptyBag (synAllExportErr rn src_loc)
+         failButContinueRn emptyBag (synAllExportErr True{-error-} rn src_loc)
     checkIEWith rn rns
        = returnRn emptyBag
 
@@ -543,7 +545,7 @@ rnFixes fixities
   = getSrcLocRn        `thenRn` \ src_loc ->
     let
         (_, dup_fixes) = removeDups cmp_fix fixities
-       cmp_fix fix1 fix2 = nameFixDecl fix1 `cmp` nameFixDecl fix2
+       cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2
 
         rn_fixity fix@(InfixL name i)
          = rn_fixity_pieces InfixL name i fix
@@ -562,10 +564,6 @@ rnFixes fixities
     mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
     mapRn rn_fixity fixities                             `thenRn` \ fixes_maybe ->
     returnRn (catMaybes fixes_maybe)
-
-nameFixDecl (InfixL name i) = name
-nameFixDecl (InfixR name i) = name
-nameFixDecl (InfixN name i) = name
 \end{code}
 
 %*********************************************************
@@ -664,7 +662,7 @@ rnContext tv_env ctxt
 
 \begin{code}
 dupNameExportWarn locn names@((n,_):_)
-  = addShortErrLocLine locn (\ sty ->
+  = addShortWarnLocLine locn (\ sty ->
     ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"])
 
 dupLocalsExportErr locn locals@((str,_):_)
@@ -675,13 +673,13 @@ classOpExportErr op locn
   = addShortErrLocLine locn (\ sty ->
     ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"])
 
-synAllExportErr syn locn
-  = addShortErrLocLine locn (\ sty ->
+synAllExportErr is_error syn locn
+  = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn (\ sty ->
     ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"])
 
 withExportErr str rn has rns locn
   = addErrLoc locn "" (\ sty ->
-    ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in export list for `", ppr sty rn, ppStr "'"],
+    ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"],
               ppCat [ppStr "    expected:", ppInterleave ppComma (map (ppr sty) has)],
               ppCat [ppStr "    found:   ", ppInterleave ppComma (map (ppr sty) rns)] ])
 
@@ -691,16 +689,16 @@ importAllErr rn locn
 
 badModExportErr mod locn
   = addShortErrLocLine locn (\ sty ->
-    ppCat [ ppStr "unknown module in export list:", ppPStr mod])
-
-dupModExportWarn locn mods@(mod:_)
-  = addShortErrLocLine locn (\ sty ->
-    ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"])
+    ppCat [ ppStr "unknown module in export list: module", ppPStr mod])
 
 emptyModExportWarn locn mod
-  = addShortErrLocLine locn (\ sty ->
+  = addShortWarnLocLine locn (\ sty ->
     ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"])
 
+dupModExportWarn locn mods@(mod:_)
+  = addShortWarnLocLine locn (\ sty ->
+    ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"])
+
 derivingNonStdClassErr clas locn
   = addShortErrLocLine locn (\ sty ->
     ppCat [ppStr "non-standard class in deriving:", ppr sty clas])