[project @ 2004-11-09 13:27:05 by simonpj]

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

diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs
index e41c775..0547824 100644 (file)
--- a/ghc/compiler/rename/RnTypes.lhs
+++ b/ghc/compiler/rename/RnTypes.lhs
@@ -4,10 +4,10 @@
 \section[RnSource]{Main pass of renamer}
 
 \begin{code}
-module RnTypes ( rnHsType, rnLHsType, rnContext,
+module RnTypes ( rnHsType, rnLHsType, rnLHsTypes, rnContext,
                 rnHsSigType, rnHsTypeFVs,
                 rnLPat, rnPat, rnPatsAndThen,          -- Here because it's not part 
-                rnOverLit, litFVs,             -- of any mutual recursion      
+                rnLit, rnOverLit,                      -- of any mutual recursion      
                 precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize
   ) where
 
@@ -16,7 +16,7 @@ import CmdLineOpts    ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) )
 import HsSyn
 import RdrHsSyn                ( extractHsRhoRdrTyVars )
 import RnHsSyn         ( extractHsTyNames, parrTyCon_name, tupleTyCon_name, 
-                         listTyCon_name, charTyCon_name
+                         listTyCon_name
                        )
 import RnEnv           ( lookupOccRn, lookupBndrRn, lookupSyntaxName,
                          lookupLocatedOccRn, lookupLocatedBndrRn,
@@ -25,15 +25,12 @@ import RnEnv                ( lookupOccRn, lookupBndrRn, lookupSyntaxName,
                          newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV )
 import TcRnMonad
 import RdrName         ( RdrName, elemLocalRdrEnv )
-import PrelNames       ( eqStringName, eqClassName, integralClassName, 
+import PrelNames       ( eqClassName, integralClassName, 
                          negateName, minusName, lengthPName, indexPName,
                          plusIntegerName, fromIntegerName, timesIntegerName,
                          ratioDataConName, fromRationalName )
 import Constants       ( mAX_TUPLE_SIZE )
-import TysWiredIn      ( intTyCon )
-import TysPrim         ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
-                         floatPrimTyCon, doublePrimTyCon )
-import Name            ( Name, NamedThing(..) )
+import Name            ( Name )
 import SrcLoc          ( Located(..), unLoc )
 import NameSet
 
@@ -113,7 +110,7 @@ rnHsType doc (HsTyVar tyvar)
     returnM (HsTyVar tyvar')
 
 rnHsType doc (HsOpTy ty1 (L loc op) ty2)
-  = addSrcSpan loc (
+  = setSrcSpan loc (
       lookupOccRn op                   `thenM` \ op' ->
       lookupTyFixityRn (L loc op')     `thenM` \ fix ->
       rnLHsType doc ty1                        `thenM` \ ty1' ->
@@ -125,6 +122,10 @@ rnHsType doc (HsParTy ty)
   = rnLHsType doc ty           `thenM` \ ty' ->
     returnM (HsParTy ty')
 
+rnHsType doc (HsBangTy b ty)
+  = rnLHsType doc ty           `thenM` \ ty' ->
+    returnM (HsBangTy b ty')
+
 rnHsType doc (HsNumTy i)
   | i == 1    = returnM (HsNumTy i)
   | otherwise = addErr err_msg `thenM_`  returnM (HsNumTy i)
@@ -164,7 +165,7 @@ rnHsType doc (HsAppTy ty1 ty2)
     returnM (HsAppTy ty1' ty2')
 
 rnHsType doc (HsPredTy pred)
-  = rnLPred doc pred   `thenM` \ pred' ->
+  = rnPred doc pred    `thenM` \ pred' ->
     returnM (HsPredTy pred')
 
 rnLHsTypes doc tys = mappM (rnLHsType doc) tys
@@ -172,12 +173,12 @@ rnLHsTypes doc tys = mappM (rnLHsType doc) tys
 
 
 \begin{code}
-rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName] -> LHsContext RdrName
-  -> LHsType RdrName -> RnM (HsType Name)
+rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName]
+        -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
 
 rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty
        -- One reason for this case is that a type like Int#
-       -- starts of as (HsForAllTy Nothing [] Int), in case
+       -- starts off as (HsForAllTy Nothing [] Int), in case
        -- there is some quantification.  Now that we have quantified
        -- and discovered there are no type variables, it's nicer to turn
        -- it into plain Int.  If it were Int# instead of Int, we'd actually
@@ -213,7 +214,7 @@ by the presence of ->
 lookupTyFixityRn (L loc n)
   = doptM Opt_GlasgowExts                      `thenM` \ glaExts ->
     when (not glaExts) 
-       (addSrcSpan loc $ addWarn (infixTyConWarn n))   `thenM_`
+       (setSrcSpan loc $ addWarn (infixTyConWarn n))   `thenM_`
     lookupFixityRn n
 
 -- Building (ty1 `op1` (ty21 `op2` ty22))
@@ -338,12 +339,9 @@ rnPat (SigPatIn pat ty)
   where
     doc = text "In a pattern type-signature"
     
-rnPat (LitPat s@(HsString _)) 
-  = returnM (LitPat s, unitFV eqStringName)
-
 rnPat (LitPat lit) 
-  = litFVs lit         `thenM` \ fvs ->
-    returnM (LitPat lit, fvs) 
+  = rnLit lit  `thenM_` 
+    returnM (LitPat lit, emptyFVs) 
 
 rnPat (NPatIn lit mb_neg) 
   = rnOverLit lit                      `thenM` \ (lit', fvs1) ->
@@ -484,22 +482,9 @@ that the types and classes they involve
 are made available.
 
 \begin{code}
-litFVs (HsChar c)
-   = checkErr (inCharRange c) (bogusCharError c) `thenM_`
-     returnM (unitFV charTyCon_name)
-
-litFVs (HsCharPrim c)         = returnM (unitFV (getName charPrimTyCon))
-litFVs (HsString s)           = returnM (mkFVs [listTyCon_name, charTyCon_name])
-litFVs (HsStringPrim s)       = returnM (unitFV (getName addrPrimTyCon))
-litFVs (HsInt i)             = returnM (unitFV (getName intTyCon))
-litFVs (HsIntPrim i)          = returnM (unitFV (getName intPrimTyCon))
-litFVs (HsFloatPrim f)        = returnM (unitFV (getName floatPrimTyCon))
-litFVs (HsDoublePrim d)       = returnM (unitFV (getName doublePrimTyCon))
-litFVs lit                   = pprPanic "RnExpr.litFVs" (ppr lit)
-                                       -- HsInteger and HsRat only appear 
-                                       -- in post-typechecker translations
-bogusCharError c
-  = ptext SLIT("character literal out of range: '\\") <> char c <> char '\''
+rnLit :: HsLit -> RnM ()
+rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
+rnLit other     = returnM ()
 
 rnOverLit (HsIntegral i _)
   = lookupSyntaxName fromIntegerName   `thenM` \ (from_integer_name, fvs) ->
@@ -550,13 +535,16 @@ checkTupSize tup_size
 
 forAllWarn doc ty (L loc tyvar)
   = ifOptM Opt_WarnUnusedMatches       $
-    addSrcSpan loc $
+    setSrcSpan loc $
     addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
                   nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))]
                   $$
                   doc
                 )
 
+bogusCharError c
+  = ptext SLIT("character literal out of range: '\\") <> char c  <> char '\''
+
 precParseErr op1 op2 
   = hang (ptext SLIT("precedence parsing error"))
       4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), 
@@ -569,7 +557,8 @@ sectionPrecErr op arg_op section
         nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
 
 infixTyConWarn op
-  = ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op)
+  = vcat [ftext FSLIT("Accepting non-standard infix type constructor") <+> quotes (ppr op),
+         ftext FSLIT("Use -fglasgow-exts to avoid this warning"))
 
 patSigErr ty
   =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)