Commit 22ffc06a authored by simonpj's avatar simonpj
Browse files

[project @ 2001-02-20 09:42:50 by simonpj]

Typechecking [TcModule, TcBinds, TcHsSyn, TcInstDcls, TcSimplify]
~~~~~~~~~~~~
* Fix a bug in TcSimplify that broke functional dependencies.
  Interleaving unification and context reduction is trickier 
  than I thought.  Comments in the code amplify.  

* Fix a functional-dependency bug, that meant that this pgm:
	class C a b | a -> b where f :: a -> b
	
	g :: (C a b, Eq b) => a -> Bool
	g x = f x == f x
  gave an ambiguity error report.  I'm afraid I've forgotten
  what the problem was.


* Correct the implementation of the monomorphism restriction,
  in TcBinds.generalise.  This fixes Marcin's bug report:
	test1 :: Eq a => a -> b -> b
	test1 x y = y

	test2 = test1 (3::Int)
  Previously we were erroneously inferring test2 :: () -> ()

* Make the "unf_env" that is looped round in TcModule go round
  in a big loop, not just round tcImports.  This matters when
  we have mutually recursive modules, so that the Ids bound in
  the source code may appear in the imports.  Sigh.  But no big
  deal.

  It does mean that you have to be careful not to call isLocalId,
  isDataConId etc, because they consult the IdInfo of an Id, which 
  in turn may be determined by the loop-tied unf_env.
parent 52eed22d
......@@ -20,20 +20,19 @@ import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet )
import TcMonad
import Inst ( LIE, emptyLIE, mkLIE, plusLIE, lieToList, InstOrigin(..),
newDicts, tyVarsOfInsts, instToId
import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..),
newDicts, instToId
)
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId,
tcGetGlobalTyVars
newSpecPragmaId, newLocalId
)
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyToDicts )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck, tcSimplifyToDicts )
import TcMonoType ( tcHsSigType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
import TcType ( newTyVarTy, newTyVar, zonkTcTyVarsAndFV,
import TcType ( newTyVarTy, newTyVar,
zonkTcTyVarToTyVar
)
import TcUnify ( unifyTauTy, unifyTauTyLists )
......@@ -44,7 +43,7 @@ import Var ( idType, idName )
import IdInfo ( InlinePragInfo(..) )
import Name ( Name, getOccName, getSrcLoc )
import NameSet
import Type ( mkTyVarTy,
import Type ( mkTyVarTy, tyVarsOfTypes,
mkForAllTys, mkFunTys, tyVarsOfType,
mkPredTy, mkForAllTy, isUnLiftedType,
unliftedTypeKind, liftedTypeKind, openTypeKind
......@@ -53,6 +52,7 @@ import Var ( tyVarKind )
import VarSet
import Bag
import Util ( isIn )
import ListSetOps ( minusList )
import Maybes ( maybeToBool )
import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel )
import FiniteMap ( listToFM, lookupFM )
......@@ -409,60 +409,72 @@ is doing.
%************************************************************************
\begin{code}
generalise binder_names mbind tau_tvs lie_req sigs
generalise_help doc tau_tvs lie_req sigs
-----------------------
| is_unrestricted && null sigs
| null sigs
= -- INFERENCE CASE: Unrestricted group, no type signatures
tcSimplifyInfer (ptext SLIT("bindings for") <+> pprBinders binder_names)
tcSimplifyInfer doc
tau_tvs lie_req
-----------------------
| is_unrestricted
| otherwise
= -- CHECKING CASE: Unrestricted group, there are type signatures
-- Check signature contexts are empty
checkSigsCtxts sigs `thenTc` \ (sig_avails, sig_dicts) ->
-- Check that the needed dicts can be
-- expressed in terms of the signature ones
tcSimplifyInferCheck check_doc tau_tvs sig_avails lie_req `thenTc` \ (forall_tvs, lie_free, dict_binds) ->
tcSimplifyInferCheck doc tau_tvs sig_avails lie_req `thenTc` \ (forall_tvs, lie_free, dict_binds) ->
-- Check that signature type variables are OK
checkSigsTyVars sigs `thenTc_`
returnTc (forall_tvs, lie_free, dict_binds, sig_dicts)
-----------------------
| otherwise -- RESTRICTED CASE: Restricted group
= -- Check signature contexts are empty
(if null sigs then
returnTc ()
else
checkSigsCtxts sigs `thenTc` \ (_, sig_dicts) ->
checkTc (null sig_dicts)
(restrictedBindCtxtErr binder_names)
) `thenTc_`
generalise binder_names mbind tau_tvs lie_req sigs
| is_unrestricted -- UNRESTRICTED CASE
= generalise_help doc tau_tvs lie_req sigs
| otherwise -- RESTRICTED CASE
= -- Do a simplification to decide what type variables
-- are constrained. We can't just take the free vars
-- of lie_req because that'll have methods that may
-- incidentally mention entirely unconstrained variables
-- e.g. a call to f :: Eq a => a -> b -> b
-- Here, b is unconstrained. A good example would be
-- foo = f (3::Int)
-- We want to infer the polymorphic type
-- foo :: forall b. b -> b
generalise_help doc tau_tvs lie_req sigs `thenTc` \ (forall_tvs, lie_free, dict_binds, dict_ids) ->
-- Check signature contexts are empty
checkTc (null sigs || null dict_ids)
(restrictedBindCtxtErr binder_names) `thenTc_`
-- Identify constrained tyvars
tcGetGlobalTyVars `thenNF_Tc` \ gbl_tvs ->
zonkTcTyVarsAndFV tau_tvs `thenNF_Tc` \ tau_tvs' ->
zonkTcTyVarsAndFV lie_tvs `thenNF_Tc` \ lie_tvs' ->
let
forall_tvs = tau_tvs' `minusVarSet` (lie_tvs' `unionVarSet` gbl_tvs)
-- Don't bother to oclose the gbl_tvs; this is a rare case
constrained_tvs = varSetElems (tyVarsOfTypes (map idType dict_ids))
-- The dict_ids are fully zonked
final_forall_tvs = forall_tvs `minusList` constrained_tvs
in
returnTc (varSetElems forall_tvs, lie_req, EmptyMonoBinds, [])
-- Now simplify with exactly that set of tyvars
-- We have to squash those Methods
tcSimplifyCheck doc final_forall_tvs [] lie_req `thenTc` \ (lie_free, binds) ->
returnTc (final_forall_tvs, lie_free, binds, [])
where
tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- sigs]
is_unrestricted | opt_NoMonomorphismRestriction = True
| otherwise = isUnRestrictedGroup tysig_names mbind
lie_tvs = varSetElems (tyVarsOfInsts (lieToList lie_req))
check_doc = case tysig_names of
[n] -> ptext SLIT("type signature for") <+> quotes (ppr n)
other -> ptext SLIT("type signature(s) for") <+> pprBinders tysig_names
tysig_names = [name | (TySigInfo name _ _ _ _ _ _ _) <- sigs]
doc | null sigs = ptext SLIT("banding(s) for") <+> pprBinders binder_names
| otherwise = ptext SLIT("type signature(s) for") <+> pprBinders binder_names
-----------------------
-- CHECK THAT ALL THE SIGNATURE CONTEXTS ARE UNIFIABLE
-- The type signatures on a mutually-recursive group of definitions
-- must all have the same context (or none).
......@@ -470,8 +482,6 @@ generalise binder_names mbind tau_tvs lie_req sigs
-- We unify them because, with polymorphic recursion, their types
-- might not otherwise be related. This is a rather subtle issue.
-- ToDo: amplify
--
-- We return a representative
checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ _ : other_sigs)
= mapTc_ check_one other_sigs `thenTc_`
if null theta1 then
......
......@@ -156,17 +156,18 @@ zonkIdBndr id
zonkIdOcc :: TcId -> NF_TcM Id
zonkIdOcc id
| not (isLocalId id) || isIP id
-- We're avoiding looking up superclass selectors
-- and constructors; zonking them is a no-op anyway, and the
-- superclass selectors aren't in the environment anyway.
= returnNF_Tc id
| otherwise
= tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' ->
-- We're even look up up superclass selectors and constructors;
-- even though zonking them is a no-op anyway, and the
-- superclass selectors aren't in the environment anyway.
-- But we don't want to call isLocalId to find out whether
-- it's a superclass selector (for example) because that looks
-- at the IdInfo field, which in turn be in a knot because of
-- the big knot in typecheckModule
let
new_id = case maybe_id' of
Just (AnId id') -> id'
other -> pprTrace "zonkIdOcc:" (ppr id) id
other -> WARN( isLocalId id, ppr id ) id
in
returnNF_Tc new_id
\end{code}
......@@ -351,8 +352,8 @@ zonkExpr (OpApp e1 op fixity e2)
zonkExpr e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
zonkExpr (NegApp _) = panic "zonkExpr: NegApp"
zonkExpr (HsPar _) = panic "zonkExpr: HsPar"
zonkExpr (SectionL expr op)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
......
......@@ -178,7 +178,7 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
clas_decls = filter isClassDecl tycl_decls
in
-- (1) Do the ordinary instance declarations
mapNF_Tc (tcInstDecl1 unf_env) inst_decls `thenNF_Tc` \ inst_infos ->
mapNF_Tc tcInstDecl1 inst_decls `thenNF_Tc` \ inst_infos ->
-- (2) Instances from generic class declarations
getGenericInstances clas_decls `thenTc` \ generic_inst_info ->
......@@ -229,9 +229,9 @@ addInstDFuns dfuns infos
\end{code}
\begin{code}
tcInstDecl1 :: TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo]
tcInstDecl1 :: RenamedInstDecl -> NF_TcM [InstInfo]
-- Deal with a single instance declaration
tcInstDecl1 unf_env decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc []) $
tcAddSrcLoc src_loc $
......
......@@ -15,7 +15,7 @@ import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
isIfaceRuleDecl, nullBinds, andMonoBindList
)
import HsTypes ( toHsType )
import PrelNames ( mAIN_Name, mainName, ioTyConName, printName )
import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName )
import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedHsExpr )
import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr,
TypecheckedForeignDecl, TypecheckedRuleDecl,
......@@ -33,7 +33,7 @@ import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults, defaultDefaultTys )
import TcExpr ( tcMonoExpr )
import TcEnv ( TcEnv, InstInfo, tcExtendGlobalValEnv, tcLookup_maybe,
import TcEnv ( TcEnv, RecTcEnv, InstInfo, tcExtendGlobalValEnv, tcLookup_maybe,
isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
TcTyThing(..), tcLookupTyCon
)
......@@ -84,15 +84,15 @@ typecheckModule
-> HomeSymbolTable
-> ModIface -- Iface for this module
-> PrintUnqualified -- For error printing
-> [RenamedHsDecl]
-> (SyntaxMap, [RenamedHsDecl])
-> Bool -- True <=> check for Main.main if Module==Main
-> IO (Maybe (PersistentCompilerState, TcResults))
-- The new PCS is Augmented with imported information,
-- (but not stuff from this module)
typecheckModule dflags pcs hst mod_iface unqual decls check_main
= do { maybe_tc_result <- typecheck dflags pcs hst unqual $
typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) check_main
= do { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $
tcModule pcs hst get_fixity this_mod decls check_main
; printTcDump dflags maybe_tc_result
; return maybe_tc_result }
......@@ -110,18 +110,24 @@ typecheckExpr :: DynFlags
-> HomeSymbolTable
-> PrintUnqualified -- For error printing
-> Module
-> (RenamedHsExpr, -- The expression itself
-> (SyntaxMap,
RenamedHsExpr, -- The expression itself
[RenamedHsDecl]) -- Plus extra decls it sucked in from interface files
-> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, TcType))
typecheckExpr dflags wrap_io pcs hst unqual this_mod (expr, decls)
= typecheck dflags pcs hst unqual $
typecheckExpr dflags wrap_io pcs hst unqual this_mod (syn_map, expr, decls)
= typecheck dflags syn_map pcs hst unqual $
-- use the default default settings, i.e. [Integer, Double]
tcSetDefaultTys defaultDefaultTys $
tcImports pcs hst get_fixity this_mod decls `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
-- Typecheck the extra declarations
fixTc (\ ~(unf_env, _, _, _, _) ->
tcImports unf_env pcs hst get_fixity this_mod decls
) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
-- Now typecheck the expression
tcSetEnv env $
tc_expr expr `thenTc` \ (expr', expr_ty) ->
zonkExpr expr' `thenNF_Tc` \ zonked_expr ->
......@@ -170,15 +176,16 @@ typecheckExpr dflags wrap_io pcs hst unqual this_mod (expr, decls)
---------------
typecheck :: DynFlags
-> SyntaxMap
-> PersistentCompilerState
-> HomeSymbolTable
-> PrintUnqualified -- For error printing
-> TcM r
-> IO (Maybe r)
typecheck dflags pcs hst unqual thing_inside
typecheck dflags syn_map pcs hst unqual thing_inside
= do { showPass dflags "Typechecker";
; env <- initTcEnv hst (pcs_PTE pcs)
; env <- initTcEnv syn_map hst (pcs_PTE pcs)
; (maybe_tc_result, errs) <- initTc dflags env thing_inside
......@@ -202,102 +209,108 @@ tcModule :: PersistentCompilerState
-> TcM (PersistentCompilerState, TcResults)
tcModule pcs hst get_fixity this_mod decls check_main
= -- Type-check the type and class decls, and all imported decls
-- tcImports recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
checkNoErrsTc (
tcImports pcs hst get_fixity this_mod decls
) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
= fixTc (\ ~(unf_env, _, _) ->
-- Loop back the final environment, including the fully zonkec
-- versions of bindings from this module. In the presence of mutual
-- recursion, interface type signatures may mention variables defined
-- in this module, which is why the knot is so big
tcSetEnv env $
-- 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_insts, deriv_binds, local_rules) ->
tcSetEnv env $
-- Foreign import declarations next
-- traceTc (text "Tc4") `thenNF_Tc_`
tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
tcExtendGlobalValEnv fo_ids $
traceTc (text "Tc4") `thenNF_Tc_`
tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
tcExtendGlobalValEnv fo_ids $
-- Default declarations
tcDefaults decls `thenTc` \ defaulting_tys ->
tcSetDefaultTys defaulting_tys $
tcDefaults decls `thenTc` \ defaulting_tys ->
tcSetDefaultTys defaulting_tys $
-- Value declarations next.
-- We also typecheck any extra binds that came out of the "deriving" process
-- traceTc (text "Tc5") `thenNF_Tc_`
tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) ->
tcSetEnv env $
-- Foreign export declarations next
-- traceTc (text "Tc6") `thenNF_Tc_`
tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
-- Second pass over class and instance declarations,
-- to compile the bindings themselves.
tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
tcSourceRules source_rules `thenNF_Tc` \ (lie_rules, more_local_rules) ->
-- Deal 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. (Usually, ambiguous type variables are resolved
-- during the generalisation step.)
let
lie_alldecls = lie_valdecls `plusLIE`
lie_instdecls `plusLIE`
lie_clasdecls `plusLIE`
lie_fodecls `plusLIE`
lie_rules
in
tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
-- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
(if check_main
then tcCheckMain this_mod
else returnTc ()) `thenTc_`
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
let
all_binds = val_binds `AndMonoBinds`
inst_binds `AndMonoBinds`
cls_dm_binds `AndMonoBinds`
const_inst_binds `AndMonoBinds`
foe_binds
in
-- traceTc (text "Tc9") `thenNF_Tc_`
zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) ->
tcSetEnv final_env $
-- zonkTopBinds puts all the top-level Ids into the tcGEnv
zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
zonkRules more_local_rules `thenNF_Tc` \ more_local_rules' ->
let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
-- Create any necessary "implicit" bindings (data constructors etc)
-- Should we create bindings for dictionary constructors?
-- They are always fully applied, and the bindings are just there
-- to support partial applications. But it's easier to let them through.
implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
| id <- implicitTyThingIds local_things
, let unf = idUnfolding id
, hasUnfolding unf
]
local_type_env :: TypeEnv
local_type_env = mkTypeEnv local_things
all_local_rules = local_rules ++ more_local_rules'
in
-- traceTc (text "Tc10") `thenNF_Tc_`
returnTc (new_pcs,
TcResults { tc_env = local_type_env,
tc_binds = implicit_binds `AndMonoBinds` all_binds',
tc_fords = foi_decls ++ foe_decls',
tc_rules = all_local_rules
}
)
traceTc (text "Tc5") `thenNF_Tc_`
tcTopBinds (val_binds `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) ->
-- Second pass over class and instance declarations,
-- plus rules and foreign exports, to generate bindings
tcSetEnv env $
tcInstDecls2 local_insts `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
tcClassDecls2 this_mod tycl_decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
tcSourceRules source_rules `thenNF_Tc` \ (lie_rules, more_local_rules) ->
-- Deal 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. (Usually, ambiguous type variables are resolved
-- during the generalisation step.)
let
lie_alldecls = lie_valdecls `plusLIE`
lie_instdecls `plusLIE`
lie_clasdecls `plusLIE`
lie_fodecls `plusLIE`
lie_rules
in
traceTc (text "Tc6") `thenNF_Tc_`
tcSimplifyTop lie_alldecls `thenTc` \ const_inst_binds ->
-- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
(if check_main
then tcCheckMain this_mod
else returnTc ()) `thenTc_`
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
let
all_binds = val_binds `AndMonoBinds`
inst_binds `AndMonoBinds`
cls_dm_binds `AndMonoBinds`
const_inst_binds `AndMonoBinds`
foe_binds
in
traceTc (text "Tc7") `thenNF_Tc_`
zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', final_env) ->
tcSetEnv final_env $
-- zonkTopBinds puts all the top-level Ids into the tcGEnv
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' ->
let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
-- Create any necessary "implicit" bindings (data constructors etc)
-- Should we create bindings for dictionary constructors?
-- They are always fully applied, and the bindings are just there
-- to support partial applications. But it's easier to let them through.
implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
| id <- implicitTyThingIds local_things
, let unf = idUnfolding id
, hasUnfolding unf
]
local_type_env :: TypeEnv
local_type_env = mkTypeEnv local_things
all_local_rules = local_rules ++ more_local_rules'
in
traceTc (text "Tc10") `thenNF_Tc_`
returnTc (final_env,
new_pcs,
TcResults { tc_env = local_type_env,
tc_binds = implicit_binds `AndMonoBinds` all_binds',
tc_fords = foi_decls ++ foe_decls',
tc_rules = all_local_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]
......@@ -306,13 +319,14 @@ tcModule pcs hst get_fixity this_mod decls check_main
\begin{code}
tcImports :: PersistentCompilerState
tcImports :: RecTcEnv
-> PersistentCompilerState
-> HomeSymbolTable
-> (Name -> Maybe Fixity)
-> Module
-> [RenamedHsDecl]
-> TcM (TcEnv, PersistentCompilerState,
[InstInfo], RenamedHsBinds, [TypecheckedRuleDecl])
-> TcM (TcEnv, PersistentCompilerState, [InstInfo],
RenamedHsBinds, [TypecheckedRuleDecl])
-- tcImports is a slight mis-nomer.
-- It deals with everythign that could be an import:
......@@ -322,66 +336,68 @@ tcImports :: PersistentCompilerState
-- rule decls
-- These can occur in source code too, of course
tcImports pcs hst get_fixity this_mod decls
= fixTc (\ ~(unf_env, _, _, _, _) ->
-- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
tcImports unf_env pcs hst get_fixity this_mod 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
-- traceTc (text "Tc1") `thenNF_Tc_`
tcTyAndClassDecls unf_env tycl_decls `thenTc` \ env ->
tcSetEnv env $
-- Typecheck the instance decls, includes deriving
-- traceTc (text "Tc2") `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, deriv_binds) ->
tcSetInstEnv inst_env $
-- 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 "Tc3") `thenNF_Tc_`
tcInterfaceSigs unf_env tycl_decls `thenTc` \ sig_ids ->
tcExtendGlobalValEnv sig_ids $
tcIfaceRules (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
tcGetEnv `thenTc` \ unf_env ->
let
all_things = nameEnvElts (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
| isHomeModule this_mod
= filter (not . isLocalThing this_mod) all_things
| otherwise
= all_things
new_pte :: PackageTypeEnv
new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
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, deriv_binds, local_rules)
)
= 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 unf_env tycl_decls `thenTc` \ env ->
tcSetEnv env $
-- Typecheck the instance decls, includes deriving
traceTc (text "Tc2") `thenNF_Tc_`
tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs)
hst unf_env get_fixity this_mod
decls `thenTc` \ (new_pcs_insts, inst_env, local_insts, deriv_binds) ->
tcSetInstEnv inst_env $
-- 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 "Tc3") `thenNF_Tc_`
tcInterfaceSigs unf_env tycl_decls `thenTc` \ sig_ids ->
tcExtendGlobalValEnv sig_ids $
tcIfaceRules (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
tcGetEnv `thenTc` \ unf_env ->
let
all_things = nameEnvElts (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
| isHomeModule this_mod
= filter (not . isLocalThing this_mod) all_things
| otherwise
= all_things
new_pte :: PackageTypeEnv
new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
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_insts, deriv_binds, local_rules)
where
tycl_decls = [d | TyClD d <- decls]
iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
......
......@@ -31,8 +31,7 @@ import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
getDictClassTys, getIPs, isTyVarDict,
instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
Inst, LIE, pprInsts, pprInstsInFull,
mkLIE, plusLIE, isEmptyLIE,
lieToList
mkLIE, lieToList
)
import TcEnv ( tcGetGlobalTyVars, tcGetInstEnv )
import InstEnv ( lookupInstEnv, classInstEnv, InstLookupResult(..) )
......@@ -395,7 +394,7 @@ tcSimplifyInfer doc tau_tvs wanted_lie
-- Check for non-generalisable insts
mapTc_ addCantGenErr (filter (not . instCanBeGeneralised) irreds) `thenTc_`