+typecheckIface
+ :: DynFlags
+ -> PersistentCompilerState
+ -> HomeSymbolTable
+ -> ModIface -- Iface for this module (just module & fixities)
+ -> [RenamedHsDecl]
+ -> IO (Maybe (PersistentCompilerState, ModDetails))
+ -- The new PCS is Augmented with imported information,
+ -- (but not stuff from this module).
+
+typecheckIface dflags pcs hst mod_iface decls
+ = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
+ tcIface pcs this_mod decls
+ ; printIfaceDump dflags maybe_tc_stuff
+ ; return maybe_tc_stuff }
+ where
+ this_mod = mi_module mod_iface
+
+tcIface pcs this_mod decls
+-- The decls are coming from this_mod's interface file, together
+-- with imported interface decls that belong in the "package" stuff.
+-- (With GHCi, all the home modules have already been processed.)
+-- That is why we need to do the partitioning below.
+ = tcIfaceImports this_mod decls `thenTc` \ (_, all_things, dfuns, rules) ->
+
+ let
+ -- Do the partitioning (see notes above)
+ (local_things, imported_things) = partition (isLocalThing this_mod) all_things
+ (local_rules, imported_rules) = partition is_local_rule rules
+ (local_dfuns, imported_dfuns) = partition (isLocalThing this_mod) dfuns
+ is_local_rule (IfaceRuleOut n _) = isLocalThing this_mod n
+ in
+ addInstDFuns (pcs_insts pcs) imported_dfuns `thenNF_Tc` \ new_pcs_insts ->
+ let
+ new_pcs_pte :: PackageTypeEnv
+ new_pcs_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
+ new_pcs_rules = addIfaceRules (pcs_rules pcs) imported_rules
+
+ new_pcs :: PersistentCompilerState
+ new_pcs = pcs { pcs_PTE = new_pcs_pte,
+ pcs_insts = new_pcs_insts,
+ pcs_rules = new_pcs_rules
+ }
+
+ mod_details = ModDetails { md_types = mkTypeEnv local_things,
+ md_insts = local_dfuns,
+ md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules],
+ md_binds = [] }
+ -- All the rules from an interface are of the IfaceRuleOut form
+ in
+ returnTc (new_pcs, mod_details)
+
+
+tcIfaceImports :: Module
+ -> [RenamedHsDecl] -- All interface-file decls
+ -> TcM (TcEnv, [TyThing], [DFunId], [TypecheckedRuleDecl])
+tcIfaceImports this_mod decls
+-- The decls are all interface-file declarations
+ = let
+ inst_decls = [d | InstD d <- decls]
+ tycl_decls = [d | TyClD d <- decls]
+ rule_decls = [d | RuleD d <- decls]
+ in
+ fixTc (\ ~(unf_env, _, _, _) ->
+ -- This fixTc follows the same general plan as tcImports,
+ -- which is better commented (below)
+ tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
+ tcExtendGlobalEnv tycl_things $
+ tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids $
+ tcIfaceInstDecls1 inst_decls `thenTc` \ dfuns ->
+ tcIfaceRules rule_decls `thenTc` \ rules ->
+ tcGetEnv `thenTc` \ env ->
+ let
+ all_things = map AnId sig_ids ++ tycl_things
+ in
+ returnTc (env, all_things, dfuns, rules)
+ )
+
+
+tcImports :: RecTcEnv
+ -> PersistentCompilerState
+ -> HomeSymbolTable
+ -> Module
+ -> [RenamedTyClDecl]
+ -> [RenamedInstDecl]
+ -> [RenamedRuleDecl]
+ -> TcM (TcEnv, PersistentCompilerState)
+
+-- tcImports is a slight mis-nomer.
+-- It deals with everything that could be an import:
+-- type and class decls (some source, some imported)
+-- interface signatures (checked lazily)
+-- instance decls (some source, some imported)
+-- rule decls (all imported)
+-- These can occur in source code too, of course
+--
+-- tcImports is only called when processing source code,
+-- so that any interface-file declarations are for other modules, not this one
+
+tcImports unf_env pcs hst this_mod
+ tycl_decls inst_decls rule_decls
+ -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
+ -- which is done lazily [ie failure just drops the pragma
+ -- without having any global-failure effect].
+ --
+ -- unf_env is also used to get the pragama info
+ -- for imported dfuns and default methods
+
+ = checkNoErrsTc $
+ -- tcImports recovers internally, but if anything gave rise to
+ -- an error we'd better stop now, to avoid a cascade
+
+ traceTc (text "Tc1") `thenNF_Tc_`
+ tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
+ tcExtendGlobalEnv tycl_things $
+
+ -- Interface type signatures
+ -- We tie a knot so that the Ids read out of interfaces are in scope
+ -- when we read their pragmas.
+ -- What we rely on is that pragmas are typechecked lazily; if
+ -- any type errors are found (ie there's an inconsistency)
+ -- we silently discard the pragma
+ traceTc (text "Tc2") `thenNF_Tc_`
+ tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids $
+
+ -- Typecheck the instance decls, includes deriving
+ -- Note that imported dictionary functions are already
+ -- in scope from the preceding tcInterfaceSigs
+ traceTc (text "Tc3") `thenNF_Tc_`
+ tcIfaceInstDecls1 inst_decls `thenTc` \ dfuns ->
+ tcIfaceRules rule_decls `thenNF_Tc` \ rules ->
+
+ addInstDFuns (pcs_insts pcs) dfuns `thenNF_Tc` \ new_pcs_insts ->
+ tcGetEnv `thenTc` \ unf_env ->
+ let
+ -- sometimes we're compiling in the context of a package module
+ -- (on the GHCi command line, for example). In this case, we
+ -- want to treat everything we pulled in as an imported thing.
+ imported_things = map AnId sig_ids ++ -- All imported
+ filter (not . isLocalThing this_mod) tycl_things
+
+ new_pte :: PackageTypeEnv
+ new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
+
+ new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
+
+ new_pcs :: PersistentCompilerState
+ new_pcs = pcs { pcs_PTE = new_pte,
+ pcs_insts = new_pcs_insts,
+ pcs_rules = new_pcs_rules
+ }
+ in
+ returnTc (unf_env, new_pcs)
+
+isSourceRuleDecl :: Module -> RenamedRuleDecl -> Bool
+-- This is a bit gruesome.
+-- Usually, HsRules come only from source files; IfaceRules only from interface files
+-- But built-in rules appear as an IfaceRuleOut... and when compiling
+-- the source file for that built-in rule, we want to treat it as a source
+-- rule, so it gets put with the other rules for that module.
+isSourceRuleDecl this_mod (HsRule _ _ _ _ _ _) = True
+isSourceRuleDecl this_mod (IfaceRule _ _ _ n _ _ _) = False
+isSourceRuleDecl this_mod (IfaceRuleOut name _) = isLocalThing this_mod name
+
+addIfaceRules rule_base rules
+ = foldl add_rule rule_base rules
+ where
+ add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
+\end{code}
+
+\begin{code}
+typecheckCoreModule
+ :: DynFlags
+ -> PersistentCompilerState
+ -> HomeSymbolTable
+ -> ModIface -- Iface for this module (just module & fixities)
+ -> [RenamedHsDecl]
+ -> IO (Maybe (PersistentCompilerState, (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])))
+typecheckCoreModule dflags pcs hst mod_iface decls
+ = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
+ tcCoreDecls this_mod decls
+
+-- ; printIfaceDump dflags maybe_tc_stuff
+
+ -- Q: Is it OK not to extend PCS here?
+ -- (in the event that it needs to be, I'm returning the PCS passed in.)
+ ; case maybe_tc_stuff of
+ Nothing -> return Nothing
+ Just result -> return (Just (pcs, result)) }
+ where
+ this_mod = mi_module mod_iface
+ core_decls = [d | (TyClD d) <- decls, isCoreDecl d]
+
+
+tcCoreDecls :: Module
+ -> [RenamedHsDecl] -- All interface-file decls
+ -> TcM (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl])
+tcCoreDecls this_mod decls
+-- The decls are all TyClD declarations coming from External Core input.
+ = let
+ tycl_decls = [d | TyClD d <- decls]
+ rule_decls = [d | RuleD d <- decls]
+ core_decls = filter isCoreDecl tycl_decls
+ in
+ fixTc (\ ~(unf_env, _) ->
+ -- This fixTc follows the same general plan as tcImports,
+ -- which is better commented.
+ -- [ Q: do we need to tie a knot for External Core? ]
+ tcTyAndClassDecls this_mod tycl_decls `thenTc` \ tycl_things ->
+ tcExtendGlobalEnv tycl_things $
+
+ tcInterfaceSigs unf_env this_mod tycl_decls `thenTc` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids $
+
+ tcCoreBinds core_decls `thenTc` \ core_prs ->
+ let
+ local_ids = map fst core_prs
+ in
+ tcExtendGlobalValEnv local_ids $
+
+ tcIfaceRules rule_decls `thenTc` \ rules ->
+
+ let
+ src_things = filter (isLocalThing this_mod) tycl_things
+ ++ map AnId local_ids
+ in
+ tcGetEnv `thenNF_Tc` \ env ->
+ returnTc (env, (mkTypeEnv src_things, core_prs, rules))
+ ) `thenTc` \ (_, result) ->
+ returnTc result