X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=372ccab14859547f72c691d131472091aef25865;hb=e4137764fddd9003f1d2a234de7b2fc076be335d;hp=875d4f605fc04f265692399e2a446bf25b8bb55a;hpb=844fa86873b806594191043afdea638472f45619;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 875d4f6..372ccab 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -29,13 +29,12 @@ 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, main_RDR_Unqual ) import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv ) -import TyCon ( isOpenTyCon ) import TcHsSyn ( zonkTopDecls ) import TcExpr ( tcInferRho ) import TcRnMonad @@ -59,6 +58,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 +155,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) ; @@ -232,7 +232,15 @@ tcRnModule hsc_env hsc_src save_rn_syntax reportDeprecations (hsc_dflags hsc_env) tcg_env ; -- Process the export list - rn_exports <- rnExports export_ies; + 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) ; @@ -248,7 +256,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 } ; @@ -380,7 +391,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 ; @@ -474,7 +484,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,8 +573,9 @@ checkHiBootIface 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) + = vcat [ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file"), + ptext SLIT("Decl") <+> ppr real_decl, + ptext SLIT("Boot file:") <+> ppr boot_decl] instMisMatch inst = hang (ppr inst) 2 (ptext SLIT("is defined in the hs-boot file, but not in the module")) @@ -630,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, @@ -650,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 @@ -965,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]