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
import TcType ( tidyTopType, tcEqType )
import Inst ( showLIE )
-import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId )
+import InstEnv ( extendInstEnvList, Instance, pprInstances,
+ instanceDFunId )
+import FamInstEnv ( FamInst, pprFamInsts )
import TcBinds ( tcTopBinds, tcHsBootSigs )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv, iDFunId )
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 )
import Util ( sortLe )
import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
+import Control.Monad ( unless )
import Data.Maybe ( isJust )
\end{code}
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) ;
-- 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
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
} ;
final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
- mod_guts = ModGuts { mg_module = this_mod,
- mg_boot = False,
- mg_usages = [], -- ToDo: compute usage
- mg_dir_imps = [], -- ??
- mg_deps = noDependencies, -- ??
- mg_exports = my_exports,
- mg_types = final_type_env,
- mg_insts = tcg_insts tcg_env,
- mg_rules = [],
- mg_binds = core_binds,
+ mod_guts = ModGuts { mg_module = this_mod,
+ mg_boot = False,
+ mg_usages = [], -- ToDo: compute usage
+ mg_dir_imps = [], -- ??
+ mg_deps = noDependencies, -- ??
+ mg_exports = my_exports,
+ mg_types = final_type_env,
+ mg_insts = tcg_insts tcg_env,
+ mg_fam_insts = tcg_fam_insts tcg_env,
+ mg_rules = [],
+ mg_binds = core_binds,
-- Stubs
- mg_rdr_env = emptyGlobalRdrEnv,
- mg_fix_env = emptyFixityEnv,
- mg_deprecs = NoDeprecs,
- mg_foreign = NoStubs
+ mg_rdr_env = emptyGlobalRdrEnv,
+ mg_fix_env = emptyFixityEnv,
+ mg_deprecs = NoDeprecs,
+ mg_foreign = NoStubs
} } ;
tcCoreDump mod_guts ;
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 ;
-- 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
-- hs-boot file, such as $fbEqT = $fEqT
checkHiBootIface
- (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env })
- (ModDetails { md_insts = boot_insts, md_types = boot_type_env })
+ (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts,
+ tcg_type_env = local_type_env })
+ (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
+ md_types = boot_type_env })
= do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ;
; mapM_ check_one (typeEnvElts boot_type_env)
; dfun_binds <- mapM check_inst boot_insts
+ ; unless (null boot_fam_insts) $
+ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
+ "instances in boot files yet...")
+ -- FIXME: Why? The actual comparison is not hard, but what would
+ -- be the equivalent to the dfun bindings returned for class
+ -- instances? We can't easily equate tycons...
; return (unionManyBags dfun_binds) }
where
check_one boot_thing
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")
+ = 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"))
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,
-- 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
| [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]
-- It's unpleasant having both pprModGuts and pprModDetails here
pprTcGblEnv :: TcGblEnv -> SDoc
-pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
- tcg_insts = dfun_ids,
- tcg_rules = rules,
- tcg_imports = imports })
- = vcat [ ppr_types dfun_ids type_env
- , ppr_insts dfun_ids
+pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
+ tcg_insts = insts,
+ tcg_fam_insts = fam_insts,
+ tcg_rules = rules,
+ tcg_imports = imports })
+ = vcat [ ppr_types insts type_env
+ , ppr_insts insts
+ , ppr_fam_insts fam_insts
, vcat (map ppr rules)
, ppr_gen_tycons (typeEnvTyCons type_env)
, ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports))
= vcat [ ppr_types [] type_env,
ppr_rules rules ]
-
ppr_types :: [Instance] -> TypeEnv -> SDoc
-ppr_types ispecs type_env
+ppr_types insts type_env
= text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
where
- dfun_ids = map instanceDFunId ispecs
+ dfun_ids = map instanceDFunId insts
ids = [id | id <- typeEnvIds type_env, want_sig id]
want_sig id | opt_PprStyle_Debug = True
| otherwise = isLocalId id &&
ppr_insts [] = empty
ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
+ppr_fam_insts :: [FamInst] -> SDoc
+ppr_fam_insts [] = empty
+ppr_fam_insts fam_insts =
+ text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
+
ppr_sigs :: [Var] -> SDoc
ppr_sigs ids
-- Print type signatures; sort by OccName