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
;
; 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 {
-- 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'
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 )
\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}
%************************************************************************
\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
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 )
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 )
-> [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]
-- 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
-- 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,
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}
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}
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) $
\begin{code}
module TcModule (
- typecheckModule, typecheckExpr, TcResults(..)
+ typecheckModule, typecheckIface, typecheckExpr, TcResults(..)
) where
#include "HsVersions.h"
:: 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
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
-> 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
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.
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
projects / ghc-hetmet.git / commitdiff