Merge Haddock comment support from ghc.haddock -- big patch

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

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index e209036..fe51c1a 100644 (file)
--- 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) )
+import DynFlags                ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts, Opt_ScopedTypeVariables ) )
 
 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, 
@@ -121,17 +122,16 @@ rnHsType doc (HsTyVar tyvar)
   = lookupOccRn tyvar          `thenM` \ tyvar' ->
     returnM (HsTyVar tyvar')
 
-rnHsType doc (HsOpTy ty1 (L loc op) ty2)
-  = setSrcSpan loc (
-      lookupOccRn op                   `thenM` \ op' ->
-      let
-       l_op' = L loc op'
-      in
-      lookupTyFixityRn l_op'           `thenM` \ fix ->
-      rnLHsType doc ty1                        `thenM` \ ty1' ->
-      rnLHsType doc ty2                        `thenM` \ ty2' -> 
-      mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2'
-   )
+rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
+  = setSrcSpan loc $ 
+    do { ty_ops_ok <- doptM Opt_ScopedTypeVariables    -- Badly named option
+       ; checkErr ty_ops_ok (opTyErr op ty)
+       ; op' <- lookupOccRn op
+       ; let l_op' = L loc op'
+       ; fix <- lookupTyFixityRn l_op'
+       ; ty1' <- rnLHsType doc ty1
+       ; ty2' <- rnLHsType doc ty2
+       ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2' }
 
 rnHsType doc (HsParTy ty)
   = rnLHsType doc ty           `thenM` \ ty' ->
@@ -189,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}
 
@@ -535,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
@@ -669,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}
 
@@ -752,12 +757,14 @@ checkTupSize tup_size
 
 forAllWarn doc ty (L loc tyvar)
   = ifOptM Opt_WarnUnusedMatches       $
-    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))]
+    addWarnAt loc (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
-                )
+                  doc)
+
+opTyErr op ty 
+  = hang (ptext SLIT("Illegal operator") <+> quotes (ppr op) <+> ptext SLIT("in type") <+> quotes (ppr ty))
+        2 (parens (ptext SLIT("Use -fscoped-type-variables to allow operators in types")))
 
 bogusCharError c
   = ptext SLIT("character literal out of range: '\\") <> char c  <> char '\''