Commit dd214d28 authored by simonpj's avatar simonpj

[project @ 2002-01-30 17:16:36 by simonpj]

-----------------------------
	Tidy up the top level of TcModule
	-----------------------------

This commit started life as sorting out the TcInstDcls thing that
we got wrong a few weeks back, but it spiraled out of control.

However, the result is a nice tidy up of TcModule.

typecheckModule/tcModule compiles a module from source code
typecheckIface/tcIface   compiles a module from its interface file
typecheckStmt		 compiles a Stmt
typecheckExpr		 compiles a Expr

tcExtraDecls is used by typecheckStmt/typecheckExpr
	to compile interface-file decls.
	It is just a wrapper for:

tcIfaceImports, which is used by tcExtraDecls and tcIface
	to compile interface file-file decls.

tcImports, is similar to tcIfaceImports, but is used only by tcModule

tcIfaceImports is used when compiling an interface, and can
	therefore be quite a bit simpler
parent 605fd82f
......@@ -17,7 +17,7 @@ module HsDecls (
hsDeclName, instDeclName,
tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
mkClassDeclSysNames, isIfaceRuleDecl, isIfaceInstDecl, ifaceRuleDeclName,
mkClassDeclSysNames, isSourceInstDecl, ifaceRuleDeclName,
getClassDeclSysNames, conDetailsTys,
collectRuleBndrSigTys
) where
......@@ -47,7 +47,7 @@ import Util ( eqListBy, count )
import SrcLoc ( SrcLoc )
import FastString
import Maybe ( isNothing, isJust, fromJust )
import Maybe ( isNothing, fromJust )
\end{code}
......@@ -660,8 +660,8 @@ data InstDecl name pat
SrcLoc
isIfaceInstDecl :: InstDecl name pat -> Bool
isIfaceInstDecl (InstDecl _ _ _ maybe_dfun _) = isJust maybe_dfun
isSourceInstDecl :: InstDecl name pat -> Bool
isSourceInstDecl (InstDecl _ _ _ maybe_dfun _) = isNothing maybe_dfun
\end{code}
\begin{code}
......@@ -788,10 +788,6 @@ data RuleDecl name pat
name -- Head of LHS
CoreRule
isIfaceRuleDecl :: RuleDecl name pat -> Bool
isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False
isIfaceRuleDecl other = True
ifaceRuleDeclName :: RuleDecl name pat -> name
ifaceRuleDeclName (IfaceRule _ _ _ n _ _ _) = n
ifaceRuleDeclName (IfaceRuleOut n r) = n
......
......@@ -102,9 +102,8 @@ Death to "ExpandingDicts".
\begin{code}
tcClassDecl1 :: RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
tcClassDecl1 rec_env
(ClassDecl {tcdCtxt = context, tcdName = class_name,
tcClassDecl1 :: RenamedTyClDecl -> TcM (Name, TyThingDetails)
tcClassDecl1 (ClassDecl {tcdCtxt = context, tcdName = class_name,
tcdTyVars = tyvar_names, tcdFDs = fundeps,
tcdSigs = class_sigs, tcdMeths = def_methods,
tcdSysNames = sys_names, tcdLoc = src_loc})
......@@ -125,10 +124,10 @@ tcClassDecl1 rec_env
-- only the type variable of the class decl.
-- Context is already kind-checked
ASSERT( equalLength context sc_sel_names )
tcHsTheta context `thenTc` \ sc_theta ->
tcHsTheta context `thenTc` \ sc_theta ->
-- CHECK THE CLASS SIGNATURES,
mapTc (tcClassSig rec_env clas tyvars mb_dm_env) op_sigs `thenTc` \ sig_stuff ->
mapTc (tcClassSig clas tyvars mb_dm_env) op_sigs `thenTc` \ sig_stuff ->
-- MAKE THE CLASS DETAILS
let
......@@ -200,8 +199,7 @@ checkDefaultBinds clas ops (Just mbs)
\begin{code}
tcClassSig :: RecTcEnv -- Knot tying only!
-> Class -- ...ditto...
tcClassSig :: Class -- ...ditto...
-> [TyVar] -- The class type variable, used for error check only
-> Maybe (NameEnv Bool) -- Info about default methods;
-- Nothing => imported class defn with no method binds
......@@ -214,7 +212,7 @@ tcClassSig :: RecTcEnv -- Knot tying only!
-- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
-- Class.DefMeth data structure.
tcClassSig unf_env clas clas_tyvars maybe_dm_env
tcClassSig clas clas_tyvars maybe_dm_env
(ClassOpSig op_name sig_dm op_ty src_loc)
= tcAddSrcLoc src_loc $
......
......@@ -4,7 +4,8 @@
\section[TcInstDecls]{Typechecking instance declarations}
\begin{code}
module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
module TcInstDcls ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns,
tcInstDecls2, tcAddDeclCtxt ) where
#include "HsVersions.h"
......@@ -14,7 +15,7 @@ import CmdLineOpts ( DynFlag(..) )
import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..),
MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), HsTyVarBndr(..),
andMonoBindList, collectMonoBinders,
isClassDecl, isIfaceInstDecl, toHsType
isClassDecl, toHsType
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl,
RenamedMonoBinds, RenamedTyClDecl, RenamedHsType,
......@@ -43,8 +44,8 @@ import PprType ( pprClassPred )
import TcMonoType ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType )
import TcUnify ( checkSigTyVars )
import TcSimplify ( tcSimplifyCheck )
import HscTypes ( HomeSymbolTable, DFunId,
ModDetails(..), PackageInstEnv, PersistentRenamerState
import HscTypes ( HomeSymbolTable, DFunId, PersistentCompilerState(..),
ModDetails(..), PackageInstEnv
)
import Subst ( substTy, substTheta )
import DataCon ( classDataCon )
......@@ -158,33 +159,31 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
Gather up the instance declarations from their various sources
\begin{code}
tcInstDecls1
:: PackageInstEnv
-> PersistentRenamerState
tcInstDecls1 -- Deal with source-code instance decls
:: PersistentCompilerState
-> HomeSymbolTable -- Contains instances
-> TcEnv -- Contains IdInfo for dfun ids
-> (Name -> Maybe Fixity) -- for deriving Show and Read
-> Module -- Module for deriving
-> [RenamedHsDecl]
-> TcM (PackageInstEnv, -- cached package inst env
InstEnv, -- the full inst env
[InstInfo], -- instance decls to process
[DFunId], -- instances from this module, for its iface
-> [RenamedTyClDecl] -- For deriving stuff
-> [RenamedInstDecl] -- Source code instance decls
-> TcM (InstEnv, -- the full inst env
[InstInfo], -- instance decls to process; contains all dfuns
-- for this module
RenamedHsBinds) -- derived instances
tcInstDecls1 inst_env0 prs hst unf_env get_fixity this_mod decls
tcInstDecls1 pcs hst unf_env get_fixity
this_mod tycl_decls inst_decls
= let
inst_decls = [inst_decl | InstD inst_decl <- decls]
tycl_decls = [decl | TyClD decl <- decls]
pkg_inst_env = pcs_insts pcs
prs = pcs_PRS pcs
clas_decls = filter isClassDecl tycl_decls
(iface_inst_ds, local_inst_ds) = partition isIfaceInstDecl inst_decls
in
-- (1) Do the ordinary instance declarations
mapNF_Tc tcLocalInstDecl1 local_inst_ds `thenNF_Tc` \ local_inst_infos ->
mapNF_Tc tcImportedInstDecl1 iface_inst_ds `thenNF_Tc` \ iface_dfuns ->
mapNF_Tc tcLocalInstDecl1 inst_decls `thenNF_Tc` \ local_inst_infos ->
-- (2) Instances from generic class declarations
getGenericInstances clas_decls `thenTc` \ generic_inst_info ->
getGenericInstances clas_decls `thenTc` \ generic_inst_info ->
-- Next, construct the instance environment so far, consisting of
-- a) cached non-home-package InstEnv (gotten from pcs) inst_env0
......@@ -208,33 +207,26 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity this_mod decls
-- the compilation manager.
let
local_inst_info = catMaybes local_inst_infos
(local_iface_dfuns, pkg_iface_dfuns)
= partition (isLocalThing this_mod) iface_dfuns
hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst
in
-- pprTrace "tcInstDecls" (vcat [ppr imported_dfuns, ppr hst_dfuns]) $
addInstDFuns inst_env0 pkg_iface_dfuns `thenNF_Tc` \ inst_env1 ->
addInstDFuns inst_env1 hst_dfuns `thenNF_Tc` \ inst_env2 ->
addInstDFuns inst_env2 local_iface_dfuns `thenNF_Tc` \ inst_env3 ->
addInstInfos inst_env3 local_inst_info `thenNF_Tc` \ inst_env4 ->
addInstInfos inst_env4 generic_inst_info `thenNF_Tc` \ inst_env5 ->
addInstDFuns pkg_inst_env hst_dfuns `thenNF_Tc` \ inst_env2 ->
addInstInfos inst_env2 local_inst_info `thenNF_Tc` \ inst_env3 ->
addInstInfos inst_env3 generic_inst_info `thenNF_Tc` \ inst_env4 ->
-- (3) Compute instances from "deriving" clauses;
-- note that we only do derivings for things in this module;
-- we ignore deriving decls from interfaces!
-- This stuff computes a context for the derived instance decl, so it
-- needs to know about all the instances possible; hence inst_env5
tcDeriving prs this_mod inst_env5 get_fixity tycl_decls
`thenTc` \ (deriv_inst_info, deriv_binds) ->
addInstInfos inst_env5 deriv_inst_info `thenNF_Tc` \ final_inst_env ->
let inst_info = generic_inst_info ++ deriv_inst_info ++ local_inst_info in
returnTc (inst_env1,
final_inst_env,
inst_info,
local_iface_dfuns ++ map iDFunId inst_info,
-- needs to know about all the instances possible; hence inst_env4
tcDeriving prs this_mod inst_env4
get_fixity tycl_decls `thenTc` \ (deriv_inst_info, deriv_binds) ->
addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env ->
returnTc (final_inst_env,
generic_inst_info ++ deriv_inst_info ++ local_inst_info,
deriv_binds)
addInstInfos :: InstEnv -> [InstInfo] -> NF_TcM InstEnv
......@@ -254,12 +246,15 @@ addInstDFuns inst_env dfuns
\end{code}
\begin{code}
tcImportedInstDecl1 :: RenamedInstDecl -> NF_TcM DFunId
tcIfaceInstDecls1 :: [RenamedInstDecl] -> NF_TcM [DFunId]
tcIfaceInstDecls1 decls = mapNF_Tc tcIfaceInstDecl1 decls
tcIfaceInstDecl1 :: RenamedInstDecl -> NF_TcM DFunId
-- An interface-file instance declaration
-- Should be in scope by now, because we should
-- have sucked in its interface-file definition
-- So it will be replete with its unfolding etc
tcImportedInstDecl1 decl@(InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
tcIfaceInstDecl1 decl@(InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
= tcLookupId dfun_name
......
......@@ -15,7 +15,7 @@ module TcModule (
import CmdLineOpts ( DynFlag(..), DynFlags, dopt )
import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
isIfaceRuleDecl, nullBinds, mkSimpleMatch, placeHolderType
isSourceInstDecl, nullBinds, mkSimpleMatch, placeHolderType
)
import PrelNames ( mAIN_Name, mainName, ioTyConName, printName,
returnIOName, bindIOName, failIOName,
......@@ -23,7 +23,7 @@ import PrelNames ( mAIN_Name, mainName, ioTyConName, printName,
)
import MkId ( unsafeCoerceId )
import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedStmt,
RenamedHsExpr )
RenamedHsExpr, RenamedRuleDecl, RenamedTyClDecl, RenamedInstDecl )
import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr,
TypecheckedForeignDecl, TypecheckedRuleDecl,
zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
......@@ -45,13 +45,14 @@ import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults, defaultDefaultTys )
import TcEnv ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookup_maybe,
isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
tcExtendGlobalTypeEnv, tcLookupGlobalId, tcLookupTyCon,
TcTyThing(..), tcLookupId
tcExtendGlobalEnv, tcExtendGlobalTypeEnv,
tcLookupGlobalId, tcLookupTyCon,
TcTyThing(..), TyThing(..), tcLookupId
)
import TcRules ( tcIfaceRules, tcSourceRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns, tcInstDecls2 )
import TcUnify ( unifyTauTy )
import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
import TcTyClsDecls ( tcTyAndClassDecls )
......@@ -59,6 +60,7 @@ import CoreUnfold ( unfoldingTemplate )
import TysWiredIn ( mkListTy, unitTy )
import ErrUtils ( printErrorsAndWarnings, errorsFound,
dumpIfSet_dyn, dumpIfSet_dyn_or, showPass )
import Rules ( extendRuleBase )
import Id ( Id, idType, idUnfolding )
import Module ( Module, moduleName )
import Name ( Name )
......@@ -74,6 +76,7 @@ import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
TypeEnv, extendTypeEnvList, typeEnvTyCons, typeEnvElts,
mkTypeEnv
)
import List ( partition )
\end{code}
......@@ -108,7 +111,7 @@ typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (stmt, iface_decl
tcSetDefaultTys defaultDefaultTys $
-- Typecheck the extra declarations
tcExtraDecls pcs hst get_fixity this_mod iface_decls `thenTc` \ (new_pcs, env) ->
tcExtraDecls pcs this_mod iface_decls `thenTc` \ (new_pcs, env) ->
tcSetEnv env $
tcExtendGlobalTypeEnv ic_type_env $
......@@ -124,10 +127,6 @@ typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (stmt, iface_decl
ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
returnTc (new_pcs, zonked_expr, zonked_ids, error "typecheckStmt: no type")
where
get_fixity :: Name -> Maybe Fixity
get_fixity n = pprPanic "typecheckStmt" (ppr n)
\end{code}
Here is the grand plan, implemented in tcUserStmt
......@@ -246,7 +245,7 @@ typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls)
tcSetDefaultTys defaultDefaultTys $
-- Typecheck the extra declarations
tcExtraDecls pcs hst get_fixity this_mod decls `thenTc` \ (new_pcs, env) ->
tcExtraDecls pcs this_mod decls `thenTc` \ (new_pcs, env) ->
-- Now typecheck the expression
tcSetEnv env $
......@@ -276,9 +275,6 @@ typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls)
returnTc (new_pcs, zonked_expr, [], zonked_ty)
where
get_fixity :: Name -> Maybe Fixity
get_fixity n = pprPanic "typecheckExpr" (ppr n)
smpl_doc = ptext SLIT("main expression")
\end{code}
......@@ -298,24 +294,35 @@ typecheckExtraDecls
-> [RenamedHsDecl] -- extra decls sucked in from interface files
-> IO (Maybe PersistentCompilerState)
typecheckExtraDecls dflags pcs hst unqual this_mod decls
typecheckExtraDecls dflags pcs hst unqual this_mod decls
= typecheck dflags pcs hst unqual $
tcExtraDecls pcs hst get_fixity this_mod decls
`thenTc` \ (new_pcs, env) ->
returnTc new_pcs
where
get_fixity n = pprPanic "typecheckExpr" (ppr n)
tcExtraDecls pcs hst get_fixity this_mod decls =
fixTc (\ ~(unf_env, _, _, _, _, _) ->
tcImports unf_env pcs hst get_fixity this_mod decls
) `thenTc` \ (env, new_pcs, local_inst_info, local_inst_dfuns,
deriv_binds, local_rules) ->
ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules
&& null local_inst_dfuns )
returnTc (new_pcs, env)
tcExtraDecls pcs this_mod decls `thenTc` \ (new_pcs, _) ->
returnTc new_pcs
tcExtraDecls :: PersistentCompilerState
-> Module
-> [RenamedHsDecl]
-> TcM (PersistentCompilerState, TcEnv)
tcExtraDecls pcs this_mod decls
= tcIfaceImports this_mod decls `thenTc` \ (env, all_things, dfuns, rules) ->
addInstDFuns (pcs_insts pcs) dfuns `thenNF_Tc` \ new_pcs_insts ->
let
new_pcs_pte = extendTypeEnvList (pcs_PTE pcs) all_things
new_pcs_rules = addIfaceRules (pcs_rules pcs) rules
new_pcs :: PersistentCompilerState
new_pcs = pcs { pcs_PTE = new_pcs_pte,
pcs_insts = new_pcs_insts,
pcs_rules = new_pcs_rules
}
in
-- Add the new instances
tcSetEnv env (tcSetInstEnv new_pcs_insts tcGetEnv) `thenNF_Tc` \ new_env ->
returnTc (new_pcs, new_env)
\end{code}
%************************************************************************
%* *
\subsection{Typechecking a module}
......@@ -373,10 +380,16 @@ tcModule pcs hst get_fixity this_mod decls
-- in this module, which is why the knot is so big
-- Type-check the type and class decls, and all imported decls
tcImports unf_env pcs hst get_fixity this_mod decls
`thenTc` \ (env, new_pcs, local_inst_info, local_inst_dfuns, deriv_binds, local_rules) ->
tcImports unf_env pcs hst get_fixity this_mod
tycl_decls iface_inst_decls iface_rule_decls `thenTc` \ (env1, new_pcs) ->
tcSetEnv env1 $
tcSetEnv env $
-- Do the source-language instances, including derivings
tcInstDecls1 new_pcs hst unf_env
get_fixity this_mod
tycl_decls src_inst_decls `thenTc` \ (inst_env, inst_info, deriv_binds) ->
tcSetInstEnv inst_env $
-- Foreign import declarations next
traceTc (text "Tc4") `thenNF_Tc_`
......@@ -391,19 +404,24 @@ tcModule pcs hst get_fixity this_mod decls
-- We also typecheck any extra binds that came out of the "deriving" process
traceTc (text "Default types" <+> ppr defaulting_tys) `thenNF_Tc_`
traceTc (text "Tc5") `thenNF_Tc_`
tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) ->
tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env2), lie_valdecls) ->
-- Second pass over class and instance declarations,
-- plus rules and foreign exports, to generate bindings
tcSetEnv env $
tcSetEnv env2 $
traceTc (text "Tc6") `thenNF_Tc_`
traceTc (ppr (getTcGEnv env2)) `thenNF_Tc_`
tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds, dm_ids) ->
tcExtendGlobalValEnv dm_ids $
tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
traceTc (text "Tc7") `thenNF_Tc_`
tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
traceTc (text "Tc8") `thenNF_Tc_`
tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
tcSourceRules source_rules `thenNF_Tc` \ (lie_rules, more_local_rules) ->
traceTc (text "Tc9") `thenNF_Tc_`
tcSourceRules src_rule_decls `thenNF_Tc` \ (lie_rules, src_rules) ->
-- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
traceTc (text "Tc6") `thenNF_Tc_`
traceTc (text "Tc10") `thenNF_Tc_`
tcCheckMain this_mod `thenTc_`
-- Deal with constant or ambiguous InstIds. How could
......@@ -446,32 +464,33 @@ tcModule pcs hst get_fixity this_mod decls
traceTc (text "Tc8") `thenNF_Tc_`
zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
traceTc (text "Tc9") `thenNF_Tc_`
zonkRules more_local_rules `thenNF_Tc` \ more_local_rules' ->
zonkRules src_rules `thenNF_Tc` \ src_rules' ->
let local_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
local_type_env :: TypeEnv
local_type_env = mkTypeEnv local_things
all_local_rules = local_rules ++ more_local_rules'
let src_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
-- This is horribly crude; the env might be jolly big
in
traceTc (text "Tc10") `thenNF_Tc_`
returnTc (final_env,
new_pcs,
TcResults { tc_env = local_type_env,
tc_insts = local_inst_dfuns,
TcResults { tc_env = mkTypeEnv src_things,
tc_insts = map iDFunId inst_info,
tc_binds = all_binds',
tc_fords = foi_decls ++ foe_decls',
tc_rules = all_local_rules
tc_rules = src_rules'
}
)
) `thenTc` \ (_, pcs, tc_result) ->
returnTc (pcs, tc_result)
where
tycl_decls = [d | TyClD d <- decls]
val_binds = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
source_rules = [d | RuleD d <- decls, not (isIfaceRuleDecl d)]
tycl_decls = [d | TyClD d <- decls]
rule_decls = [d | RuleD d <- decls]
inst_decls = [d | InstD d <- decls]
val_decls = [d | ValD d <- decls]
(src_inst_decls, iface_inst_decls) = partition isSourceInstDecl inst_decls
(src_rule_decls, iface_rule_decls) = partition (isSourceRuleDecl this_mod) rule_decls
val_binds = foldr ThenBinds EmptyBinds val_decls
\end{code}
......@@ -494,51 +513,97 @@ typecheckIface
typecheckIface dflags pcs hst mod_iface decls
= do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $
tcIfaceImports pcs hst get_fixity this_mod decls
tcIface pcs this_mod decls
; printIfaceDump dflags maybe_tc_stuff
; return maybe_tc_stuff }
where
this_mod = mi_module mod_iface
fixity_env = mi_fixities mod_iface
this_mod = mi_module mod_iface
get_fixity :: Name -> Maybe Fixity
get_fixity nm = lookupNameEnv fixity_env nm
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
}
tcIfaceImports pcs hst get_fixity this_mod decls
= fixTc (\ ~(unf_env, _, _, _, _, _) ->
tcImports unf_env pcs hst get_fixity this_mod decls
) `thenTc` \ (env, new_pcs, local_inst_info, local_inst_dfuns,
deriv_binds, local_rules) ->
ASSERT(nullBinds deriv_binds && null local_inst_info)
let
local_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv env))
mod_details = ModDetails { md_types = mkTypeEnv local_things,
md_insts = local_inst_dfuns,
md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules],
md_binds = [] }
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)
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 unf_env 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
-> (Name -> Maybe Fixity)
-> Module
-> [RenamedHsDecl]
-> TcM (TcEnv, PersistentCompilerState, [InstInfo], [DFunId],
RenamedHsBinds, [TypecheckedRuleDecl])
-> [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
-- type and class decls (some source, some imported)
-- interface signatures (checked lazily)
-- instance decls
-- rule decls
-- 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 get_fixity this_mod decls
tcImports unf_env pcs hst get_fixity 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].
......@@ -551,8 +616,8 @@ tcImports unf_env pcs hst get_fixity this_mod decls
-- an error we'd better stop now, to avoid a cascade
traceTc (text "Tc1") `thenNF_Tc_`
tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ env ->
tcSetEnv env $
tcTyAndClassDecls unf_env 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
......@@ -567,39 +632,46 @@ tcImports unf_env pcs hst get_fixity this_mod decls
-- Typecheck the instance decls, includes deriving
-- Note that imported dictionary functions are already
-- in scope from the preceding tcInterfaceSigs
traceTc (text "Tc3") `thenNF_Tc_`
tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) hst unf_env get_fixity this_mod decls
`thenTc` \ (new_pcs_insts, inst_env, local_inst_info, local_inst_dfuns, deriv_binds) ->
tcSetInstEnv inst_env $
tcIfaceRules unf_env (pcs_rules pcs) this_mod iface_rules `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
-- When relinking this module from its interface-file decls
-- we'll have IfaceRules that are in fact local to this module
-- That's the reason we we get any local_rules out here
traceTc (text "Tc3") `thenNF_Tc_`
tcIfaceInstDecls1 inst_decls `thenTc` \ dfuns ->
tcIfaceRules rule_decls `thenNF_Tc` \ rules ->
tcGetEnv `thenTc` \ unf_env ->
addInstDFuns (pcs_insts pcs) dfuns `thenNF_Tc` \ new_pcs_insts ->
tcGetEnv `thenTc` \ unf_env ->
let
all_things = typeEnvElts (getTcGEnv unf_env)
-- 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
= filter (not . isLocalThing this_mod) all_things
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, local_inst_info, local_inst_dfuns, deriv_binds, local_rules)
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
tycl_decls = [d | TyClD d <- decls]
iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
add_rule rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule)
\end{code}
......
......@@ -20,9 +20,8 @@ import TcType ( tyVarsOfTypes, openTypeKind )
import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar, tcDelay )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..), tcAddScopedTyVars )
import TcExpr ( tcExpr )
import TcEnv ( RecTcEnv, tcExtendLocalValEnv, isLocalThing )
import Rules ( extendRuleBase )
import Inst ( LIE, plusLIEs, instToId )
import TcEnv ( RecTcEnv, tcExtendLocalValEnv, isLocalThing, tcLookupId )
import Inst ( LIE, plusLIEs, emptyLIE, instToId )
import Id ( idName, idType, mkLocalId )
import Module ( Module )
import List ( partition )
......@@ -30,27 +29,8 @@ import Outputable
\end{code}
\begin{code}
tcIfaceRules :: RecTcEnv -> PackageRuleBase -> Module -> [RenamedRuleDecl]
-> TcM (PackageRuleBase, [TypecheckedRuleDecl])
tcIfaceRules unf_env pkg_rule_base mod decls
= tcDelay unf_env doc [] (
-- We need the recursive env because the built-in rules show up as