X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnTypes.lhs;h=82bf50a9fd6518802587ac1441ec003e4c210221;hb=3c4a732b0b011cf356eed1ecd4fdc4d5f1aab193;hp=0aa0b4e1c568ec0ed9ee1c1377ea940c340e7307;hpb=9da4639011348fb6c318e3cba4b08622f811d9c4;p=ghc-hetmet.git

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 0aa0b4e..82bf50a 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -21,13 +21,14 @@ module RnTypes (
 	dupFieldErr, patSigErr, checkTupSize
   ) where
 
-import DynFlags		( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts, Opt_ScopedTypeVariables ) )
+import DynFlags		( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts, Opt_ScopedTypeVariables, Opt_OverloadedStrings ) )
 
 import HsSyn
 import RdrHsSyn		( extractHsRhoRdrTyVars )
 import RnHsSyn		( extractHsTyNames, parrTyCon_name, tupleTyCon_name, 
 			  listTyCon_name
 			)
+import RnHsDoc          ( rnLHsDoc )
 import RnEnv		( lookupOccRn, lookupBndrRn, lookupSyntaxName,
 			  lookupLocatedOccRn, lookupLocatedBndrRn,
 			  lookupLocatedGlobalOccRn, bindTyVarsRn, 
@@ -39,7 +40,7 @@ import RdrName		( RdrName, elemLocalRdrEnv )
 import PrelNames	( eqClassName, integralClassName, geName, eqName,
 		  	  negateName, minusName, lengthPName, indexPName,
 			  plusIntegerName, fromIntegerName, timesIntegerName,
-			  ratioDataConName, fromRationalName )
+			  ratioDataConName, fromRationalName, fromStringName )
 import TypeRep		( funTyCon )
 import Constants	( mAX_TUPLE_SIZE )
 import Name		( Name )
@@ -188,6 +189,11 @@ rnHsType doc (HsSpliceTy _)
   = do	{ addErr (ptext SLIT("Type splices are not yet implemented"))
  	; failM }
 
+rnHsType doc (HsDocTy ty haddock_doc)
+  = rnLHsType doc ty 	        `thenM` \ ty' ->
+    rnLHsDoc haddock_doc	`thenM` \ haddock_doc' ->
+    returnM (HsDocTy ty' haddock_doc')
+
 rnLHsTypes doc tys = mappM (rnLHsType doc) tys
 \end{code}
 
@@ -499,14 +505,20 @@ rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
 rnLPred doc  = wrapLocM (rnPred doc)
 
 rnPred doc (HsClassP clas tys)
-  = lookupOccRn clas		`thenM` \ clas_name ->
-    rnLHsTypes doc tys		`thenM` \ tys' ->
-    returnM (HsClassP clas_name tys')
-
+  = do { clas_name <- lookupOccRn clas
+       ; tys' <- rnLHsTypes doc tys
+       ; returnM (HsClassP clas_name tys')
+       }
+rnPred doc (HsEqualP ty1 ty2)
+  = do { ty1' <- rnLHsType doc ty1
+       ; ty2' <- rnLHsType doc ty2
+       ; returnM (HsEqualP ty1' ty2')
+       }
 rnPred doc (HsIParam n ty)
-  = newIPNameRn n		`thenM` \ name ->
-    rnLHsType doc ty		`thenM` \ ty' ->
-    returnM (HsIParam name ty')
+  = do { name <- newIPNameRn n
+       ; ty' <- rnLHsType doc ty
+       ; returnM (HsIParam name ty')
+       }
 \end{code}
 
 
@@ -574,6 +586,10 @@ rnPat (SigPatIn pat ty)
   where
     doc = text "In a pattern type-signature"
     
+rnPat (LitPat lit@(HsString s))
+  = do { ovlStr <- doptM Opt_OverloadedStrings
+       ; if ovlStr then rnPat (mkNPat (mkHsIsString s) Nothing)
+         else do { rnLit lit; return (LitPat lit, emptyFVs) } }  -- Same as below
 rnPat (LitPat lit) 
   = rnLit lit 	`thenM_` 
     returnM (LitPat lit, emptyFVs) 
@@ -587,7 +603,7 @@ rnPat (NPat lit mb_neg eq _)
     )					`thenM` \ (mb_neg', fvs2) ->
     lookupSyntaxName eqName		`thenM` \ (eq', fvs3) -> 
     returnM (NPat lit' mb_neg' eq' placeHolderType, 
-	      fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` eqClassName)	
+	      fvs1 `plusFV` fvs2 `plusFV` fvs3)	
 	-- Needed to find equality on pattern
 
 rnPat (NPlusKPat name lit _ _)
@@ -596,7 +612,7 @@ rnPat (NPlusKPat name lit _ _)
     lookupSyntaxName minusName		`thenM` \ (minus, fvs2) ->
     lookupSyntaxName geName		`thenM` \ (ge, fvs3) ->
     returnM (NPlusKPat name' lit' ge minus,
-	     fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` integralClassName)
+	     fvs1 `plusFV` fvs2 `plusFV` fvs3)
 	-- The Report says that n+k patterns must be in Integral
 
 rnPat (LazyPat pat)
@@ -621,23 +637,19 @@ rnPat (ParPat pat)
 
 rnPat (ListPat pats _)
   = rnLPats pats			`thenM` \ (patslist, fvs) ->
-    returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name)
+    returnM (ListPat patslist placeHolderType, fvs)
 
 rnPat (PArrPat pats _)
   = rnLPats pats			`thenM` \ (patslist, fvs) ->
     returnM (PArrPat patslist placeHolderType, 
-	      fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
+	      fvs `plusFV` implicit_fvs)
   where
     implicit_fvs = mkFVs [lengthPName, indexPName]
 
 rnPat (TuplePat pats boxed _)
-  = checkTupSize tup_size	`thenM_`
+  = checkTupSize (length pats)	`thenM_`
     rnLPats pats			`thenM` \ (patslist, fvs) ->
-    returnM (TuplePat patslist boxed placeHolderType, 
-	     fvs `addOneFV` tycon_name)
-  where
-    tup_size   = length pats
-    tycon_name = tupleTyCon_name boxed tup_size
+    returnM (TuplePat patslist boxed placeHolderType, fvs)
 
 rnPat (TypePat name) =
     rnHsTypeFVs (text "In a type pattern") name	`thenM` \ (name', fvs) ->
@@ -667,21 +679,22 @@ rnConPat con (InfixCon pat1 pat2)
 -- -----------------------------------------------------------------------------
 -- rnRpats
 
-rnRpats :: [(Located RdrName, LPat RdrName)]
-        -> RnM ([(Located Name, LPat Name)], FreeVars)
+-- Haddock comments for record fields are renamed to Nothing here
+rnRpats :: [HsRecField RdrName (LPat RdrName)] 
+        -> RnM ([HsRecField Name (LPat Name)], FreeVars)
 rnRpats rpats
   = mappM_ field_dup_err dup_fields 	`thenM_`
     mapFvRn rn_rpat rpats		`thenM` \ (rpats', fvs) ->
     returnM (rpats', fvs)
   where
-    (_, dup_fields) = removeDups compare [ unLoc f | (f,_) <- rpats ]
+    (_, dup_fields) = removeDups compare [ unLoc f | HsRecField f _ _ <- rpats ]
 
     field_dup_err dups = addErr (dupFieldErr "pattern" dups)
 
-    rn_rpat (field, pat)
+    rn_rpat (HsRecField field pat _)
       = lookupLocatedGlobalOccRn field	`thenM` \ fieldname ->
 	rnLPat pat			`thenM` \ (pat', fvs) ->
-	returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname)
+	returnM ((mkRecField fieldname pat'), fvs `addOneFV` unLoc fieldname)
 
 \end{code}
 
@@ -728,6 +741,10 @@ rnOverLit (HsFractional i _)
 	-- and denominator (see DsUtils.mkIntegerLit)
     in
     returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
+
+rnOverLit (HsIsString s _)
+  = lookupSyntaxName fromStringName	`thenM` \ (from_string_name, fvs) ->
+	returnM (HsIsString s from_string_name, fvs)
 \end{code}