Commit 20d1c20c authored by simonmar's avatar simonmar
Browse files

[project @ 2001-02-23 12:24:10 by simonmar]

Fix a problem with duplicate instances appearing in the interpreter
after reloading modules.
parent 1ff7e0c6
......@@ -156,16 +156,13 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch
else do {
-- TYPECHECK
maybe_tc_result <- typecheckModule dflags pcs_cl hst
old_iface alwaysQualify (vanillaSyntaxMap, cl_hs_decls)
False{-don't check for Main.main-};
maybe_tc_result
<- typecheckIface dflags pcs_cl hst old_iface (vanillaSyntaxMap, cl_hs_decls);
case maybe_tc_result of {
Nothing -> return (HscFail pcs_cl);
Just (pcs_tc, tc_result) -> do {
Just (pcs_tc, env_tc, local_rules) -> do {
let env_tc = tc_env tc_result
local_rules = tc_rules tc_result
;
-- create a new details from the closed, typechecked, old iface
let new_details = mkModDetailsFromIface env_tc local_rules
;
......@@ -216,7 +213,6 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch
; maybe_tc_result
<- _scc_ "TypeCheck" typecheckModule dflags pcs_rn hst new_iface
print_unqualified rn_hs_decls
True{-check for Main.main if necessary-}
; case maybe_tc_result of {
Nothing -> return (HscFail pcs_ch{-was: pcs_rn-});
Just (pcs_tc, tc_result) -> do {
......
......@@ -247,7 +247,7 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls
-- Make a Real dfun instead of the dummy one we have so far
gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo
gen_inst_info dfun binds
= InstInfo { iLocal = True, iDFunId = dfun,
= InstInfo { iDFunId = dfun,
iBinds = binds, iPrags = [] }
rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'
......
......@@ -57,8 +57,8 @@ import DataCon ( DataCon )
import TyCon ( TyCon )
import Class ( Class, ClassOpItem, ClassContext )
import Name ( Name, OccName, NamedThing(..),
nameOccName, getSrcLoc, mkLocalName,
isLocalName, nameModule_maybe
nameOccName, getSrcLoc, mkLocalName, isLocalName,
nameIsLocalOrFrom, nameModule_maybe
)
import Name ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv )
import OccName ( mkDFunOcc, occNameString )
......@@ -261,11 +261,7 @@ newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
\begin{code}
isLocalThing :: NamedThing a => Module -> a -> Bool
-- True if the thing has a Local name,
-- or a Global name from the specified module
isLocalThing mod thing = case nameModule_maybe (getName thing) of
Nothing -> True -- A local name
Just m -> m == mod -- A global thing
isLocalThing mod thing = nameIsLocalOrFrom mod (getName thing)
\end{code}
%************************************************************************
......@@ -509,7 +505,6 @@ The InstInfo type summarises the information in an instance declaration
\begin{code}
data InstInfo
= InstInfo {
iLocal :: Bool, -- True <=> it's defined in this module
iDFunId :: DFunId, -- The dfun id
iBinds :: RenamedMonoBinds, -- Bindings, b
iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
......
......@@ -15,8 +15,8 @@ import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..),
MonoBinds(..), HsExpr(..), HsLit(..), Sig(..),
andMonoBindList, collectMonoBinders, isClassDecl
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds,
RenamedTyClDecl, RenamedHsType,
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl,
RenamedMonoBinds, RenamedTyClDecl, RenamedHsType,
extractHsTyVars, maybeGenericMatch
)
import TcHsSyn ( TcMonoBinds, mkHsConApp )
......@@ -31,8 +31,9 @@ import TcDeriv ( tcDeriving )
import TcEnv ( TcEnv, tcExtendGlobalValEnv,
tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcLookupClass,
InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
newDFunName, tcExtendTyVarEnv
InstInfo(..), pprInstInfo, simpleInstInfoTyCon,
simpleInstInfoTy, newDFunName, tcExtendTyVarEnv,
isLocalThing,
)
import InstEnv ( InstEnv, extendInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType, checkSigTyVars )
......@@ -171,7 +172,7 @@ tcInstDecls1 :: PackageInstEnv
-> [RenamedHsDecl]
-> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
tcInstDecls1 inst_env0 prs hst unf_env get_fixity this_mod decls
= let
inst_decls = [inst_decl | InstD inst_decl <- decls]
tycl_decls = [decl | TyClD decl <- decls]
......@@ -191,7 +192,8 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
-- e) generic instances inst_env4
-- The result of (b) replaces the cached InstEnv in the PCS
let
(local_inst_info, imported_inst_info) = partition iLocal (concat inst_infos)
(local_inst_info, imported_inst_info)
= partition (isLocalThing this_mod . iDFunId) (concat inst_infos)
imported_dfuns = map (tcAddImportedIdInfo unf_env . iDFunId)
imported_inst_info
......@@ -207,7 +209,8 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
-- 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; hecne inst_env4
tcDeriving prs mod inst_env4 get_fixity tycl_decls `thenTc` \ (deriv_inst_info, deriv_binds) ->
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 (inst_env1,
......@@ -267,7 +270,7 @@ tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
let
dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
in
returnTc [InstInfo { iLocal = is_local, iDFunId = dfun_id,
returnTc [InstInfo { iDFunId = dfun_id,
iBinds = binds, iPrags = uprags }]
\end{code}
......@@ -406,7 +409,7 @@ mkGenericInstance clas loc (hs_ty, binds)
dfun_id = mkDictFunId dfun_name clas tyvars inst_tys inst_theta
in
returnTc (InstInfo { iLocal = True, iDFunId = dfun_id,
returnTc (InstInfo { iDFunId = dfun_id,
iBinds = binds, iPrags = [] })
\end{code}
......@@ -498,15 +501,13 @@ is the @dfun_theta@ below.
First comes the easy case of a non-local instance decl.
\begin{code}
tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds)
-- tcInstDecl2 is called *only* on InstInfos
tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id,
tcInstDecl2 (InstInfo { iDFunId = dfun_id,
iBinds = monobinds, iPrags = uprags })
| not is_local
= returnNF_Tc (emptyLIE, EmptyMonoBinds)
| otherwise
= -- Prime error recovery
recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $
tcAddSrcLoc (getSrcLoc dfun_id) $
......
......@@ -5,7 +5,7 @@
\begin{code}
module TcModule (
typecheckModule, typecheckExpr, TcResults(..)
typecheckModule, typecheckIface, typecheckExpr, TcResults(..)
) where
#include "HsVersions.h"
......@@ -82,18 +82,17 @@ typecheckModule
:: DynFlags
-> PersistentCompilerState
-> HomeSymbolTable
-> ModIface -- Iface for this module
-> ModIface -- Iface for this module (just module & fixities)
-> PrintUnqualified -- For error printing
-> (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 (syn_map, decls) check_main
typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls)
= do { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $
tcModule pcs hst get_fixity this_mod decls check_main
tcModule pcs hst get_fixity this_mod decls
; printTcDump dflags maybe_tc_result
; return maybe_tc_result }
where
......@@ -103,6 +102,48 @@ typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) check_main
get_fixity :: Name -> Maybe Fixity
get_fixity nm = lookupNameEnv fixity_env nm
---------------
typecheckIface
:: DynFlags
-> PersistentCompilerState
-> HomeSymbolTable
-> ModIface -- Iface for this module (just module & fixities)
-> (SyntaxMap, [RenamedHsDecl])
-> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedRuleDecl]))
-- The new PCS is Augmented with imported information,
-- (but not stuff from this module).
-- The TcResults returned contains only the environment
-- and rules.
typecheckIface dflags pcs hst mod_iface (syn_map, decls)
= do { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $
tcIfaceImports pcs hst get_fixity 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
get_fixity :: Name -> Maybe Fixity
get_fixity nm = lookupNameEnv fixity_env nm
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,
deriv_binds, local_rules) ->
ASSERT(nullBinds deriv_binds)
let
local_things = filter (isLocalThing this_mod)
(nameEnvElts (getTcGEnv env))
local_type_env :: TypeEnv
local_type_env = mkTypeEnv local_things
in
-- throw away local_inst_info
returnTc (new_pcs, local_type_env, local_rules)
---------------
typecheckExpr :: DynFlags
-> Bool -- True <=> wrap in 'print' to get a result of IO type
......@@ -205,10 +246,9 @@ tcModule :: PersistentCompilerState
-> (Name -> Maybe Fixity)
-> Module
-> [RenamedHsDecl]
-> Bool -- True <=> check for Main.main if Mod==Main
-> TcM (PersistentCompilerState, TcResults)
tcModule pcs hst get_fixity this_mod decls check_main
tcModule pcs hst get_fixity this_mod decls
= fixTc (\ ~(unf_env, _, _) ->
-- Loop back the final environment, including the fully zonkec
-- versions of bindings from this module. In the presence of mutual
......@@ -261,9 +301,7 @@ tcModule pcs hst get_fixity this_mod decls check_main
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_`
tcCheckMain this_mod `thenTc_`
-- Backsubstitution. This must be done last.
-- Even tcSimplifyTop may do some unification.
......@@ -466,22 +504,34 @@ noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
printTcDump dflags Nothing = return ()
printTcDump dflags (Just (_, results))
= do dumpIfSet_dyn dflags Opt_D_dump_types
"Type signatures" (dump_sigs results)
"Type signatures" (dump_sigs (tc_env results))
dumpIfSet_dyn dflags Opt_D_dump_tc
"Typechecked" (dump_tc results)
printIfaceDump dflags Nothing = return ()
printIfaceDump dflags (Just (_, env, rules))
= do dumpIfSet_dyn dflags Opt_D_dump_types
"Type signatures" (dump_sigs env)
dumpIfSet_dyn dflags Opt_D_dump_tc
"Typechecked" (dump_iface env rules)
dump_tc results
= vcat [ppr (tc_binds results),
pp_rules (tc_rules results),
ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
]
dump_sigs results -- Print type signatures
dump_iface env rules
= vcat [pp_rules rules,
ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts env]
]
dump_sigs env -- Print type signatures
= -- Convert to HsType so that we get source-language style printing
-- And sort by RdrName
vcat $ map ppr_sig $ sortLt lt_sig $
[ (toRdrName id, toHsType (idType id))
| AnId id <- nameEnvElts (tc_env results),
| AnId id <- nameEnvElts env,
want_sig id
]
where
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment