X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnTypes.lhs;h=8dbf8878b37f0c84177718a02431d909f15b768b;hb=5d0b2bba1dfc0b2786162927ed7b3d4911f1cc54;hp=d04a0d93d4e6d90a78231c0ca59bc1f4e4d631c3;hpb=7fbb69b209250fbf3f311073146c83c88a53391b;p=ghc-hetmet.git

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index d04a0d9..8dbf887 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -28,6 +28,7 @@ import RdrHsSyn		( extractHsRhoRdrTyVars )
 import RnHsSyn		( extractHsTyNames, parrTyCon_name, tupleTyCon_name, 
 			  listTyCon_name
 			)
+import RnHsDoc          ( rnLHsDoc )
 import RnEnv		( lookupOccRn, lookupBndrRn, lookupSyntaxName,
 			  lookupLocatedOccRn, lookupLocatedBndrRn,
 			  lookupLocatedGlobalOccRn, bindTyVarsRn, 
@@ -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}
 
 
@@ -534,7 +546,6 @@ rnPatsAndThen ctxt pats thing_inside
     bindLocatedLocalsFV doc_pat bndrs	$ \ new_bndrs ->
     rnLPats pats			`thenM` \ (pats', pat_fvs) ->
     thing_inside pats'			`thenM` \ (res, res_fvs) ->
-
     let
 	unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs
     in
@@ -668,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}