deprecEnv :: NameEnv DeprecTxt,
typeEnv :: TypeEnv,
- instEnv :: InstEnv,
- ruleEnv :: RuleEnv -- Domain may include Id from other modules
+ mdInsts :: [DFunId], -- Dfun-ids for the instances in this module
+ mdRules :: RuleEnv -- Domain may include Id from other modules
}
emptyModDetails :: Module -> ModDetails
fixityEnv = emptyNameEnv,
deprecEnv = emptyNameEnv,
typeEnv = emptyNameEnv,
- instEnv = emptyInstEnv,
- ruleEnv = emptyRuleEnv
+ mdInsts = [],
+ mdRules = emptyRuleEnv
}
-emptyRuleEnv = panic "emptyRuleEnv"
\end{code}
Symbol tables map modules to ModDetails:
-- not on construction
type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class
-type ClsInstEnv = [(TyVarSet, [Type], Id)] -- The instances for a particular class
+type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class
+type DFunId = Id
type RuleEnv = IdEnv [CoreRule]
+
+emptyRuleEnv = emptyVarEnv
\end{code}
\section[TcBinds]{TcBinds}
\begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
+module TcBinds ( tcBindsAndThen, tcTopBinds,y
tcSpecSigs, tcBindWithSigs ) where
#include "HsVersions.h"
dictionaries, which we resolve at the module level.
\begin{code}
-tcTopBindsAndThen, tcBindsAndThen
+tcTopBinds :: RenamedHsBinds -> TcM ((TcMonoBinds, TcEnv), LIE)
+tcTopBinds binds
+ = tc_binds_and_then TopLevel glue binds $
+ tcGetEnv `thenNF_Tc` \ env ->
+ returnTc ((EmptyMonoBinds, env), emptyLIE)
+ where
+ glue is_rec binds1 (binds2, thing) = (binds1 `AndMonoBinds` binds2, thing)
+
+
+tcBindsAndThen
:: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator
-> RenamedHsBinds
-> TcM (thing, LIE)
-> TcM (thing, LIE)
-tcTopBindsAndThen = tc_binds_and_then TopLevel
-tcBindsAndThen = tc_binds_and_then NotTopLevel
+tcBindsAndThen = tc_binds_and_then NotTopLevel
tc_binds_and_then top_lvl combiner EmptyBinds do_next
= do_next
import TcMonad
import TcEnv ( InstEnv, getEnvTyCons, tcSetInstEnv, newDFunName )
import TcGenDeriv -- Deriv stuff
-import TcInstUtil ( InstInfo(..), pprInstInfo, instInfoClass, simpleInstInfoTyCon, buildInstanceEnv )
+import TcInstUtil ( InstInfo(..), pprInstInfo, simpleDFunClassTyCon, extendInstEnv )
import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
So, here are the synonyms for the ``equation'' structures:
\begin{code}
-type DerivEqn = (Class, TyCon, [TyVar], DerivRhs)
- -- The tyvars bind all the variables in the RHS
- -- NEW: it's convenient to re-use InstInfo
- -- We'll "panic" out some fields...
+type DerivEqn = (Name, Class, TyCon, [TyVar], DerivRhs)
+ -- The Name is the name for the DFun we'll build
+ -- The tyvars bind all the variables in the RHS
type DerivRhs = [(Class, [TauType])] -- Same as a ThetaType!
\begin{code}
tcDeriving :: PersistentRenamerState
-> Module -- name of module under scrutiny
- -> Bag InstInfo -- What we already know about instances
- -> TcM (Bag InstInfo, -- The generated "instance decls".
- RenamedHsBinds) -- Extra generated bindings
+ -> InstEnv -- What we already know about instances
+ -> TcM ([InstInfo], -- The generated "instance decls".
+ RenamedHsBinds) -- Extra generated bindings
-tcDeriving prs mod inst_decl_infos_in
- = recoverTc (returnTc (emptyBag, EmptyBinds)) $
+tcDeriving prs mod inst_env_in local_tycons
+ = recoverTc (returnTc ([], EmptyBinds)) $
-- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
- makeDerivEqns `thenTc` \ eqns ->
+ makeDerivEqns local_tycons `thenTc` \ eqns ->
if null eqns then
- returnTc (emptyBag, EmptyBinds)
+ returnTc ([], EmptyBinds)
else
-- Take the equation list and solve it, to deliver a list of
-- solutions, a.k.a. the contexts for the instance decls
-- required for the corresponding equations.
- solveDerivEqns inst_decl_infos_in eqns `thenTc` \ new_inst_infos ->
+ solveDerivEqns inst_env_in eqns `thenTc` \ new_dfuns ->
-- Now augment the InstInfos, adding in the rather boring
-- actual-code-to-do-the-methods binds. We may also need to
-- "con2tag" and/or "tag2con" functions. We do these
-- separately.
- gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc ->
-
+ gen_taggery_Names new_dfuns `thenTc` \ nm_alist_etc ->
tcGetEnv `thenNF_Tc` \ env ->
let
extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
- method_binds_s = map (gen_bind (tcGST env)) new_inst_infos
+ method_binds_s = map (gen_bind (tcGST env)) new_dfuns
mbinders = collectLocatedMonoBinders extra_mbinds
-- Rename to get RenamedBinds.
returnRn (rn_method_binds_s, rn_extra_binds)
)
in
- mapNF_Tc gen_inst_info (new_inst_infos `zip` rn_method_binds_s) `thenNF_Tc` \ really_new_inst_infos ->
+ mapNF_Tc gen_inst_info (new_dfuns `zip` rn_method_binds_s) `thenNF_Tc` \ new_inst_infos ->
ioToTc (dumpIfSet opt_D_dump_deriv "Derived instances"
- (ddump_deriving really_new_inst_infos rn_extra_binds)) `thenTc_`
+ (ddump_deriving new_inst_infos rn_extra_binds)) `thenTc_`
- returnTc (listToBag really_new_inst_infos, rn_extra_binds)
+ returnTc (new_inst_infos, rn_extra_binds)
where
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
ddump_deriving inst_infos extra_binds
= vcat (map pprInstInfo inst_infos) $$ ppr extra_binds
where
- -- Paste the dfun id and method binds into the InstInfo
- gen_inst_info (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _, meth_binds)
- = newDFunName mod clas tys locn `thenNF_Tc` \ dfun_name ->
- let
- dfun_id = mkDictFunId dfun_name clas tyvars tys inst_decl_theta
- in
- returnNF_Tc (InstInfo clas tyvars tys inst_decl_theta
- dfun_id meth_binds locn [])
+ -- Make a Real dfun instead of the dummy one we have so far
+ gen_inst_info (dfun, binds)
+ = InstInfo { iLocal = True,
+ iClass = clas, iTyVars = tyvars,
+ iTys = tys, iTheta = theta,
+ iDFunId = dfun, iBinds = binds,
+ iLoc = getSrcLoc dfun, iPrags = [] }
+ where
+ (tyvars, theta, tau) = splitSigmaTy dfun
+ (clas, tys) = splitDictTy tau
rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'
-- Ignore the free vars returned
all those.
\begin{code}
-makeDerivEqns :: TcM [DerivEqn]
+makeDerivEqns :: Module -> [TyCon] -> TcM [DerivEqn]
-makeDerivEqns
- = tcGetEnv `thenNF_Tc` \ env ->
- let
- local_data_tycons = filter (\tc -> isLocallyDefined tc && isAlgTyCon tc)
- (getEnvTyCons env)
-
- think_about_deriving = need_deriving local_data_tycons
+makeDerivEqns this_mod local_tycons
+ = let
+ think_about_deriving = need_deriving local_tycons
(derive_these, _) = removeDups cmp_deriv think_about_deriving
in
if null local_data_tycons then
= case chk_out clas tycon of
Just err -> addErrTc err `thenNF_Tc_`
returnNF_Tc Nothing
- Nothing -> returnNF_Tc (Just (clas, tycon, tyvars, constraints))
+ Nothing -> newDFunName this_mod clas tys locn `thenNF_Tc` \ dfun_name ->
+ returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints))
where
clas_key = classKey clas
tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ???
\end{itemize}
\begin{code}
-solveDerivEqns :: Bag InstInfo
+solveDerivEqns :: InstEnv
-> [DerivEqn]
- -> TcM [InstInfo] -- Solns in same order as eqns.
- -- This bunch is Absolutely minimal...
+ -> TcM [DFunId] -- Solns in same order as eqns.
+ -- This bunch is Absolutely minimal...
-solveDerivEqns inst_decl_infos_in orig_eqns
+solveDerivEqns inst_env_in orig_eqns
= iterateDeriv initial_solutions
where
-- The initial solutions for the equations claim that each
-- compares it with the current one; finishes if they are the
-- same, otherwise recurses with the new solutions.
-- It fails if any iteration fails
- iterateDeriv :: [DerivSoln] ->TcM [InstInfo]
+ iterateDeriv :: [DerivSoln] ->TcM [DFunId]
iterateDeriv current_solns
- = checkNoErrsTc (iterateOnce current_solns) `thenTc` \ (new_inst_infos, new_solns) ->
+ = checkNoErrsTc (iterateOnce current_solns) `thenTc` \ (new_dfuns, new_solns) ->
if (current_solns == new_solns) then
- returnTc new_inst_infos
+ returnTc new_dfuns
else
iterateDeriv new_solns
= -- Extend the inst info from the explicit instance decls
-- with the current set of solutions, giving a
- add_solns inst_decl_infos_in orig_eqns current_solns
- `thenNF_Tc` \ (new_inst_infos, inst_env) ->
+ add_solns inst_env_in orig_eqns current_solns `thenNF_Tc` \ (new_dfuns, inst_env) ->
-- Simplify each RHS
-
tcSetInstEnv inst_env (
listTc [ tcAddErrCtxt (derivCtxt tc) $
tcSimplifyThetas deriv_rhs
- | (_,tc,_,deriv_rhs) <- orig_eqns ]
+ | (_, _,tc,_,deriv_rhs) <- orig_eqns ]
) `thenTc` \ next_solns ->
-- Canonicalise the solutions, so they compare nicely
- let canonicalised_next_solns
- = [ sortLt (<) next_soln | next_soln <- next_solns ]
+ let canonicalised_next_solns = [ sortLt (<) next_soln | next_soln <- next_solns ]
in
- returnTc (new_inst_infos, canonicalised_next_solns)
+ returnTc (new_dfuns, canonicalised_next_solns)
\end{code}
\begin{code}
-add_solns :: Bag InstInfo -- The global, non-derived ones
+add_solns :: InstEnv -- The global, non-derived ones
-> [DerivEqn] -> [DerivSoln]
- -> NF_TcM ([InstInfo], -- The new, derived ones
- InstEnv)
+ -> ([DFunId], InstEnv)
-- the eqns and solns move "in lockstep"; we have the eqns
-- because we need the LHS info for addClassInstance.
-add_solns inst_infos_in eqns solns
-
- = discardErrsTc (buildInstanceEnv all_inst_infos) `thenNF_Tc` \ inst_env ->
- -- We do the discard-errs so that we don't get repeated error messages
- -- about duplicate instances.
- -- They'll appear later, when we do the top-level buildInstanceEnv.
-
- returnNF_Tc (new_inst_infos, inst_env)
+add_solns inst_env_in eqns solns
+ = (new_dfuns, inst_env)
where
- new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns
-
- all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
-
- mk_deriv_inst_info (clas, tycon, tyvars, _) theta
- = InstInfo clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)]
- theta'
- dummy_dfun_id
- (my_panic "binds") (getSrcLoc tycon)
- (my_panic "upragmas")
- where
- dummy_dfun_id
- = mkVanillaId (getName tycon) dummy_dfun_ty
- -- The name is getSrcLoc'd in an error message
-
- theta' = classesToPreds theta
- dummy_dfun_ty = mkSigmaTy tyvars theta' voidTy
- -- All we need from the dfun is its "theta" part, used during
- -- equation simplification (tcSimplifyThetas). The final
- -- dfun_id will have the superclass dictionaries as arguments too,
- -- but that'll be added after the equations are solved. For now,
- -- it's enough just to make a dummy dfun with the simple theta part.
- --
- -- The part after the theta is dummied here as voidTy; actually it's
- -- (C (T a b)), but it doesn't seem worth constructing it.
- -- We can't leave it as a panic because to get the theta part we
- -- have to run down the type!
-
- my_panic str = panic "add_soln" -- pprPanic ("add_soln:"++str) (hsep [char ':', ppr clas, ppr tycon])
+ new_dfuns = zipWithEqual "add_solns" mk_deriv_dfun eqns solns
+ (inst_env, _) = extendInstEnv inst_env_in
+ -- Ignore the errors about duplicate instances.
+ -- We don't want repeated error messages
+ -- They'll appear later, when we do the top-level extendInstEnvs
+
+ mk_deriv_dfun (dfun_name clas, tycon, tyvars, _) theta
+ = mkDictFunId dfun_name clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)] theta
\end{code}
%************************************************************************
-- Generate the method bindings for the required instance
-- (paired with class name, as we need that when generating dict
-- names.)
-gen_bind :: GlobalSymbolTable -> InstInfo -> RdrNameMonoBinds
+gen_bind :: GlobalSymbolTable -> DFunId -> RdrNameMonoBinds
gen_bind fixities inst
| not (isLocallyDefined tycon) = EmptyMonoBinds
| clas `hasKey` showClassKey = gen_Show_binds fixities tycon
(classKey clas)
tycon
where
- clas = instInfoClass inst
- tycon = simpleInstInfoTyCon inst
+ (clas, tycon) = simpleDFunClassTyCon dfun
\end{code}
If we have a @tag2con@ function, we also generate a @maxtag@ constant.
\begin{code}
-gen_taggery_Names :: [InstInfo]
+gen_taggery_Names :: [DFunId]
-> TcM [(RdrName, -- for an assoc list
- TyCon, -- related tycon
- TagThingWanted)]
+ TyCon, -- related tycon
+ TagThingWanted)]
-gen_taggery_Names inst_infos
- = --pprTrace "gen_taggery:\n" (vcat [hsep [ppr c, ppr t] | (c,t) <- all_CTs]) $
- foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
+gen_taggery_Names dfuns
+ = foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
foldlTc do_tag2con names_so_far tycons_of_interest
where
- all_CTs = [ (instInfoClass info, simpleInstInfoTyCon info) | info <- inst_infos ]
-
+ all_CTs = map simplDFunClassTyCon dfuns
all_tycons = map snd all_CTs
(tycons_of_interest, _) = removeDups compare all_tycons
Gather up the instance declarations from their various sources
\begin{code}
-tcInstDecls1 :: PersistentRenamerState
+tcInstDecls1 :: PersistentCompilerState
+ -> HomeSymbolTable -- Contains instances
-> TcEnv -- Contains IdInfo for dfun ids
- -> [RenamedHsDecl]
-> Module -- Module for deriving
- -> FixityEnv -- For derivings
- -> RnNameSupply -- For renaming derivings
- -> TcM (Bag InstInfo,
- RenamedHsBinds)
-
-tcInstDecls1 prs unf_env decls mod
- = -- (1) Do the ordinary instance declarations
- mapNF_Tc (tcInstDecl1 mod unf_env)
- [inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags ->
- let
- decl_inst_info = unionManyBags inst_info_bags
- in
- -- (2) Instances from "deriving" clauses; note that we only do derivings
- -- for things in this module; we ignore deriving decls from
- -- interfaces!
- tcDeriving prs mod decl_inst_info `thenTc` \ (deriv_inst_info, deriv_binds) ->
-
- -- (3) Instances from generic class declarations
- mapTc (getGenericInstances mod)
- [cl_decl | TyClD cl_decl <- decls, isClassDecl cl_decl] `thenTc` \ cls_inst_info ->
+ -> [RenamedHsDecl]
+ -> TcM (PersistentCompilerState, InstEnv, [InstInfo], RenamedHsBinds)
+tcInstDecls1 pcs hst unf_env this_mod decls mod
+ = let
+ inst_decls = [inst_decl | InstD inst_decl <- decls]
+ clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl cl_decl]
+ in
+ -- (1) Do the ordinary instance declarations
+ mapNF_Tc (tcInstDecl1 mod) inst_decls `thenNF_Tc` \ inst_infos ->
+
+ -- (2) Instances from generic class declarations
+ getGenericInstances mod clas_decls `thenTc` \ generic_inst_info ->
+
+ -- Next, consruct the instance environment so far, consisting of
+ -- a) cached non-home-package InstEnv (gotten from pcs) pcsInsts pcs
+ -- b) imported instance decls (not in the home package) inst_env1
+ -- c) other modules in this package (gotten from hst) inst_env2
+ -- d) local instance decls inst_env3
+ -- e) generic instances inst_env4
+ -- The result of (b) replaces the cached InstEnv in the PCS
let
- generic_insts = concat cls_inst_info
- full_inst_info = deriv_inst_info `unionBags`
- unionManyBags inst_info_bags `unionBags`
- (listToBag generic_insts)
+ (local_inst_info, imported_inst_info) = partition isLocalInst (concat inst_infos)
+ generic_inst_info = concat generic_inst_infos -- All local
+
+ imported_dfuns = map (tcAddImportedIdInfo unf_env . instInfoDFun) imported_inst_info
+ hst_dfuns = foldModuleEnv ((++) . mdInsts) [] hst
+ in
+ addInstDFuns (pcsInsts pcs) imported_dfuns `thenNF_Tc` \ inst_env1 ->
+ addInstDFuns inst_env1 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 ->
in
- ioToTc (dumpIfSet opt_D_dump_deriv "Generic instances"
- (vcat (map pprInstInfo generic_insts))) `thenNF_Tc_`
- (returnTc (full_inst_info, deriv_binds))
+ -- (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; hecne inst_env4
+ tcDeriving (pcsPRS pcs) this_mod inst_env4 local_tycons `thenTc` \ (deriv_inst_info, deriv_binds) ->
+ addInstInfos inst_env4 deriv_inst_info `thenNF_Tc` \ final_inst_env ->
+
+ returnTc (pcs { pcsInsts = inst_env1 },
+ final_inst_env,
+ generic_inst_info ++ deriv_inst_info ++ local_inst_info,
+ deriv_binds)
+
+addInstInfos :: InstEnv -> [InstInfo] -> NF_TcM InstEnv
+addInstInfos inst_env infos = addInstDfuns inst_env (map iDFun infos)
+
+addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv
+addInstDFuns dfuns infos
+ = addErrsTc errs `thenNF_Tc_`
+ returnTc inst_env'
+ where
+ (inst_env', errs) = extendInstEnv env dfuns
\end{code}
\begin{code}
-tcInstDecl1 :: Module -> ValueEnv -> RenamedInstDecl -> NF_TcM (Bag InstInfo)
+tcInstDecl1 :: Module -> ValueEnv -> RenamedInstDecl -> NF_TcM [InstInfo]
-- Deal with a single instance declaration
tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
= -- Prime error recovery, set source location
- recoverNF_Tc (returnNF_Tc emptyBag) $
+ recoverNF_Tc (returnNF_Tc []) $
tcAddSrcLoc src_loc $
-- Type-check all the stuff before the "where"
-- Make the dfun id and return it
newDFunName mod clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
- returnNF_Tc (mkDictFunId dfun_name clas tyvars inst_tys theta)
+ returnNF_Tc (True, mkDictFunId dfun_name clas tyvars inst_tys theta)
Just dfun_name -> -- An interface-file instance declaration
- -- Make the dfun id and add info from interface file
- let
- dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
- in
- returnNF_Tc (tcAddImportedIdInfo unf_env dfun_id)
- ) `thenNF_Tc` \ dfun_id ->
-
- returnTc (unitBag (InstInfo clas tyvars inst_tys theta dfun_id binds src_loc uprags))
+ -- Make the dfun id
+ returnNF_Tc (False, mkDictFunId dfun_name clas tyvars inst_tys theta)
+ ) `thenNF_Tc` \ (is_local, dfun_id) ->
+
+ returnTc [InstInfo { iLocal = is_local,
+ iClass = clas, iTyVars = tyvars, iTys = inst_tys,
+ iTheta = theta, iDFunId = dfun_id,
+ iBinds = binds, iLoc = src_loc, iPrags = uprags }]
\end{code}
\begin{code}
-getGenericInstances :: Module -> RenamedTyClDecl -> TcM [InstInfo]
-getGenericInstances mod decl@(ClassDecl context class_name tyvar_names
- fundeps class_sigs def_methods pragmas
- name_list loc)
+getGenericInstances :: Module -> [RenamedTyClDecl] -> TcM [InstInfo]
+getGenericInstances mod class_decls
+ = mapTc (get_generics mod) class_decls `thenTc` \ gen_inst_infos ->
+ let
+ gen_inst_info = concat gen_inst_infos
+ in
+ ioToTc (dumpIfSet opt_D_dump_deriv "Generic instances"
+ (vcat (map pprInstInfo gen_inst_info))) `thenNF_Tc_`
+ returnTc gen_inst_info
+
+get_generics mod decl@(ClassDecl context class_name tyvar_names
+ fundeps class_sigs def_methods pragmas
+ name_list loc)
| null groups
- = returnTc [] -- The comon case
+ = returnTc [] -- The comon case:
+ -- no generic default methods, or
+ -- its an imported class decl (=> has no methods at all)
- | otherwise
+ | otherwise -- A local class decl with generic default methods
= recoverNF_Tc (returnNF_Tc []) $
tcAddDeclCtxt decl $
tcLookupClass class_name `thenTc` \ clas ->
dfun_id = mkDictFunId dfun_name clas tyvars inst_tys inst_theta
in
- returnTc (InstInfo clas tyvars inst_tys inst_theta dfun_id binds loc [])
- -- The "[]" means "no pragmas"
+ returnTc (InstInfo { iLocal = True,
+ iClass = clas, iTyVars = tyvars, iTys = inst_tys,
+ iTheta = inst_theta, iDFunId = dfun_id, iBinds = binds,
+ iLoc = loc, iPrags = [] })
\end{code}
\begin{code}
tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds)
-tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
- inst_decl_theta
- dfun_id monobinds
- locn uprags)
+tcInstDecl2 (InstInfo { iClass = clas, iTyVars = inst_tyvars, iTys = inst_tys,
+ iTheta = inst_decl_theta, iDFunId = dfun_id,
+ iBinds = monobinds, iLoc = locn, iPrags = uprags })
| not (isLocallyDefined dfun_id)
= returnNF_Tc (emptyLIE, EmptyMonoBinds)
\begin{code}
module TcInstUtil (
InstInfo(..), pprInstInfo,
- instInfoClass, simpleInstInfoTy, simpleInstInfoTyCon,
+ simpleInstInfoTy, simpleInstInfoTyCon,
-- Instance environment
- InstEnv, emptyInstEnv, buildInstanceEnv,
+ InstEnv, emptyInstEnv, extendInstEnv,
lookupInstEnv, InstLookupResult(..),
classInstEnv, classDataCon
) where
\begin{code}
data InstInfo
- = InstInfo
- Class -- Class, k
- [TyVar] -- Type variables, tvs
- [Type] -- The types at which the class is being instantiated
- ThetaType -- inst_decl_theta: the original context, c, from the
- -- instance declaration. It constrains (some of)
- -- the TyVars above
- Id -- The dfun id
- RenamedMonoBinds -- Bindings, b
- SrcLoc -- Source location assoc'd with this instance's defn
- [RenamedSig] -- User pragmas recorded for generating specialised instances
-
-pprInstInfo (InstInfo clas tvs tys inst_decl_theta _ mbinds _ _)
- = vcat [ptext SLIT("InstInfo:") <+> ppr (mkSigmaTy tvs inst_decl_theta (mkDictTy clas tys)),
- nest 4 (ppr mbinds)]
-
-instInfoClass :: InstInfo -> Class
-instInfoClass (InstInfo clas _ _ _ _ _ _ _) = clas
+ = InstInfo {
+ iClass :: Class, -- Class, k
+ iTyVars :: [TyVar], -- Type variables, tvs
+ iTys :: [Type], -- The types at which the class is being instantiated
+ iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the
+ -- instance declaration. It constrains (some of)
+ -- the TyVars above
+ iLocal :: Bool, -- True <=> it's defined in this module
+ iDFunId :: DFunId, -- The dfun id
+ iBinds :: RenamedMonoBinds, -- Bindings, b
+ iLoc :: SrcLoc -- Source location assoc'd with this instance's defn
+ iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances
+ }
+
+pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)),
+ nest 4 (ppr (iBinds info))]
simpleInstInfoTy :: InstInfo -> Type
-simpleInstInfoTy (InstInfo _ _ [ty] _ _ _ _ _) = ty
+simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty
simpleInstInfoTyCon :: InstInfo -> TyCon
-- Gets the type constructor for a simple instance declaration,
simpleInstInfoTyCon inst
= case splitTyConApp_maybe (simpleInstInfoTy inst) of
Just (tycon, _) -> tycon
+
+isLocalInst :: InstInfo -> Bool
+isLocalInst info = iLocal info
\end{code}
It makes a nasty mutual-recursion knot if you put it in Class.
\begin{code}
+simpleDFunClassTyCon :: DFunId -> (Class, TyCon)
+simpleDFunClassTyCon dfun
+ = (clas, tycon)
+ where
+ (_,_,dict_ty) = splitSigmaTy (idType dfun)
+ (clas, [ty]) = splitDictTy dict_ty
+ tycon = case splitTyConApp_maybe ty of
+ Just (tycon,_) -> tycon
+
classDataCon :: Class -> DataCon
classDataCon clas = case tyConDataCons (classTyCon clas) of
(dict_constr:no_more) -> ASSERT( null no_more ) dict_constr
%************************************************************************
%* *
-\subsection{Converting instance info into suitable InstEnvs}
-%* *
-%************************************************************************
-
-\begin{code}
-buildInstanceEnv :: Bag InstInfo -> NF_TcM InstEnv
-
-buildInstanceEnv info = --pprTrace "BuildInstanceEnv" (ppr info)
- foldrNF_Tc addClassInstance emptyInstEnv (bagToList info)
-\end{code}
-
-@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
-based on information from a single instance declaration. It complains
-about any overlap with an existing instance.
-
-\begin{code}
-addClassInstance
- :: InstInfo
- -> InstEnv
- -> NF_TcM InstEnv
-
-addClassInstance
- (InstInfo clas inst_tyvars inst_tys _
- dfun_id _ src_loc _)
- inst_env
- = -- Add the instance to the class's instance environment
- case addToInstEnv opt_AllowOverlappingInstances
- inst_env clas inst_tyvars inst_tys dfun_id of
- Failed (tys', dfun_id') -> addErrTc (dupInstErr clas (inst_tys, dfun_id)
- (tys', dfun_id'))
- `thenNF_Tc_`
- returnNF_Tc inst_env
-
- Succeeded inst_env' -> returnNF_Tc inst_env'
-\end{code}
-
-\begin{code}
-dupInstErr clas info1@(tys1, dfun1) info2@(tys2, dfun2)
- -- Overlapping/duplicate instances for given class; msg could be more glamourous
- = hang (ptext SLIT("Duplicate or overlapping instance declarations"))
- 4 (sep [ptext SLIT("for") <+> quotes (pprConstraint clas tys1),
- nest 4 (sep [ppr_loc dfun1, ptext SLIT("and") <+> ppr_loc dfun2])])
- where
- ppr_loc dfun
- | isLocallyDefined dfun = ptext SLIT("defined at") <+> ppr (getSrcLoc dfun)
- | otherwise = ptext SLIT("imported from module") <+> quotes (ppr (nameModule (idName dfun)))
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Instance environments: InstEnv and ClsInstEnv}
%* *
%************************************************************************
not if they unify but neither is
\begin{code}
-addToInstEnv :: Bool -- True <=> overlap permitted
- -> InstEnv -- Envt
- -> Class -> [TyVar] -> [Type] -> Id -- New item
- -> MaybeErr InstEnv -- Success...
- ([Type], Id) -- Failure: Offending overlap
+extendInstEnv :: InstEnv -> [DFunId] -> (InstEnv, [Message])
+ -- Similar, but all we have is the DFuns
+extendInstEnvWithDFuns env infos
+ = go env [] infos
+ where
+ go env msgs [] = (env, msgs)
+ go env msgs (dfun:dfuns) = case addToInstEnv inst_env dfun of
+ Succeeded new_env -> go new_env msgs dfuns
+ Failed dfun' -> go env (msg:msgs) infos
+ where
+ msg = dupInstErr dfun dfun'
+
-addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value
+dupInstErr dfun1 dfun2
+ -- Overlapping/duplicate instances for given class; msg could be more glamourous
+ = hang (ptext SLIT("Duplicate or overlapping instance declarations:"))
+ 2 (ppr_dfun dfun1 $$ ppr_dfun dfun2)
+ where
+ ppr_dfun dfun = ppr (getSrcLoc dfun) <> colon <+> ppr tau
+ where
+ (_,_,tau) = splitSigmaTy (idType dfun)
+
+addToInstEnv :: InstEnv -> DFunId
+ -> MaybeErr InstEnv -- Success...
+ DFunId -- Failure: Offending overlap
+
+addToInstEnv inst_env dfun_id
= case insert_into (classInstEnv inst_env clas) of
Failed stuff -> Failed stuff
Succeeded new_env -> Succeeded (addToUFM inst_env clas new_env)
where
+ (ins_tvs, _, dict_ty) = splitSigmaTy (idType dfun_id)
+ (clas, ins_tys) = splitDictTy dict_ty
+
ins_tv_set = mkVarSet ins_tvs
- ins_item = (ins_tv_set, ins_tys, value)
+ ins_item = (ins_tv_set, ins_tys, dfun_id)
insert_into [] = returnMaB [ins_item]
insert_into env@(cur_item@(tpl_tvs, tpl_tys, val) : rest)
-- (b) they unify, and any sort of overlap is prohibited,
-- (c) they unify but neither is more specific than t'other
| identical
- || (unifiable && not overlap_ok)
+ || (unifiable && not opt_AllowOverlappingInstances)
|| (unifiable && not (ins_item_more_specific || cur_item_more_specific))
- = failMaB (tpl_tys, val)
+ = failMaB val
-- New item is an instance of current item, so drop it here
| ins_item_more_specific = returnMaB (ins_item : env)
import TcMonad
import Inst ( emptyLIE, plusLIE )
-import TcBinds ( tcTopBindsAndThen )
+import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv, tcLookupGlobal_maybe,
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import TcInstUtil ( buildInstanceEnv, InstInfo )
+import TcInstUtil ( InstInfo )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import TcTyDecls ( mkImplicitDataBinds )
import Util
import BasicTypes ( EP(..) )
import Bag ( Bag, isEmptyBag )
-import Outputable
+vimport Outputable
\end{code}
tc_pcs :: PersistentCompilerState, -- Augmented with imported information,
-- (but not stuff from this module)
tc_env :: TypeEnv, -- The TypeEnv just for the stuff from this module
+ tc_insts :: [DFunId], -- Instances, just for this module
tc_binds :: TypecheckedMonoBinds,
- tc_insts :: InstEnv, -- Instances, just for this module
tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports.
tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
}
-> RenamedHsModule
-> IO (Maybe (PersistentCompilerState, TcResults))
-typecheckModule pcs hst mod
- = do { us <- mkSplitUniqSupply 'a' ;
+typecheckModule pcs hst (HsModule mod_name _ _ _ decls _ src_loc)
+ = do { env <- initTcEnv global_symbol_table global_inst_env ;
- env <- initTcEnv global_symbol_table global_inst_env ;
-
- (maybe_result, warns, errs) <- initTc us env (tcModule (pcsPRS pcs) mod)
+ (_, (maybe_result, warns, errs)) <- initTc env src_loc tc_module
printErrorsAndWarnings errs warns ;
- case maybe_result of {
- Nothing -> return Nothing ;
- Just results -> do {
-
- dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) ;
- dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results) ;
+ printTcDumps maybe_result ;
if isEmptyBag errs then
return Nothing
- else
-
- let groups :: FiniteMap Module TypeEnv
- groups = groupTyThings (nameEnvElts (tc_env results))
-
- local_type_env :: TypeEnv
- local_type_env = lookupWithDefaultFM groups this_mod emptyNameEnv
-
- new_pst :: PackageSymbolTable
- new_pst = extendTypeEnv (pcsPST pcs) (delFromFM groups this_mod)
- ;
- return (Just (pcs {pcsPST = new_pst},
- results {tc_env = local_type_env}))
- }}}
+ else
+ return result
+ }
where
+ this_mod = mkThisModule
global_symbol_table = pcsPST pcs `plusModuleEnv` hst
- global_inst_env = foldModuleEnv (plusInstEnv . instEnv) (pcsInsts pcs) gst
- -- For now, make the total instance envt by simply
- -- folding together all the instances we can find anywhere
+ tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst this_mod decls unf_env)
\end{code}
The internal monster:
\begin{code}
-tcModule :: PersistentRenamerState
- -> RenamedHsModule -- input
- -> TcM TcResults -- output
-
-tcModule prs (HsModule mod_name _ _ _ decls _ src_loc)
- = tcAddSrcLoc src_loc $ -- record where we're starting
-
- fixTc (\ ~(unf_env ,_) ->
- -- (unf_env :: TcEnv) 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
-
- -- Type-check the type and class decls
- tcTyAndClassDecls unf_env decls `thenTc` \ env ->
- tcSetEnv env $
-
- -- Typecheck the instance decls, includes deriving
- tcInstDecls1 prs unf_env decls
- (mkThisModule mod_name) `thenTc` \ (inst_info, deriv_binds) ->
+tcModule :: PersistentCompilerState
+ -> HomeSymbolTable
+ -> Module
+ -> [RenamedHsDecl]
+ -> TcEnv -- The knot-tied environment
+ -> TcM TcResults
+
+ -- (unf_env :: TcEnv) 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
+
+tcModule pcs hst this_mod decls unf_env
+ = -- Type-check the type and class decls
+ tcTyAndClassDecls unf_env decls `thenTc` \ env ->
+ tcSetEnv env $
+ let
+ classes = tcEnvClasses env
+ tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes
+ local_classes = filter isLocallyDefined classes
+ local_tycons = [ tc | tc <- tycons,
+ isLocallyDefined tc,
+ not (isClassTyCon tc)
+ ]
+ -- For local_tycons, filter out the ones derived from classes
+ -- Otherwise the latter show up in interface files
+ in
+
+ -- Typecheck the instance decls, includes deriving
+ tcInstDecls1 pcs hst unf_env this_mod
+ local_tycons decls `thenTc` \ (pcs_with_insts, inst_env, inst_info, deriv_binds) ->
+ tcSetInstEnv inst_env $
+
+ -- Default declarations
+ tcDefaults decls `thenTc` \ defaulting_tys ->
+ tcSetDefaultTys defaulting_tys $
+
+ -- 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
+ -- We must do this before mkImplicitDataBinds (which comes next), since
+ -- the latter looks up unpackCStringId, for example, which is usually
+ -- imported
+ tcInterfaceSigs unf_env decls `thenTc` \ sig_ids ->
+ tcExtendGlobalValEnv sig_ids $
+
+ -- Create any necessary record selector Ids and their bindings
+ -- "Necessary" includes data and newtype declarations
+ -- We don't create bindings for dictionary constructors;
+ -- they are always fully applied, and the bindings are just there
+ -- to support partial applications
+ mkImplicitDataBinds tycons `thenTc` \ (data_ids, imp_data_binds) ->
+ mkImplicitClassBinds classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) ->
+
+ -- Extend the global value environment with
+ -- (a) constructors
+ -- (b) record selectors
+ -- (c) class op selectors
+ -- (d) default-method ids... where? I can't see where these are
+ -- put into the envt, and I'm worried that the zonking phase
+ -- will find they aren't there and complain.
+ tcExtendGlobalValEnv data_ids $
+ tcExtendGlobalValEnv cls_ids $
+
+ -- Foreign import declarations next
+ tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
+ tcExtendGlobalValEnv fo_ids $
+
+ -- Value declarations next.
+ -- We also typecheck any extra binds that came out of the "deriving" process
+ tcTopBinds (get_binds decls `ThenBinds` deriv_binds) `thenTc` \ ((val_binds, env), lie_valdecls) ->
+ tcSetEnv env $
- buildInstanceEnv inst_info `thenNF_Tc` \ inst_env ->
-
- tcSetInstEnv inst_env $
- let
- classes = tcEnvClasses env
- tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes
- local_classes = filter isLocallyDefined classes
- local_tycons = [ tc | tc <- tycons,
- isLocallyDefined tc,
- not (isClassTyCon tc)
- ]
- -- For local_tycons, filter out the ones derived from classes
- -- Otherwise the latter show up in interface files
- in
-
- -- Default declarations
- tcDefaults decls `thenTc` \ defaulting_tys ->
- tcSetDefaultTys defaulting_tys $
-
- -- 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
- -- We must do this before mkImplicitDataBinds (which comes next), since
- -- the latter looks up unpackCStringId, for example, which is usually
- -- imported
- tcInterfaceSigs unf_env decls `thenTc` \ sig_ids ->
- tcExtendGlobalValEnv sig_ids $
-
- -- Create any necessary record selector Ids and their bindings
- -- "Necessary" includes data and newtype declarations
- -- We don't create bindings for dictionary constructors;
- -- they are always fully applied, and the bindings are just there
- -- to support partial applications
- mkImplicitDataBinds tycons `thenTc` \ (data_ids, imp_data_binds) ->
- mkImplicitClassBinds classes `thenNF_Tc` \ (cls_ids, imp_cls_binds) ->
-
- -- Extend the global value environment with
- -- (a) constructors
- -- (b) record selectors
- -- (c) class op selectors
- -- (d) default-method ids... where? I can't see where these are
- -- put into the envt, and I'm worried that the zonking phase
- -- will find they aren't there and complain.
- tcExtendGlobalValEnv data_ids $
- tcExtendGlobalValEnv cls_ids $
-
- -- foreign import declarations next.
- tcForeignImports decls `thenTc` \ (fo_ids, foi_decls) ->
- tcExtendGlobalValEnv fo_ids $
-
- -- Value declarations next.
- -- We also typecheck any extra binds that came out of the "deriving" process
- tcTopBindsAndThen
- (\ is_rec binds1 (binds2, thing) -> (binds1 `AndMonoBinds` binds2, thing))
- (get_val_decls decls `ThenBinds` deriv_binds)
- ( tcGetEnv `thenNF_Tc` \ env ->
- returnTc ((EmptyMonoBinds, env), emptyLIE)
- ) `thenTc` \ ((val_binds, final_env), lie_valdecls) ->
- tcSetEnv final_env $
-
- -- foreign export declarations next.
- tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
-
- -- Second pass over class and instance declarations,
- -- to compile the bindings themselves.
- tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
- tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
- tcRules decls `thenNF_Tc` \ (lie_rules, 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 defines main
- (if mod_name == mAIN_Name then
- tcLookupGlobal_maybe mainName `thenNF_Tc` \ maybe_main ->
- case maybe_main of
- Just (AnId _) -> returnTc ()
- other -> addErrTc noMainErr
- else
- returnTc ()
- ) `thenTc_`
-
- -- Backsubstitution. This must be done last.
- -- Even tcSimplifyTop may do some unification.
- let
- all_binds = imp_data_binds `AndMonoBinds`
- imp_cls_binds `AndMonoBinds`
- val_binds `AndMonoBinds`
- inst_binds `AndMonoBinds`
- cls_dm_binds `AndMonoBinds`
- const_inst_binds `AndMonoBinds`
- foe_binds
- in
- zonkTopBinds all_binds `thenNF_Tc` \ (all_binds', really_final_env) ->
- tcSetEnv really_final_env $
- -- zonkTopBinds puts all the top-level Ids into the tcGEnv
-
- zonkForeignExports foe_decls `thenNF_Tc` \ foe_decls' ->
- zonkRules rules `thenNF_Tc` \ rules' ->
-
- returnTc (really_final_env,
- (TcResults { tc_env = tcGEnv really_final_env,
- tc_binds = all_binds',
- tc_insts = inst_info,
- tc_fords = foi_decls ++ foe_decls',
- tc_rules = rules'
- }))
-
- -- End of outer fix loop
- ) `thenTc` \ (final_env, stuff) ->
- returnTc stuff
-
-get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
+ -- Foreign export declarations next
+ tcForeignExports decls `thenTc` \ (lie_fodecls, foe_binds, foe_decls) ->
+
+ -- Second pass over class and instance declarations,
+ -- to compile the bindings themselves.
+ tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
+ tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
+ tcRules decls `thenNF_Tc` \ (lie_rules, 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 defines main
+ checkMain this_mod `thenTc_`
+
+ -- Backsubstitution. This must be done last.
+ -- Even tcSimplifyTop may do some unification.
+ let
+ all_binds = imp_data_binds `AndMonoBinds`
+ imp_cls_binds `AndMonoBinds`
+ val_binds `AndMonoBinds`
+ inst_binds `AndMonoBinds`
+ cls_dm_binds `AndMonoBinds`
+ const_inst_binds `AndMonoBinds`
+ foe_binds
+ in
+ 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 rules `thenNF_Tc` \ rules' ->
+
+
+ let groups :: FiniteMap Module TypeEnv
+ groups = groupTyThings (nameEnvElts (tcGEnv final_env))
+
+ local_type_env :: TypeEnv
+ local_type_env = lookupWithDefaultFM groups this_mod emptyNameEnv
+
+ new_pst :: PackageSymbolTable
+ new_pst = extendTypeEnv (pcsPST pcs) (delFromFM groups this_mod)
+
+ final_pcs :: PersistentCompilerState
+ final_pcs = pcs_with_insts {pcsPST = new_pst}
+ in
+ returnTc (really_final_env,
+ TcResults { tc_pcs = final_pcs,
+ tc_env = local_type_env,
+ tc_binds = all_binds',
+ tc_insts = map instInfoDfunId inst_infos,
+ tc_fords = foi_decls ++ foe_decls',
+ tc_rules = rules'
+ }))
+
+get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
\end{code}
\begin{code}
+checkMain :: Module -> TcM ()
+checkMain this_mod
+ | moduleName this_mod == mAIN_Name
+ = tcLookupGlobal_maybe mainName `thenNF_Tc` \ maybe_main ->
+ case maybe_main of
+ Just (AnId _) -> returnTc ()
+ other -> addErrTc noMainErr
+
+ | otherwise = returnTc ()
+
noMainErr
= hsep [ptext SLIT("Module"), quotes (pprModuleName mAIN_Name),
ptext SLIT("must include a definition for"), quotes (ptext SLIT("main"))]
%************************************************************************
\begin{code}
+printTcDump Nothing = return ()
+printTcDump (Just results)
+ = do { dumpIfSet opt_D_dump_types "Type signatures" (dump_sigs results) ;
+ dumpIfSet opt_D_dump_tc "Typechecked" (dump_tc results)
+ }
+
dump_tc results
= vcat [ppr (tc_binds results),
pp_rules (tc_rules results),
listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
- failTc, failWithTc, addErrTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
+ failTc, failWithTc, addErrTc, addErrsTc, warnTc, recoverTc, checkNoErrsTc, recoverNF_Tc, discardErrsTc,
addErrTcM, addInstErrTcM, failWithTcM,
tcGetEnv, tcSetEnv,
\end{code}
\begin{code}
--- initEnv is passed in to avoid module recursion between TcEnv & TcMonad.
-
-initTc :: UniqSupply
- -> (TcRef (UniqFM a) -> TcEnv)
+initTc :: TcEnv
+ -> SrcLoc
-> TcM r
-> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
-initTc us initenv do_this
+initTc tc_env src_loc do_this
= do {
+ us <- mkSplitUniqSupply 'a' ;
us_var <- newIORef us ;
dfun_var <- newIORef emptyFM ;
errs_var <- newIORef (emptyBag,emptyBag) ;
let
init_down = TcDown [] us_var dfun_var
- noSrcLoc
+ src_loc
[] errs_var
- init_env = initenv tvs_var
;
- maybe_res <- catch (do { res <- do_this init_down init_env ;
+ maybe_res <- catch (do { res <- do_this init_down env ;
return (Just res)})
(\_ -> return Nothing) ;
addErrTc :: Message -> NF_TcM ()
addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg)
+addErrsTc :: [Message] -> NF_TcM ()
+addErrsTc [] = returnNF_Tc ()
+addErrsTc err_msgs = listNF_Tc_ (map addErrTc err_msgs) `thenNF_Tc_` returnNF_Tc ()
+
-- The 'M' variants do the TidyEnv bit
failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail
failWithTcM env_and_msg
-- Predicates and the like
mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe,
- splitDictTy_maybe, isDictTy, predRepTy,
+ splitDictTy, splitDictTy_maybe, isDictTy, predRepTy,
mkSynTy, isSynTy, deNoteType,
splitPredTy_maybe (PredTy p) = Just p
splitPredTy_maybe other = Nothing
+splitDictTy :: Type -> (Class, [Type])
+splitDictTy (NoteTy _ ty) = splitDictTy ty
+splitDictTy (PredTy (Class clas tys)) = (clas, tys)
+
splitDictTy_maybe :: Type -> Maybe (Class, [Type])
-splitDictTy_maybe ty = case splitPredTy_maybe ty of
- Just p -> getClassTys_maybe p
- Nothing -> Nothing
+splitDictTy_maybe (NoteTy _ ty) = splitDictTy ty
+splitDictTy_maybe (PredTy (Class clas tys)) = Just (clas, tys)
+splitDictTy_maybe other = Nothing
getClassTys_maybe :: PredType -> Maybe ClassPred
getClassTys_maybe (Class clas tys) = Just (clas, tys)
projects / ghc-hetmet.git / commitdiff