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

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

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index ea29fb1..b71776b 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -29,7 +29,7 @@ import StaticFlags    ( opt_PprStyle_Debug )
 import HsSyn           ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
                          SpliceDecl(..), HsBind(..), LHsBinds,
                          emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds,
-                         nlHsApp, nlHsVar, pprLHsBinds )
+                         nlHsApp, nlHsVar, pprLHsBinds, HaddockModInfo(..) )
 import RdrHsSyn                ( findSplice )
 
 import PrelNames       ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN,
@@ -59,6 +59,7 @@ import RnNames                ( importsFromLocalDecls, rnImports, rnExports,
                          reportUnusedNames, reportDeprecations )
 import RnEnv           ( lookupSrcOcc_maybe )
 import RnSource                ( rnSrcDecls, rnTyClDecls, checkModDeprec )
+import RnHsDoc          ( rnMbHsDoc )
 import PprCore         ( pprRules, pprCoreBindings )
 import CoreSyn         ( CoreRule, bindersOfBinds )
 import ErrUtils                ( Messages, mkDumpDoc, showPass )
@@ -155,7 +156,7 @@ tcRnModule :: HscEnv
 
 tcRnModule hsc_env hsc_src save_rn_syntax
         (L loc (HsModule maybe_mod export_ies 
-                         import_decls local_decls mod_deprec))
+                         import_decls local_decls mod_deprec _ module_info maybe_doc))
  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 
    let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
@@ -233,8 +234,17 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 
                -- Process the export list
        rn_exports <- rnExports export_ies ;
+                 
+               -- Rename the Haddock documentation header 
+       rn_module_doc <- rnMbHsDoc maybe_doc ;
+
+               -- Rename the Haddock module info 
+       rn_description <- rnMbHsDoc (hmi_description module_info) ;
+       let { rn_module_info = module_info { hmi_description = rn_description } } ;
+
         let { liftM2' fn a b = do a' <- a; b' <- b; return (fn a' b') } ;
-        exports <- mkExportNameSet (isJust maybe_mod) (liftM2' (,) rn_exports export_ies) ;
+        exports <- mkExportNameSet (isJust maybe_mod) 
+                                  (liftM2' (,) rn_exports export_ies) ;
 
                -- Check whether the entire module is deprecated
                -- This happens only once per module
@@ -247,7 +257,10 @@ tcRnModule hsc_env hsc_src save_rn_syntax
                                                       else Nothing,
                                     tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
                                     tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` 
-                                                  mod_deprecs }
+                                                  mod_deprecs,
+                                    tcg_doc = rn_module_doc, 
+                                    tcg_hmi = rn_module_info
+                                 }
                -- A module deprecation over-rides the earlier ones
             } ;
 
@@ -379,7 +392,6 @@ tcRnSrcDecls decls
              TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, 
                         tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
 
-       tcDump tcg_env ;
        (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
                                                           rules fords ;
 
@@ -473,7 +485,8 @@ tcRnHsBootDecls decls
 
                -- Typecheck instance decls
        ; traceTc (text "Tc3")
-       ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
+       ; (tcg_env, inst_infos, _binds) 
+            <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
        ; setGblEnv tcg_env     $ do {
 
                -- Typecheck value declarations
@@ -562,6 +575,7 @@ missingBootThing thing
   = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
 bootMisMatch thing boot_decl real_decl
   = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
+    $+$ (ppr boot_decl) $+$ (ppr real_decl)
 instMisMatch inst
   = hang (ppr inst)
        2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
@@ -628,6 +642,7 @@ tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
 tcTopSrcDecls boot_details
        (HsGroup { hs_tyclds = tycl_decls, 
                   hs_instds = inst_decls,
+                   hs_derivds = deriv_decls,
                   hs_fords  = foreign_decls,
                   hs_defds  = default_decls,
                   hs_ruleds = rule_decls,
@@ -648,7 +663,8 @@ tcTopSrcDecls boot_details
                -- Source-language instances, including derivings,
                -- and import the supporting declarations
         traceTc (text "Tc3") ;
-       (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
+       (tcg_env, inst_infos, deriv_binds) 
+            <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
        setGblEnv tcg_env       $ do {
 
                -- Foreign import declarations next.  No zonking necessary
@@ -963,15 +979,20 @@ mkPlan stmt@(L loc (BindStmt {}))
   | [L _ v] <- collectLStmtBinders stmt                -- One binder, for a bind stmt 
   = do { let print_v  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
                                           (HsVar thenIOName) placeHolderType
+
+       ; print_bind_result <- doptM Opt_PrintBindResult
+       ; let print_plan = do
+                 { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
+                 ; v_ty <- zonkTcType (idType v_id)
+                 ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
+                 ; return stuff }
+
        -- The plans are:
        --      [stmt; print v]         but not if v::()
        --      [stmt]
-       ; runPlans [do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
-                      ; v_ty <- zonkTcType (idType v_id)
-                      ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
-                      ; return stuff },
-                   tcGhciStmts [stmt]
-         ]}
+       ; runPlans ((if print_bind_result then [print_plan] else []) ++
+                   [tcGhciStmts [stmt]])
+       }
 
 mkPlan stmt
   = tcGhciStmts [stmt]