}}}
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
-tcIfaceTyCon IfaceIntTc = return intTyCon
+tcIfaceTyCon IfaceIntTc = return intTyCon
tcIfaceTyCon IfaceBoolTc = return boolTyCon
tcIfaceTyCon IfaceCharTc = return charTyCon
tcIfaceTyCon IfaceListTc = return listTyCon
%* *
%************************************************************************
-IfaceDecls etc are populated with RdrNames. The RdrNames may either be
-
- Orig or Unqual when the interface is read from a file
-
- Exact when the interface is kept by GHCi, and is now
- being re-linked with the type environment
-
-At an occurrence site, to convert the RdrName to Name:
- Unqual look up in LocalRdrEnv
- Orig look up in OrigNameCache
- Exact return the Name
-
-At a binding site, to bind the RdrName
- Unqual we extend the LocalRdrEnv
- Orig or Unqual we don't extend the LocalRdrEnv (no need)
-
-First, we deal with the RdrName -> Name mapping
-
\begin{code}
lookupIfaceTc :: IfaceTyCon -> IfL Name
lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext
DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
import InstEnv ( extendInstEnv )
import CoreSyn
+import PprType ( pprClassPred )
import PprCore ( pprIdRules )
import Rules ( extendRuleBaseList )
import CoreUtils ( exprType )
import UniqSupply ( initUs_ )
import Outputable
import SrcLoc ( noSrcLoc )
-import Util ( zipWithEqual, dropList, equalLength )
+import Util ( zipWithEqual, dropList, equalLength, zipLazy )
import Maybes ( expectJust )
import CmdLineOpts ( DynFlag(..) )
\end{code}
%************************************************************************
%* *
- Other interfaces
+ Type-checking a complete interface
%* *
%************************************************************************
+Suppose we discover we don't need to recompile. Then we must type
+check the old interface file. This is a bit different to the
+incremental type checking we do as we suck in interface files. Instead
+we do things similarly as when we are typechecking source decls: we
+bring into scope the type envt for the interface all at once, using a
+knot. Remember, the decls aren't necessarily in dependency order --
+and even if they were, the type decls might be mutually recursive.
+
\begin{code}
-typecheckIface :: ModIface -> IfG ModDetails
--- Used when we decide not to recompile, but intead to use the
--- interface to construct the type environment for the module
-typecheckIface iface
- = initIfaceLcl (moduleName (mi_module iface)) $
- do { ty_things <- mapM (tcIfaceDecl . snd) (mi_decls iface)
- ; rules <- mapM tcIfaceRule (mi_rules iface)
+typecheckIface :: HscEnv
+ -> ModIface -- Get the decls from here
+ -> IO ModDetails
+typecheckIface hsc_env iface@(ModIface { mi_module = mod, mi_decls = ver_decls,
+ mi_rules = rules, mi_insts = dfuns })
+ = initIfaceTc hsc_env iface $ \ tc_env_var -> do
+ { -- Typecheck the decls
+ names <- mappM (lookupOrig (moduleName mod) . ifName) decls
+ ; ty_things <- fixM (\ rec_ty_things -> do
+ { writeMutVar tc_env_var (mkNameEnv (names `zipLazy` rec_ty_things))
+ -- This only makes available the "main" things,
+ -- but that's enough for the strictly-checked part
+ ; mapM tcIfaceDecl decls })
+
+ -- Now augment the type envt with all the implicit things
+ -- These will be needed when type-checking the unfoldings for
+ -- the IfaceIds, but this is done lazily, so writing the thing
+ -- now is sufficient
+ ; let { add_implicits main_thing = main_thing : implicitTyThings main_thing
+ ; type_env = mkTypeEnv (concatMap add_implicits ty_things) }
+ ; writeMutVar tc_env_var type_env
+
+ -- Now do those rules and instances
; dfuns <- mapM tcIfaceInst (mi_insts iface)
- ; return (ModDetails { md_types = mkTypeEnv ty_things,
- md_insts = dfuns,
- md_rules = rules }) }
+ ; rules <- mapM tcIfaceRule (mi_rules iface)
+
+ -- Finished
+ ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules })
+ }
+ where
+ decls = map snd ver_decls
\end{code}
else do
{ writeMutVar eps_var (eps {eps_insts = inst_pool'})
+ ; traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys,
+ nest 2 (vcat (map ppr iface_insts))])
+
-- Typecheck the new instances
; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts)
import Parser
import Lexer ( P(..), ParseResult(..), mkPState, showPFailed )
import SrcLoc ( mkSrcLoc )
-import TcRnDriver ( tcRnModule, tcRnExtCore, tcRnIface )
+import TcRnDriver ( tcRnModule, tcRnExtCore )
+import TcIface ( typecheckIface )
import IfaceEnv ( initNameCache )
import LoadIface ( ifaceStats, initExternalPackageState )
import PrelInfo ( wiredInThings, basicKnownKeyNames )
showModMsg have_object mod location);
new_details <- _scc_ "tcRnIface"
- tcRnIface hsc_env old_iface ;
+ typecheckIface hsc_env old_iface ;
dumpIfaceStats hsc_env ;
return (HscNoRecomp new_details old_iface)
#endif
tcRnModule,
tcTopSrcDecls,
- tcRnIface, tcRnExtCore
+ tcRnExtCore
) where
#include "HsVersions.h"
import TcRules ( tcRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcIface ( typecheckIface, tcExtCoreBindings )
+import TcIface ( tcExtCoreBindings )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules )
\end{code}
-%*********************************************************
-%* *
-\subsection{Closing up the interface decls}
-%* *
-%*********************************************************
-
-Suppose we discover we don't need to recompile. Then we start from the
-IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
-
-\begin{code}
-tcRnIface :: HscEnv
- -> ModIface -- Get the decls from here
- -> IO ModDetails
-tcRnIface hsc_env iface
- = initIfaceTc hsc_env iface (typecheckIface iface)
-\end{code}
-
-
%************************************************************************
%* *
The interactive interface
import HsSyn ( MonoBinds(..) )
import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
- TyThing, Dependencies(..),
+ TyThing, Dependencies(..), TypeEnv, emptyTypeEnv,
ExternalPackageState(..), HomePackageTable,
ModDetails(..), HomeModInfo(..),
Deprecs(..), FixityEnv, FixItem,
; initTcRnIf 'i' hsc_env gbl_env () do_this
}
-initIfaceTc :: HscEnv -> ModIface -> IfG a -> IO a
+initIfaceTc :: HscEnv -> ModIface
+ -> (TcRef TypeEnv -> IfL a) -> IO a
-- Used when type-checking checking an up-to-date interface file
-- No type envt from the current module, but we do know the module dependencies
initIfaceTc hsc_env iface do_this
- = do { let { gbl_env = IfGblEnv { if_is_boot = mkModDeps (dep_mods (mi_deps iface)),
- if_rec_types = Nothing } ;
+ = do { tc_env_var <- newIORef emptyTypeEnv
+ ; let { gbl_env = IfGblEnv { if_is_boot = mkModDeps (dep_mods (mi_deps iface)),
+ if_rec_types = Just (mod, readMutVar tc_env_var) } ;
+ ; if_lenv = IfLclEnv { if_mod = moduleName mod,
+ if_tv_env = emptyOccEnv,
+ if_id_env = emptyOccEnv }
}
- ; initTcRnIf 'i' hsc_env gbl_env () do_this
+ ; initTcRnIf 'i' hsc_env gbl_env if_lenv (do_this tc_env_var)
}
+ where
+ mod = mi_module iface
initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a
-- Used when sucking in new Rules in SimplCore
= tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl)
tcTyClDecl1 calc_vrcs calc_isrec
- (TySynonym {tcdName = tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
+ (TySynonym {tcdName = tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
= tcTyVarBndrs tvs $ \ tvs' -> do
{ rhs_ty' <- tcHsKindedType rhs_ty
; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' arg_vrcs)) }
arg_vrcs = calc_vrcs tc_name
tcTyClDecl1 calc_vrcs calc_isrec
- (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
- tcdName = tc_name, tcdCons = cons})
+ (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
+ tcdName = tc_name, tcdCons = cons})
= tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
; want_generic <- doptM Opt_Generics
is_rec = calc_isrec tc_name
tcTyClDecl1 calc_vrcs calc_isrec
- (ClassDecl {tcdName = class_name, tcdTyVars = tvs,
- tcdCtxt = ctxt, tcdMeths = meths,
- tcdFDs = fundeps, tcdSigs = sigs} )
+ (ClassDecl {tcdName = class_name, tcdTyVars = tvs,
+ tcdCtxt = ctxt, tcdMeths = meths,
+ tcdFDs = fundeps, tcdSigs = sigs} )
= tcTyVarBndrs tvs $ \ tvs' -> do
{ ctxt' <- tcHsKindedContext ctxt
; fds' <- mappM tc_fundep fundeps
tcTyClDecl1 calc_vrcs calc_isrec
- (ForeignType {tcdName = tc_name, tcdExtName = tc_ext_name})
+ (ForeignType {tcdName = tc_name, tcdExtName = tc_ext_name})
= returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 []))
-----------------------------------
projects / ghc-hetmet.git / commitdiff