remove Haddock-lexing/parsing/renaming from GHC

[ghc-hetmet.git] / compiler / typecheck / TcRnDriver.lhs

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 30574ae..12069ff 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -25,7 +25,7 @@ module TcRnDriver (
        tcRnExtCore
     ) where
 
-import IO
+import System.IO
 #ifdef GHCI
 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
 #endif
@@ -111,8 +111,6 @@ import Data.Maybe   ( isJust )
 #include "HsVersions.h"
 \end{code}
 
-
-
 %************************************************************************
 %*                                                                     *
        Typecheck and rename a module
@@ -130,7 +128,7 @@ tcRnModule :: HscEnv
 tcRnModule hsc_env hsc_src save_rn_syntax
         (L loc (HsModule maybe_mod export_ies 
                          import_decls local_decls mod_deprec
-                         module_info maybe_doc))
+                         maybe_doc_hdr))
  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 
    let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
@@ -188,8 +186,9 @@ tcRnModule hsc_env hsc_src save_rn_syntax
        -- because the latter might add new bindings for boot_dfuns, 
        -- which may be mentioned in imported unfoldings
 
-               -- Rename the Haddock documentation 
-       tcg_env <- rnHaddock module_info maybe_doc tcg_env ;
+               -- Don't need to rename the Haddock documentation,
+               -- it's not parsed by GHC anymore.
+       tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
 
                -- Report unused names
        reportUnusedNames export_ies tcg_env ;
@@ -644,6 +643,53 @@ checkBootDecl (AnId id1) (AnId id2)
     (idType id1 `tcEqType` idType id2)
 
 checkBootDecl (ATyCon tc1) (ATyCon tc2)
+  = checkBootTyCon tc1 tc2
+
+checkBootDecl (AClass c1)  (AClass c2)
+  = let 
+       (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) 
+          = classExtraBigSig c1
+       (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2) 
+          = classExtraBigSig c2
+
+       env0 = mkRnEnv2 emptyInScopeSet
+       env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2
+
+       eqSig (id1, def_meth1) (id2, def_meth2)
+         = idName id1 == idName id2 &&
+           tcEqTypeX env op_ty1 op_ty2
+         where
+         (_, rho_ty1) = splitForAllTys (idType id1)
+         op_ty1 = funResultTy rho_ty1
+         (_, rho_ty2) = splitForAllTys (idType id2)
+          op_ty2 = funResultTy rho_ty2
+
+       eqFD (as1,bs1) (as2,bs2) = 
+         eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
+         eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
+
+       same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2)
+    in
+       eqListBy same_kind clas_tyvars1 clas_tyvars2 &&
+                    -- Checks kind of class
+       eqListBy eqFD clas_fds1 clas_fds2 &&
+       (null sc_theta1 && null op_stuff1 && null ats1
+        ||   -- Above tests for an "abstract" class
+        eqListBy (tcEqPredX env) sc_theta1 sc_theta2 &&
+        eqListBy eqSig op_stuff1 op_stuff2 &&
+        eqListBy checkBootTyCon ats1 ats2)
+
+checkBootDecl (ADataCon dc1) (ADataCon dc2)
+  = pprPanic "checkBootDecl" (ppr dc1)
+
+checkBootDecl _ _ = False -- probably shouldn't happen
+
+----------------
+checkBootTyCon :: TyCon -> TyCon -> Bool
+checkBootTyCon tc1 tc2
+  | not (eqKind (tyConKind tc1) (tyConKind tc2))
+  = False      -- First off, check the kind
+
   | isSynTyCon tc1 && isSynTyCon tc2
   = ASSERT(tc1 == tc2)
     let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
@@ -659,11 +705,13 @@ checkBootDecl (ATyCon tc1) (ATyCon tc2)
 
   | isAlgTyCon tc1 && isAlgTyCon tc2
   = ASSERT(tc1 == tc2)
-    eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2)
-    && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
+    eqKind (tyConKind tc1) (tyConKind tc2) &&
+    eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
+    eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
 
   | isForeignTyCon tc1 && isForeignTyCon tc2
-  = tyConExtName tc1 == tyConExtName tc2
+  = eqKind (tyConKind tc1) (tyConKind tc2) &&
+    tyConExtName tc1 == tyConExtName tc2
   where 
         env0 = mkRnEnv2 emptyInScopeSet
 
@@ -692,41 +740,6 @@ checkBootDecl (ATyCon tc1) (ATyCon tc2)
                         (dataConOrigArgTys c1)
                         (dataConOrigArgTys c2)
 
-checkBootDecl (AClass c1)  (AClass c2)
-  = let 
-       (clas_tyvars1, clas_fds1, sc_theta1, _, _, op_stuff1) 
-          = classExtraBigSig c1
-       (clas_tyvars2, clas_fds2, sc_theta2, _, _, op_stuff2) 
-          = classExtraBigSig c2
-
-       env0 = mkRnEnv2 emptyInScopeSet
-       env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2
-
-       eqSig (id1, def_meth1) (id2, def_meth2)
-         = idName id1 == idName id2 &&
-           tcEqTypeX env op_ty1 op_ty2
-         where
-         (_, rho_ty1) = splitForAllTys (idType id1)
-         op_ty1 = funResultTy rho_ty1
-         (_, rho_ty2) = splitForAllTys (idType id2)
-          op_ty2 = funResultTy rho_ty2
-
-       eqFD (as1,bs1) (as2,bs2) = 
-         eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
-         eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
-    in
-       equalLength clas_tyvars1 clas_tyvars2 &&
-       eqListBy eqFD clas_fds1 clas_fds2 &&
-       (null sc_theta1 && null op_stuff1
-        ||
-        eqListBy (tcEqPredX env) sc_theta1 sc_theta2 &&
-        eqListBy eqSig op_stuff1 op_stuff2)
-
-checkBootDecl (ADataCon dc1) (ADataCon dc2)
-  = pprPanic "checkBootDecl" (ppr dc1)
-
-checkBootDecl _ _ = False -- probably shouldn't happen
-
 ----------------
 missingBootThing thing what
   = ppr thing <+> ptext (sLit "is exported by the hs-boot file, but not")