remove Haddock-lexing/parsing/renaming from GHC

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

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 3c9f77f..fa69a44 100644 (file)
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -21,11 +21,10 @@ import RnBinds              ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSig
                                 makeMiniFixityEnv)
 import RnEnv           ( lookupLocalDataTcNames, lookupLocatedOccRn,
                          lookupTopBndrRn, lookupLocatedTopBndrRn,
-                         lookupOccRn, newLocalsRn, 
+                         lookupOccRn, newLocalBndrsRn, 
                          bindLocatedLocalsFV, bindPatSigTyVarsFV,
                          bindTyVarsRn, extendTyVarEnvFVRn,
-                         bindLocalNames, checkDupRdrNames, mapFvRn,
-                         checkM
+                         bindLocalNames, checkDupRdrNames, mapFvRn
                        )
 import RnNames         ( getLocalNonValBinders, extendGlobalRdrEnvRn )
 import HscTypes        ( GenAvailInfo(..), availsToNameSet )
@@ -42,13 +41,12 @@ import Bag
 import FastString
 import SrcLoc
 import DynFlags        ( DynFlag(..) )
-import Maybe            ( isNothing )
 import BasicTypes       ( Boxity(..) )
 
 import ListSetOps    (findDupsEq)
-import List
 
 import Control.Monad
+import Data.Maybe
 \end{code}
 
 \begin{code}
@@ -232,7 +230,7 @@ rnList f xs = mapFvRn (wrapLocFstM f) xs
 %*********************************************************
 
 \begin{code}
-rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
+rnDocDecl :: DocDecl -> RnM DocDecl
 rnDocDecl (DocCommentNext doc) = do 
   rn_doc <- rnHsDoc doc
   return (DocCommentNext rn_doc)
@@ -501,9 +499,16 @@ extendTyVarEnvForMethodBinds tyvars thing_inside
 \begin{code}
 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
 rnSrcDerivDecl (DerivDecl ty)
-  = do ty' <- rnLHsType (text "a deriving decl") ty
-       let fvs = extractHsTyNames ty'
-       return (DerivDecl ty', fvs)
+  = do { standalone_deriv_ok <- doptM Opt_StandaloneDeriving
+       ; unless standalone_deriv_ok (addErr standaloneDerivErr)
+       ; ty' <- rnLHsType (text "a deriving decl") ty
+       ; let fvs = extractHsTyNames ty'
+       ; return (DerivDecl ty', fvs) }
+
+standaloneDerivErr :: SDoc
+standaloneDerivErr 
+  = hang (ptext (sLit "Illegal standalone deriving declaration"))
+       2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
 \end{code}
 
 %*********************************************************
@@ -599,7 +604,6 @@ validRuleLhs foralls lhs
     check_e (HsApp e1 e2)               = checkl_e e1 `mplus` checkl_e e2
     check_e (NegApp e _)                = checkl_e e
     check_e (ExplicitList _ es)         = checkl_es es
-    check_e (ExplicitTuple es _) = checkl_es es
     check_e other               = Just other   -- Fails
 
     checkl_es es = foldr (mplus . checkl_e) Nothing es
@@ -636,9 +640,9 @@ However, we can also do some scoping checks at the same time.
 
 \begin{code}
 rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
-rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
+rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
   = lookupLocatedTopBndrRn name                `thenM` \ name' ->
-    return (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
+    return (ForeignType {tcdLName = name', tcdExtName = ext_name},
             emptyFVs)
 
 -- all flavours of type family declarations ("type family", "newtype fanily",
@@ -781,7 +785,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
                -- No need to check for duplicate method signatures
                -- since that is done by RnNames.extendGlobalRdrEnvRn
                -- and the methods are already in scope
-           ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
+           ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
            ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
 
   -- Haddock docs 
@@ -926,25 +930,17 @@ rnFamily :: TyClDecl RdrName
 rnFamily (tydecl@TyFamily {tcdFlavour = flavour, 
                           tcdLName = tycon, tcdTyVars = tyvars}) 
         bindIdxVars =
-      do { checkM (isDataFlavour flavour                      -- for synonyms,
-                  || not (null tyvars)) $ addErr needOneIdx  -- no. of indexes >= 1
-        ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
+      do { bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do {
         ; tycon' <- lookupLocatedTopBndrRn tycon
         ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon', 
                              tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, 
                    emptyFVs) 
          } }
-      where
-        isDataFlavour DataFamily = True
-       isDataFlavour _          = False
 rnFamily d _ = pprPanic "rnFamily" (ppr d)
 
 family_doc :: Located RdrName -> SDoc
 family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon)
 
-needOneIdx :: SDoc
-needOneIdx = text "Type family declarations requires at least one type index"
-
 -- Rename associated type declarations (in classes)
 --
 -- * This can be family declarations and (default) type instances
@@ -955,7 +951,7 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
     rn_at (tydecl@TySynonym {}) = 
       do
-        checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
+        unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
         rnTyClDecl tydecl
     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"