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

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index d04a0d9..fe51c1a 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}
 
@@ -534,7 +540,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 +673,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}