X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=d1333b3833d52fc9f487a114005dd49813f3b7f8;hb=afaceeff37e6347113399f6ec8a61dfcbd22dcac;hp=7bf2f8763121d1b4f9132f2f66e40cea7981fe7e;hpb=0ab8b6d4e614cfa43529e8f7aa1e6b621f6e0c18;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 7bf2f87..d1333b3 100644 --- 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, @@ -40,7 +40,9 @@ 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 ) @@ -48,7 +50,8 @@ import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcIface ( tcExtCoreBindings, tcHiBootIface ) -import IfaceSyn ( checkBootDecl, tyThingToIfaceDecl, IfaceExtName(..) ) +import MkIface ( tyThingToIfaceDecl ) +import IfaceSyn ( checkBootDecl, IfaceExtName(..) ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import LoadIface ( loadOrphanModules ) @@ -57,6 +60,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 ) @@ -87,7 +91,7 @@ import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsLocalBinds(..), HsValBinds(..), LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds, collectLStmtsBinders, collectLStmtBinders, nlVarPat, - mkFunBind, placeHolderType, noSyntaxExpr ) + mkFunBind, placeHolderType, noSyntaxExpr, nlHsTyApp ) import RdrName ( GlobalRdrElt(..), globalRdrEnvElts, unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv ) import RnSource ( addTcgDUs ) @@ -96,6 +100,7 @@ import TcHsType ( kcHsType ) import TcMType ( zonkTcType, zonkQuantifiedTyVar ) import TcMatches ( tcStmts, tcDoStmt ) import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) +import TcGadt ( emptyRefinement ) import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy, isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy ) import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) @@ -112,7 +117,7 @@ import MkId ( unsafeCoerceId ) import TyCon ( tyConName ) import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) -import Kind ( Kind ) +import {- Kind parts of -} Type ( Kind ) import Var ( globaliseId ) import Name ( isBuiltInSyntax, isInternalName ) import OccName ( isTcOcc ) @@ -124,13 +129,15 @@ import HscTypes ( InteractiveContext(..), Dependencies(..) ) import BasicTypes ( Fixity, RecFlag(..) ) import SrcLoc ( unLoc ) +import Data.Maybe ( isNothing ) #endif import FastString ( mkFastString ) import Util ( sortLe ) import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) -import Data.Maybe ( isJust, isNothing ) +import Control.Monad ( unless ) +import Data.Maybe ( isJust ) \end{code} @@ -151,7 +158,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) ; @@ -229,8 +236,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 @@ -243,7 +259,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 } ; @@ -307,22 +326,23 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) 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 ; @@ -375,7 +395,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 ; @@ -427,6 +446,7 @@ tc_rn_src_decls boot_details ds -- Rename the splice expression, and get its supporting decls (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ; failIfErrsM ; -- Don't typecheck if renaming failed + rnDump (ppr rn_splice_expr) ; -- Execute the splice spliced_decls <- tcSpliceDecls rn_splice_expr ; @@ -468,7 +488,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 @@ -508,11 +529,19 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) -- 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 @@ -556,7 +585,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") + = 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")) @@ -623,6 +654,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, @@ -643,7 +675,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 @@ -854,16 +887,30 @@ tcRnStmt hsc_env ictxt rdr_stmt bound_names = map idName global_ids ; new_rn_env = extendLocalRdrEnv rn_env bound_names ; - -- Remove any shadowed bindings from the type_env; - -- they are inaccessible but might, I suppose, cause - -- a space leak if we leave them there +{- --------------------------------------------- + At one stage I removed any shadowed bindings from the type_env; + they are inaccessible but might, I suppose, cause a space leak if we leave them there. + However, with Template Haskell they aren't necessarily inaccessible. Consider this + GHCi session + Prelude> let f n = n * 2 :: Int + Prelude> fName <- runQ [| f |] + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + 14 + Prelude> let f n = n * 3 :: Int + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + In the last line we use 'fName', which resolves to the *first* 'f' + in scope. If we delete it from the type env, GHCi crashes because + it doesn't expect that. + + Hence this code is commented out + shadowed = [ n | name <- bound_names, let rdr_name = mkRdrUnqual (nameOccName name), Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ; - filtered_type_env = delListFromNameEnv type_env shadowed ; - new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ; +-------------------------------------------------- -} + new_type_env = extendTypeEnvWithIds type_env global_ids ; new_ic = ictxt { ic_rn_local_env = new_rn_env, ic_type_env = new_type_env } } ; @@ -958,15 +1005,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] @@ -980,6 +1032,8 @@ tcGhciStmts stmts io_ty = mkTyConApp ioTyCon [] ; ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; + tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts + (emptyRefinement, io_ret_ty) ; names = map unLoc (collectLStmtsBinders stmts) ; @@ -994,17 +1048,16 @@ tcGhciStmts stmts -- then the type checker would instantiate x..z, and we wouldn't -- get their *polymorphic* values. (And we'd get ambiguity errs -- if they were overloaded, since they aren't applied to anything.) - mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty]) + mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty]) (noLoc $ ExplicitList unitTy (map mk_item ids)) ; - mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy]) + mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) (nlHsVar id) } ; -- OK, we're ready to typecheck the stmts traceTc (text "tcs 2") ; - ((tc_stmts, ids), lie) <- getLIE $ - tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ -> - mappM tcLookupId names ; + ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ -> + mappM tcLookupId names ; -- Look up the names right in the middle, -- where they will all be in scope @@ -1261,12 +1314,14 @@ tcCoreDump mod_guts -- 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)) @@ -1278,12 +1333,11 @@ pprModGuts (ModGuts { mg_types = type_env, = 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 && @@ -1298,6 +1352,11 @@ ppr_insts :: [Instance] -> SDoc 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