Parse and desugar equational constraints

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

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index d04a0d9..8dbf887 100644 (file)
--- 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}