% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[TcModule]{Typechecking a whole module}
+\section[TcMovectle]{Typechecking a whole module}
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module TcRnDriver (
#ifdef GHCI
tcRnStmt, tcRnExpr, tcRnType,
tcRnLookupRdrName,
+ getModuleExports,
+#endif
+ tcRnImports,
tcRnLookupName,
tcRnGetInfo,
- getModuleExports,
-#endif
tcRnModule,
tcTopSrcDecls,
tcRnExtCore
) where
-import IO
#ifdef GHCI
import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
#endif
import DynFlags
import StaticFlags
import HsSyn
-import RdrHsSyn
-
import PrelNames
import RdrName
import TcHsSyn
import TcExpr
import TcRnMonad
-import TcType
-import Inst
+import Coercion
import FamInst
import InstEnv
import FamInstEnv
+import TcAnnotations
import TcBinds
+import TcType ( tidyTopType )
import TcDefaults
import TcEnv
import TcRules
import TcForeign
import TcInstDcls
import TcIface
+import TcMType
import MkIface
import IfaceSyn
import TcSimplify
import TcTyClsDecls
-import TcUnify ( withBox )
import LoadIface
import RnNames
import RnEnv
import RnSource
-import RnHsDoc
import PprCore
import CoreSyn
import ErrUtils
import Id
+import VarEnv
import Var
import Module
-import LazyUniqFM
+import UniqFM
import Name
import NameEnv
import NameSet
import TyCon
-import TysWiredIn
+import TysPrim
import SrcLoc
import HscTypes
import ListSetOps
import Outputable
+import DataCon
+import Type
+import Class
+import TcType ( orphNamesOfDFunHead )
+import Inst ( tcGetInstEnvs )
+import Data.List ( sortBy )
#ifdef GHCI
-import Linker
-import DataCon
+import TcType ( isUnitTy, isTauTy )
+import CoreUtils( mkPiTypes )
import TcHsType
-import TcMType
import TcMatches
import RnTypes
import RnExpr
import IfaceEnv
import MkId
-import IdInfo
-import {- Kind parts of -} Type
import BasicTypes
-import Foreign.Ptr( Ptr )
+import TidyPgm ( globaliseAndTidyId )
+import TysWiredIn ( unitTy, mkListTy )
#endif
import FastString
import Bag
import Control.Monad
-import Data.Maybe ( isJust )
+#include "HsVersions.h"
\end{code}
-
-
%************************************************************************
%* *
Typecheck and rename a module
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) ;
-- thing (especially via 'module Foo' export item)
-- That is, only uses in the *body* of the module are complained about
traceRn (text "rn3") ;
- failIfErrsM ; -- finishDeprecations crashes sometimes
+ failIfErrsM ; -- finishWarnings crashes sometimes
-- as a result of typechecker repairs (e.g. unboundNames)
- tcg_env <- finishDeprecations (hsc_dflags hsc_env) mod_deprec tcg_env ;
+ tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ;
-- Process the export list
- traceRn (text "rn4a: before exports");
+ traceRn (text "rn4a: before exports");
tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
traceRn (text "rn4b: after exportss") ;
+ -- Check that main is exported (must be after rnExports)
+ checkMainExported tcg_env ;
+
-- Compare the hi-boot iface (if any) with the real thing
-- Must be done after processing the exports
tcg_env <- checkHiBootIface tcg_env boot_iface ;
- -- Make the new type env available to stuff slurped from interface files
- -- Must do this after checkHiBootIface, because the latter might add new
- -- bindings for boot_dfuns, which may be mentioned in imported unfoldings
- writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
+ -- The new type env is already available to stuff slurped from
+ -- interface files, via TcEnv.updateGlobalTypeEnv
+ -- It's important that this includes the stuff in checkHiBootIface,
+ -- 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 ;
gbl {
tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env,
tcg_imports = tcg_imports gbl `plusImportAvails` imports,
- tcg_rn_imports = fmap (const rn_imports) (tcg_rn_imports gbl),
+ tcg_rn_imports = rn_imports,
tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
home_fam_insts,
-- Check type-familily consistency
; traceRn (text "rn1: checking family instance consistency")
- ; let { dir_imp_mods = map (\ (mod, _) -> mod)
- . moduleEnvElts
+ ; let { dir_imp_mods = moduleEnvKeys
. imp_mods
$ imports }
; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
-- (in fact, it might not even need to be in the scope of
-- this tcg_env at all)
avails <- getLocalNonValBinders (mkFakeGroup ldecls) ;
- tc_envs <- extendGlobalRdrEnvRn False avails
- emptyFsEnv {- no fixity decls -} ;
+ tc_envs <- extendGlobalRdrEnvRn avails emptyFsEnv {- no fixity decls -} ;
setEnvs tc_envs $ do {
- rn_decls <- checkNoErrs $ rnTyClDecls ldecls ;
+ (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ;
-- Dump trace of renaming part
rnDump (ppr rn_decls) ;
-- Typecheck them all together so that
-- any mutually recursive types are done right
- tcg_env <- tcTyAndClassDecls emptyModDetails rn_decls ;
- -- Make the new type env available to stuff slurped from interface files
+ -- Just discard the auxiliary bindings; they are generated
+ -- only for Haskell source code, and should already be in Core
+ (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ;
setGblEnv tcg_env $ do {
+ -- Make the new type env available to stuff slurped from interface files
-- Now the core bindings
core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
my_exports = map (Avail . idName) bndrs ;
-- ToDo: export the data types also?
- final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
+ final_type_env =
+ extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
mod_guts = ModGuts { mg_module = this_mod,
mg_boot = False,
mg_inst_env = tcg_inst_env tcg_env,
mg_fam_inst_env = tcg_fam_inst_env tcg_env,
mg_rules = [],
+ mg_vect_decls = [],
+ mg_anns = [],
mg_binds = core_binds,
-- Stubs
mg_rdr_env = emptyGlobalRdrEnv,
mg_fix_env = emptyFixityEnv,
- mg_deprecs = NoDeprecs,
+ mg_warns = NoWarnings,
mg_foreign = NoStubs,
mg_hpc_info = emptyHpcInfo False,
mg_modBreaks = emptyModBreaks,
return mod_guts
}}}}
+mkFakeGroup :: [LTyClDecl a] -> HsGroup a
mkFakeGroup decls -- Rather clumsy; lots of unused fields
- = emptyRdrGroup { hs_tyclds = decls }
+ = emptyRdrGroup { hs_tyclds = [decls] }
\end{code}
-- Reason: solely to report unused imports and bindings
tcRnSrcDecls boot_iface decls
= do { -- Do all the declarations
- (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ;
+ (tc_envs, lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
+ ; traceTc "Tc8" empty ;
+ ; setEnvs tc_envs $
+ do {
-- Finish simplifying class constraints
--
- -- tcSimplifyTop deals with constant or ambiguous InstIds.
+ -- simplifyTop deals with constant or ambiguous InstIds.
-- How could there be ambiguous ones? They can only arise if a
-- top-level decl falls under the monomorphism restriction
-- and no subsequent decl instantiates its type.
-- thaat checkMain adds
--
-- We do it with both global and local env in scope:
- -- * the global env exposes the instances to tcSimplifyTop
- -- * the local env exposes the local Ids to tcSimplifyTop,
+ -- * the global env exposes the instances to simplifyTop
+ -- * the local env exposes the local Ids to simplifyTop,
-- so that we get better error messages (monomorphism restriction)
- traceTc (text "Tc8") ;
- inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
-
- -- Backsubstitution. This must be done last.
- -- Even tcSimplifyTop may do some unification.
- traceTc (text "Tc9") ;
- let { (tcg_env, _) = tc_envs
- ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
- tcg_rules = rules, tcg_fords = fords } = tcg_env
- ; all_binds = binds `unionBags` inst_binds } ;
+ new_ev_binds <- simplifyTop lie ;
+ traceTc "Tc9" empty ;
failIfErrsM ; -- Don't zonk if there have been errors
-- It's a waste of time; and we may get debug warnings
-- about strangely-typed TyCons!
- (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
-
- let { final_type_env = extendTypeEnvWithIds type_env bind_ids
- ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
- tcg_binds = binds',
- tcg_rules = rules',
- tcg_fords = fords' } } ;
-
- return (tcg_env' { tcg_binds = tcg_binds tcg_env' })
- }
+ -- Zonk the final code. This must be done last.
+ -- Even simplifyTop may do some unification.
+ -- This pass also warns about missing type signatures
+ let { (tcg_env, _) = tc_envs
+ ; TcGblEnv { tcg_type_env = type_env,
+ tcg_binds = binds,
+ tcg_sigs = sig_ns,
+ tcg_ev_binds = cur_ev_binds,
+ tcg_imp_specs = imp_specs,
+ tcg_rules = rules,
+ tcg_vects = vects,
+ tcg_fords = fords } = tcg_env
+ ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
+
+ (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
+ <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ;
+
+ let { final_type_env = extendTypeEnvWithIds type_env bind_ids
+ ; tcg_env' = tcg_env { tcg_binds = binds',
+ tcg_ev_binds = ev_binds',
+ tcg_imp_specs = imp_specs',
+ tcg_rules = rules',
+ tcg_vects = vects',
+ tcg_fords = fords' } } ;
+
+ setGlobalTypeEnv tcg_env' final_type_env
+ } }
tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
-- Loops around dealing with each top level inter-splice group
-- in turn, until it's dealt with the entire module
tc_rn_src_decls boot_details ds
- = do { let { (first_group, group_tail) = findSplice ds } ;
+ = do { (first_group, group_tail) <- findSplice ds ;
-- If ds is [] we get ([], Nothing)
-- Deal with decls up to, but not including, the first splice
return (tcg_env, tcl_env)
} ;
- -- If there's a splice, we must carry on
- Just (SpliceDecl splice_expr, rest_ds) -> do {
#ifndef GHCI
+ -- There shouldn't be a splice
+ Just (SpliceDecl {}, _) -> do {
failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
#else
+ -- If there's a splice, we must carry on
+ Just (SpliceDecl splice_expr _, rest_ds) -> do {
-- Rename the splice expression, and get its supporting decls
(rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
\begin{code}
tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
tcRnHsBootDecls decls
- = do { let { (first_group, group_tail) = findSplice decls }
-
- ; case group_tail of
- Just stuff -> spliceInHsBootErr stuff
- Nothing -> return ()
+ = do { (first_group, group_tail) <- findSplice decls
-- Rename the declarations
- ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
- ; setGblEnv tcg_env $ do {
+ ; (tcg_env, HsGroup {
+ hs_tyclds = tycl_decls,
+ hs_instds = inst_decls,
+ hs_derivds = deriv_decls,
+ hs_fords = for_decls,
+ hs_defds = def_decls,
+ hs_ruleds = rule_decls,
+ hs_vects = vect_decls,
+ hs_annds = _,
+ hs_valds = val_binds }) <- rnTopSrcDecls first_group
+ ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
+
- -- Todo: check no foreign decls, no rules, no default decls
+ -- Check for illegal declarations
+ ; case group_tail of
+ Just (SpliceDecl d _, _) -> badBootDecl "splice" d
+ Nothing -> return ()
+ ; mapM_ (badBootDecl "foreign") for_decls
+ ; mapM_ (badBootDecl "default") def_decls
+ ; mapM_ (badBootDecl "rule") rule_decls
+ ; mapM_ (badBootDecl "vect") vect_decls
-- Typecheck type/class decls
- ; traceTc (text "Tc2")
- ; let tycl_decls = hs_tyclds rn_group
- ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls
- ; setGblEnv tcg_env $ do {
+ ; traceTc "Tc2" empty
+ ; (tcg_env, aux_binds, dm_ids)
+ <- tcTyAndClassDecls emptyModDetails tycl_decls
+ ; setGblEnv tcg_env $
+ tcExtendIdEnv dm_ids $ do {
-- Typecheck instance decls
- ; traceTc (text "Tc3")
+ -- Family instance declarations are rejected here
+ ; traceTc "Tc3" empty
; (tcg_env, inst_infos, _deriv_binds)
- <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
+ <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls
+
; setGblEnv tcg_env $ do {
-- Typecheck value declarations
- ; traceTc (text "Tc5")
- ; val_ids <- tcHsBootSigs (hs_valds rn_group)
+ ; traceTc "Tc5" empty
+ ; val_ids <- tcHsBootSigs val_binds
-- Wrap up
-- No simplification or zonking to do
- ; traceTc (text "Tc7a")
+ ; traceTc "Tc7a" empty
; gbl_env <- getGblEnv
-- Make the final type-env
-- Include the dfun_ids so that their type sigs
- -- are written into the interface file
+ -- are written into the interface file.
+ -- And similarly the aux_ids from aux_binds
; let { type_env0 = tcg_type_env gbl_env
; type_env1 = extendTypeEnvWithIds type_env0 val_ids
; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
- ; dfun_ids = map iDFunId inst_infos }
- ; return (gbl_env { tcg_type_env = type_env2 })
- }}}}
-
-spliceInHsBootErr (SpliceDecl (L loc _), _)
- = addErrAt loc (ptext (sLit "Splices are not allowed in hs-boot files"))
+ ; type_env3 = extendTypeEnvWithIds type_env2 aux_ids
+ ; dfun_ids = map iDFunId inst_infos
+ ; aux_ids = case aux_binds of
+ ValBindsOut _ sigs -> [id | L _ (IdSig id) <- sigs]
+ _ -> panic "tcRnHsBoodDecls"
+ }
+
+ ; setGlobalTypeEnv gbl_env type_env3
+ }}}
+ ; traceTc "boot" (ppr lie); return gbl_env }
+
+badBootDecl :: String -> Located decl -> TcM ()
+badBootDecl what (L loc _)
+ = addErrAt loc (char 'A' <+> text what
+ <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file"))
\end{code}
Once we've typechecked the body of the module, we want to compare what
checkHiBootIface
tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds,
- tcg_insts = local_insts, tcg_fam_insts = local_fam_insts,
+ tcg_insts = local_insts,
tcg_type_env = local_type_env, tcg_exports = local_exports })
(ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
md_types = boot_type_env, md_exports = boot_exports })
= return tcg_env
| otherwise
- = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts $$
- ppr boot_exports)) ;
+ = do { traceTc "checkHiBootIface" $ vcat
+ [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
-- Check the exports of the boot module, one by one
; mapM_ check_export boot_exports
- -- Check instance declarations
- ; mb_dfun_prs <- mapM check_inst boot_insts
- ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds,
- tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns }
- dfun_prs = catMaybes mb_dfun_prs
- boot_dfuns = map fst dfun_prs
- dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
- | (boot_dfun, dfun) <- dfun_prs ]
-
-- Check for no family instances
; unless (null boot_fam_insts) $
panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
-- be the equivalent to the dfun bindings returned for class
-- instances? We can't easily equate tycons...
- ; return tcg_env' }
+ -- Check instance declarations
+ ; mb_dfun_prs <- mapM check_inst boot_insts
+ ; let dfun_prs = catMaybes mb_dfun_prs
+ boot_dfuns = map fst dfun_prs
+ dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
+ | (boot_dfun, dfun) <- dfun_prs ]
+ type_env' = extendTypeEnvWithIds local_type_env boot_dfuns
+ tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
+
+ ; failIfErrsM
+ ; setGlobalTypeEnv tcg_env' type_env' }
+ -- Update the global type env *including* the knot-tied one
+ -- so that if the source module reads in an interface unfolding
+ -- mentioning one of the dfuns from the boot module, then it
+ -- can "see" that boot dfun. See Trac #4003
where
check_export boot_avail -- boot_avail is exported by the boot iface
| name `elem` dfun_names = return ()
-- Check that the actual module exports the same thing
| not (null missing_names)
- = addErrTc (missingBootThing (head missing_names) "exported by")
+ = addErrAt (nameSrcSpan (head missing_names))
+ (missingBootThing (head missing_names) "exported by")
-- If the boot module does not *define* the thing, we are done
-- (it simply re-exports it, and names match, so nothing further to do)
-- Check that the actual module also defines the thing, and
-- then compare the definitions
- | Just real_thing <- lookupTypeEnv local_type_env name
- = do { let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing)
- real_decl = tyThingToIfaceDecl real_thing
- ; checkTc (checkBootDecl boot_decl real_decl)
- (bootMisMatch real_thing boot_decl real_decl) }
- -- The easiest way to check compatibility is to convert to
- -- iface syntax, where we already have good comparison functions
+ | Just real_thing <- lookupTypeEnv local_type_env name,
+ Just boot_thing <- mb_boot_thing
+ = when (not (checkBootDecl boot_thing real_thing))
+ $ addErrAt (nameSrcSpan (getName boot_thing))
+ (let boot_decl = tyThingToIfaceDecl
+ (fromJust mb_boot_thing)
+ real_decl = tyThingToIfaceDecl real_thing
+ in bootMisMatch real_thing boot_decl real_decl)
| otherwise
= addErrTc (missingBootThing name "defined in")
= case [dfun | inst <- local_insts,
let dfun = instanceDFunId inst,
idType dfun `tcEqType` boot_inst_ty ] of
- [] -> do { addErrTc (instMisMatch boot_inst); return Nothing }
+ [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
+ , text "boot_inst" <+> ppr boot_inst
+ , text "boot_inst_ty" <+> ppr boot_inst_ty
+ ])
+ ; addErrTc (instMisMatch boot_inst); return Nothing }
(dfun:_) -> return (Just (local_boot_dfun, dfun))
where
boot_dfun = instanceDFunId boot_inst
local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
+-- This has to compare the TyThing from the .hi-boot file to the TyThing
+-- in the current source file. We must be careful to allow alpha-renaming
+-- where appropriate, and also the boot declaration is allowed to omit
+-- constructors and class methods.
+--
+-- See rnfail055 for a good test of this stuff.
+
+checkBootDecl :: TyThing -> TyThing -> Bool
+
+checkBootDecl (AnId id1) (AnId id2)
+ = ASSERT(id1 == 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 &&
+ def_meth1 == def_meth2
+ 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 _)
+ = 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")
+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
+ env = rnBndrs2 env0 tvs1 tvs2
+
+ eqSynRhs SynFamilyTyCon SynFamilyTyCon
+ = True
+ eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
+ = tcEqTypeX env t1 t2
+ eqSynRhs _ _ = False
+ in
+ equalLength tvs1 tvs2 &&
+ eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2)
+
+ | isAlgTyCon tc1 && isAlgTyCon tc2
+ = ASSERT(tc1 == tc2)
+ eqKind (tyConKind tc1) (tyConKind tc2) &&
+ eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
+ eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
+
+ | isForeignTyCon tc1 && isForeignTyCon tc2
+ = eqKind (tyConKind tc1) (tyConKind tc2) &&
+ tyConExtName tc1 == tyConExtName tc2
+
+ | otherwise = False
+ where
+ env0 = mkRnEnv2 emptyInScopeSet
+
+ eqAlgRhs AbstractTyCon _ = True
+ eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
+ eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
+ eqListBy eqCon (data_cons tc1) (data_cons tc2)
+ eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
+ eqCon (data_con tc1) (data_con tc2)
+ eqAlgRhs _ _ = False
+
+ eqCon c1 c2
+ = dataConName c1 == dataConName c2
+ && dataConIsInfix c1 == dataConIsInfix c2
+ && dataConStrictMarks c1 == dataConStrictMarks c2
+ && dataConFieldLabels c1 == dataConFieldLabels c2
+ && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1
+ tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2
+ env = rnBndrs2 env0 tvs1 tvs2
+ in
+ equalLength tvs1 tvs2 &&
+ eqListBy (tcEqPredX env)
+ (dataConEqTheta c1 ++ dataConDictTheta c1)
+ (dataConEqTheta c2 ++ dataConDictTheta c2) &&
+ eqListBy (tcEqTypeX env)
+ (dataConOrigArgTys c1)
+ (dataConOrigArgTys c2)
+
+----------------
+missingBootThing :: Name -> String -> SDoc
+missingBootThing name what
+ = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not")
<+> text what <+> ptext (sLit "the module")
+bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc
bootMisMatch thing boot_decl real_decl
= vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"),
ptext (sLit "Main module:") <+> ppr real_decl,
ptext (sLit "Boot file: ") <+> ppr boot_decl]
+instMisMatch :: Instance -> SDoc
instMisMatch inst
= hang (ppr inst)
2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
-- Fails if there are any errors
rnTopSrcDecls group
- = do { -- Rename the source decls (with no shadowing; error on duplicates)
- (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls False group ;
+ = do { -- Rename the source decls
+ traceTc "rn12" empty ;
+ (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
+ traceTc "rn13" empty ;
-- save the renamed syntax, if we want it
let { tcg_env'
hs_derivds = deriv_decls,
hs_fords = foreign_decls,
hs_defds = default_decls,
+ hs_annds = annotation_decls,
hs_ruleds = rule_decls,
+ hs_vects = vect_decls,
hs_valds = val_binds })
= do { -- Type-check the type and class decls, and all imported decls
-- The latter come in via tycl_decls
- traceTc (text "Tc2") ;
+ traceTc "Tc2" empty ;
- tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
+ (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ;
-- If there are any errors, tcTyAndClassDecls fails here
- -- Make these type and class decls available to stuff slurped from interface files
- writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
-
+ setGblEnv tcg_env $
+ tcExtendIdEnv dm_ids $ do {
- setGblEnv tcg_env $ do {
-- Source-language instances, including derivings,
-- and import the supporting declarations
- traceTc (text "Tc3") ;
+ traceTc "Tc3" empty ;
(tcg_env, inst_infos, deriv_binds)
- <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
+ <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls;
setGblEnv tcg_env $ do {
- -- Foreign import declarations next. No zonking necessary
- -- here; we can tuck them straight into the global environment.
- traceTc (text "Tc4") ;
+ -- Foreign import declarations next.
+ traceTc "Tc4" empty ;
(fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
tcExtendGlobalValEnv fi_ids $ do {
-- Default declarations
- traceTc (text "Tc4a") ;
+ traceTc "Tc4a" empty ;
default_tys <- tcDefaults default_decls ;
updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
+ -- Now GHC-generated derived bindings, generics, and selectors
+ -- Do not generate warnings from compiler-generated code;
+ -- hence the use of discardWarnings
+ (tc_aux_binds, specs1, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ;
+ (tc_deriv_binds, specs2, tcl_env) <- setLclTypeEnv tcl_env $
+ discardWarnings (tcTopBinds deriv_binds) ;
+
-- Value declarations next
- -- We also typecheck any extra binds that came out
- -- of the "deriving" process (deriv_binds)
- traceTc (text "Tc5") ;
- (tc_val_binds, tcl_env) <- tcTopBinds val_binds ;
- setLclTypeEnv tcl_env $ do {
-
- -- Now GHC-generated derived bindings and generics.
- -- Do not generate warnings from compiler-generated code.
- (tc_deriv_binds, tcl_env) <- discardWarnings $
- tcTopBinds deriv_binds ;
-
- -- Second pass over class and instance declarations,
- traceTc (text "Tc6") ;
- (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ tcInstDecls2 tycl_decls inst_infos ;
- showLIE (text "after instDecls2") ;
-
- -- Foreign exports
- -- They need to be zonked, so we return them
- traceTc (text "Tc7") ;
- (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
-
- -- Rules
- rules <- tcRules rule_decls ;
+ traceTc "Tc5" empty ;
+ (tc_val_binds, specs3, tcl_env) <- setLclTypeEnv tcl_env $
+ tcTopBinds val_binds;
- -- Wrap up
- traceTc (text "Tc7a") ;
+ setLclTypeEnv tcl_env $ do { -- Environment doesn't change now
+
+ -- Second pass over class and instance declarations,
+ traceTc "Tc6" empty ;
+ inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
+
+ -- Foreign exports
+ traceTc "Tc7" empty ;
+ (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
+
+ -- Annotations
+ annotations <- tcAnnotations annotation_decls ;
+
+ -- Rules
+ rules <- tcRules rule_decls ;
+
+ -- Vectorisation declarations
+ vects <- tcVectDecls vect_decls ;
+
+ -- Wrap up
+ traceTc "Tc7a" empty ;
tcg_env <- getGblEnv ;
let { all_binds = tc_val_binds `unionBags`
tc_deriv_binds `unionBags`
+ tc_aux_binds `unionBags`
inst_binds `unionBags`
- foe_binds ;
-
- -- Extend the GblEnv with the (as yet un-zonked)
- -- bindings, rules, foreign decls
- tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
- tcg_rules = tcg_rules tcg_env ++ rules,
- tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
- return (tcg_env', tcl_env)
+ foe_binds
+
+ ; sig_names = mkNameSet (collectHsValBinders val_binds)
+ `minusNameSet` getTypeSigNames val_binds
+
+ -- Extend the GblEnv with the (as yet un-zonked)
+ -- bindings, rules, foreign decls
+ ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
+ , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++
+ specs3
+ , tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names
+ , tcg_rules = tcg_rules tcg_env ++ rules
+ , tcg_vects = tcg_vects tcg_env ++ vects
+ , tcg_anns = tcg_anns tcg_env ++ annotations
+ , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
+ return (tcg_env', tcl_env)
}}}}}}
\end{code}
check_main dflags tcg_env
}
+check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv
check_main dflags tcg_env
| mod /= main_mod
- = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
+ = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
return tcg_env
| otherwise
- = do { mb_main <- lookupSrcOcc_maybe main_fn
+ = do { mb_main <- lookupGlobalOccRn_maybe main_fn
-- Check that 'main' is in scope
-- It might be imported from another module!
; case mb_main of {
- Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
+ Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
; complain_no_main
; return tcg_env } ;
Just main_name -> do
- { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
+ { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
; let loc = srcLocSpan (getSrcLoc main_name)
; ioTyCon <- tcLookupTyCon ioTyConName
- ; (main_expr, res_ty)
+ ; res_ty <- newFlexiTyVarTy liftedTypeKind
+ ; main_expr
<- addErrCtxt mainCtxt $
- withBox liftedTypeKind $ \res_ty ->
tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
-- See Note [Root-main Id]
(mkTyConApp ioTyCon [res_ty])
; co = mkWpTyApps [res_ty]
; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
- ; main_bind = noLoc (VarBind root_main_id rhs) }
+ ; main_bind = mkVarBind root_main_id rhs }
- ; return (tcg_env { tcg_binds = tcg_binds tcg_env
+ ; return (tcg_env { tcg_main = Just main_name,
+ tcg_binds = tcg_binds tcg_env
`snocBag` main_bind,
tcg_dus = tcg_dus tcg_env
`plusDU` usesOnly (unitFV main_name)
-- Record the use of 'main', so that we don't
-- complain about it being defined but not used
- })
+ })
}}}
where
mod = tcg_mod tcg_env
main_mod = mainModIs dflags
- main_is_flag = mainFunIs dflags
-
- main_fn = case main_is_flag of
- Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
- Nothing -> main_RDR_Unqual
+ main_fn = getMainFun dflags
complain_no_main | ghcLink dflags == LinkInMemory = return ()
| otherwise = failWithTc noMainMsg
mainCtxt = ptext (sLit "When checking the type of the") <+> pp_main_fn
noMainMsg = ptext (sLit "The") <+> pp_main_fn
<+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
- pp_main_fn | isJust main_is_flag = ptext (sLit "main function") <+> quotes (ppr main_fn)
- | otherwise = ptext (sLit "function") <+> quotes (ppr main_fn)
+ pp_main_fn = ppMainFn main_fn
+
+ppMainFn :: RdrName -> SDoc
+ppMainFn main_fn
+ | main_fn == main_RDR_Unqual
+ = ptext (sLit "function") <+> quotes (ppr main_fn)
+ | otherwise
+ = ptext (sLit "main function") <+> quotes (ppr main_fn)
+
+-- | Get the unqualified name of the function to use as the \"main\" for the main module.
+-- Either returns the default name or the one configured on the command line with -main-is
+getMainFun :: DynFlags -> RdrName
+getMainFun dflags = case (mainFunIs dflags) of
+ Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
+ Nothing -> main_RDR_Unqual
+
+checkMainExported :: TcGblEnv -> TcM ()
+checkMainExported tcg_env = do
+ dflags <- getDOpts
+ case tcg_main tcg_env of
+ Nothing -> return () -- not the main module
+ Just main_name -> do
+ let main_mod = mainModIs dflags
+ checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $
+ ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+>
+ ptext (sLit "is not exported by module") <+> quotes (ppr main_mod)
\end{code}
Note [Root-main Id]
%*********************************************************
\begin{code}
-#ifdef GHCI
setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
setInteractiveContext hsc_env icxt thing_inside
= let -- Initialise the tcg_inst_env with instances from all home modules.
-- This mimics the more selective call to hptInstances in tcRnModule.
- (home_insts, home_fam_insts) = hptInstances hsc_env (\mod -> True)
+ (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)
in
updGblEnv (\env -> env {
tcg_rdr_env = ic_rn_gbl_env icxt,
-- later ids in ic_tmp_ids must shadow earlier ones with the same
-- OccName, and tcExtendIdEnv implements this behaviour.
- do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
+ do { traceTc "setIC" (ppr (ic_tmp_ids icxt))
; thing_inside }
\end{code}
\begin{code}
+#ifdef GHCI
tcRnStmt :: HscEnv
-> InteractiveContext
-> LStmt RdrName
- -> IO (Maybe ([Id], LHsExpr Id))
+ -> IO (Messages, Maybe ([Id], LHsExpr Id))
-- The returned [Id] is the list of new Ids bound by
-- this statement. It can be used to extend the
-- InteractiveContext via extendInteractiveContext.
setInteractiveContext hsc_env ictxt $ do {
-- Rename; use CmdLineMode because tcRnStmt is only used interactively
- (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
+ (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ ->
+ return ((), emptyFVs) ;
traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
failIfErrsM ;
rnDump (ppr rn_stmt) ;
-- None of the Ids should be of unboxed type, because we
-- cast them all to HValues in the end!
- mapM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
+ mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
+
+ traceTc "tcs 1" empty ;
+ let { global_ids = map globaliseAndTidyId zonked_ids } ;
+ -- Note [Interactively-bound Ids in GHCi]
- traceTc (text "tcs 1") ;
- let { global_ids = map globaliseAndTidy zonked_ids } ;
-
{- ---------------------------------------------
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.
where
bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"),
nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
-
-globaliseAndTidy :: Id -> Id
-globaliseAndTidy id -- Note [Interactively-bound Ids in GHCi]
- = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
- where
- tidy_type = tidyTopType (idType id)
\end{code}
Note [Interactively-bound Ids in GHCi]
-- The two-step process avoids getting two errors: one from
-- the expression itself, and one from the 'print it' part
-- This two-step story is very clunky, alas
- do { checkNoErrs (tcGhciStmts [let_stmt])
+ do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
--- checkNoErrs defeats the error recovery of let-bindings
; tcGhciStmts [let_stmt, print_it] }
]}
mkPlan stmt@(L loc (BindStmt {}))
- | [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt
+ | [v] <- collectLStmtBinders stmt -- One binder, for a bind stmt
= do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
(HsVar thenIOName) placeHolderType
let {
ret_ty = mkListTy unitTy ;
io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
- tc_io_stmts stmts = tcStmts DoExpr tcDoStmt stmts io_ret_ty ;
+ tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ;
- names = map unLoc (collectLStmtsBinders stmts) ;
+ names = collectLStmtsBinders stmts ;
-- mk_return builds the expression
-- returnIO @ [()] [coerce () x, .., coerce () z]
} ;
-- OK, we're ready to typecheck the stmts
- traceTc (text "TcRnDriver.tcGhciStmts: tc stmts") ;
- ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
+ traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
+ ((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ ->
mapM tcLookupId names ;
-- Look up the names right in the middle,
-- where they will all be in scope
-- Simplify the context
- traceTc (text "TcRnDriver.tcGhciStmts: simplify ctxt") ;
- const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
+ traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
+ const_binds <- checkNoErrs (simplifyInteractive lie) ;
-- checkNoErrs ensures that the plan fails if context redn fails
- traceTc (text "TcRnDriver.tcGhciStmts: done") ;
- return (ids, mkHsDictLet const_binds $
- noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
+ traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+ return (ids, mkHsDictLet (EvBinds const_binds) $
+ noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty))
}
\end{code}
tcRnExpr :: HscEnv
-> InteractiveContext
-> LHsExpr RdrName
- -> IO (Maybe Type)
+ -> IO (Messages, Maybe Type)
tcRnExpr hsc_env ictxt rdr_expr
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env ictxt $ do {
- (rn_expr, fvs) <- rnLExpr rdr_expr ;
+ (rn_expr, _fvs) <- rnLExpr rdr_expr ;
failIfErrsM ;
-- Now typecheck the expression;
-- it might have a rank-2 type (e.g. :t runST)
- ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
- ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
- tcSimplifyInteractive lie_top ;
- let { all_expr_ty = mkForAllTys qtvs $
- mkFunTys (map (idType . instToId) dict_insts) $
- res_ty } ;
+ uniq <- newUnique ;
+ let { fresh_it = itName uniq } ;
+ ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ;
+ ((qtvs, dicts, _), lie_top) <- captureConstraints $
+ simplifyInfer TopLevel
+ False {- No MR for now -}
+ [(fresh_it, res_ty)]
+ lie ;
+
+ _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings
+
+ let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
zonkTcType all_expr_ty
}
- where
- smpl_doc = ptext (sLit "main expression")
\end{code}
tcRnType just finds the kind of a type
tcRnType :: HscEnv
-> InteractiveContext
-> LHsType RdrName
- -> IO (Maybe Kind)
+ -> IO (Messages, Maybe Kind)
tcRnType hsc_env ictxt rdr_type
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env ictxt $ do {
failIfErrsM ;
-- Now kind-check the type
- (ty', kind) <- kcHsType rn_type ;
+ (_ty', kind) <- kcLHsType rn_type ;
return kind
}
where
\begin{code}
#ifdef GHCI
--- ASSUMES that the module is either in the HomePackageTable or is
+-- | ASSUMES that the module is either in the 'HomePackageTable' or is
-- a package module with an interface on disk. If neither of these is
-- true, then the result will be an error indicating the interface
-- could not be found.
getModuleExports hsc_env mod
= let
ic = hsc_IC hsc_env
- checkMods = ic_toplev_scope ic ++ ic_exports ic
+ checkMods = ic_toplev_scope ic ++ map fst (ic_exports ic)
in
initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods)
; ifaceExportNames (mi_exports iface)
}
-tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
+tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name])
tcRnLookupRdrName hsc_env rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env (hsc_IC hsc_env) $
lookup_rdr_name rdr_name
+lookup_rdr_name :: RdrName -> TcM [Name]
lookup_rdr_name rdr_name = do {
-- If the identifier is a constructor (begins with an
-- upper-case letter), then we need to consider both
return good_names
}
+#endif
-tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
+tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
tcRnLookupName hsc_env name
= initTcPrintErrors hsc_env iNTERACTIVE $
setInteractiveContext hsc_env (hsc_IC hsc_env) $
_ -> panic "tcRnLookupName'"
tcRnGetInfo :: HscEnv
- -> Name
- -> IO (Maybe (TyThing, Fixity, [Instance]))
+ -> Name
+ -> IO (Messages, Maybe (TyThing, Fixity, [Instance]))
--- Used to implemnent :info in GHCi
+-- Used to implement :info in GHCi
--
-- Look up a RdrName and return all the TyThings it might be
-- A capitalised RdrName is given to us in the DataName namespace,
-- *and* as a type or class constructor;
-- hence the call to dataTcOccs, and we return up to two results
tcRnGetInfo hsc_env name
- = initTcPrintErrors hsc_env iNTERACTIVE $
- let ictxt = hsc_IC hsc_env in
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ tcRnGetInfo' hsc_env name
+
+tcRnGetInfo' :: HscEnv
+ -> Name
+ -> TcRn (TyThing, Fixity, [Instance])
+tcRnGetInfo' hsc_env name
+ = let ictxt = hsc_IC hsc_env in
setInteractiveContext hsc_env ictxt $ do
-- Load the interface for all unqualified types and classes
; return (classInstances inst_envs cls) }
lookupInsts (ATyCon tc)
- = do { eps <- getEps -- Load all instances for all classes that are
- -- in the type environment (which are all the ones
- -- we've seen in any interface file so far)
- ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
- ; return [ ispec
+ = do { (pkg_ie, home_ie) <- tcGetInstEnvs
+ -- Load all instances for all classes that are
+ -- in the type environment (which are all the ones
+ -- we've seen in any interface file so far)
+ ; return [ ispec -- Search all
| ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
, let dfun = instanceDFunId ispec
, relevant dfun ] }
where
- relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
+ relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df)
tc_name = tyConName tc
-lookupInsts other = return []
+lookupInsts _ = return []
loadUnqualIfaces :: InteractiveContext -> TcM ()
-- Load the home module for everything that is in scope unqualified
isTcOcc (nameOccName name), -- Types and classes only
unQualOK gre ] -- In scope unqualified
doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
-#endif /* GHCI */
\end{code}
%************************************************************************
-- NB: foreign x-d's have undefined's in their types;
-- hence can't show the tc_fords
+tcCoreDump :: ModGuts -> TcM ()
tcCoreDump mod_guts
= do { dflags <- getDOpts ;
when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
-- It's unpleasant having both pprModGuts and pprModDetails here
pprTcGblEnv :: TcGblEnv -> SDoc
pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
- tcg_insts = insts,
- tcg_fam_insts = fam_insts,
- tcg_rules = rules,
- tcg_imports = imports })
+ tcg_insts = insts,
+ tcg_fam_insts = fam_insts,
+ tcg_rules = rules,
+ tcg_vects = vects,
+ tcg_imports = imports })
= vcat [ ppr_types insts type_env
, ppr_tycons fam_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))
- , ptext (sLit "Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
+ , ppr_insts insts
+ , ppr_fam_insts fam_insts
+ , vcat (map ppr rules)
+ , vcat (map ppr vects)
+ , ppr_gen_tycons (typeEnvTyCons type_env)
+ , ptext (sLit "Dependent modules:") <+>
+ ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
+ , ptext (sLit "Dependent packages:") <+>
+ ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
+ where -- The two uses of sortBy are just to reduce unnecessary
+ -- wobbling in testsuite output
+ cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
+ = (mod_name1 `stableModuleNameCmp` mod_name2)
+ `thenCmp`
+ (is_boot1 `compare` is_boot2)
pprModGuts :: ModGuts -> SDoc
pprModGuts (ModGuts { mg_types = type_env,
where
le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
ppr_tycon tycon
- | isCoercionTyCon tycon = ptext (sLit "coercion") <+> ppr tycon
+ | isCoercionTyCon tycon
+ = sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs
+ , nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))]
| otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon))
+ where
+ tvs = take (tyConArity tycon) alphaTyVars
ppr_rules :: [CoreRule] -> SDoc
ppr_rules [] = empty
ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
- nest 4 (pprRules rs),
+ nest 2 (pprRules rs),
ptext (sLit "#-}")]
+ppr_gen_tycons :: [TyCon] -> SDoc
ppr_gen_tycons [] = empty
ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"),
nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]