Commit f1080bc8 authored by simonpj's avatar simonpj

[project @ 2000-10-13 15:08:10 by simonpj]

Mainly typechecking instance decls
parent 064a65d9
......@@ -63,8 +63,8 @@ data ModDetails
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
......@@ -75,10 +75,9 @@ emptyModDetails mod
fixityEnv = emptyNameEnv,
deprecEnv = emptyNameEnv,
typeEnv = emptyNameEnv,
instEnv = emptyInstEnv,
ruleEnv = emptyRuleEnv
mdInsts = [],
mdRules = emptyRuleEnv
}
emptyRuleEnv = panic "emptyRuleEnv"
\end{code}
Symbol tables map modules to ModDetails:
......@@ -178,9 +177,12 @@ type GlobalRdrEnv = RdrNameEnv [Name] -- The list is because there may be name c
-- 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}
......
......@@ -4,7 +4,7 @@
\section[TcBinds]{TcBinds}
\begin{code}
module TcBinds ( tcBindsAndThen, tcTopBindsAndThen,
module TcBinds ( tcBindsAndThen, tcTopBinds,y
tcSpecSigs, tcBindWithSigs ) where
#include "HsVersions.h"
......@@ -95,14 +95,22 @@ At the top-level the LIE is sure to contain nothing but constant
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
......
This diff is collapsed.
......@@ -163,49 +163,74 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
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"
......@@ -230,17 +255,17 @@ tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
-- 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}
......@@ -275,14 +300,25 @@ gives rise to the instance declarations
\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 ->
......@@ -361,8 +397,10 @@ mkGenericInstance mod clas loc (hs_ty, binds)
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}
......@@ -454,10 +492,9 @@ First comes the easy case of a non-local instance decl.
\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)
......
......@@ -8,10 +8,10 @@ The bits common to TcInstDcls and TcDeriv.
\begin{code}
module TcInstUtil (
InstInfo(..), pprInstInfo,
instInfoClass, simpleInstInfoTy, simpleInstInfoTyCon,
simpleInstInfoTy, simpleInstInfoTyCon,
-- Instance environment
InstEnv, emptyInstEnv, buildInstanceEnv,
InstEnv, emptyInstEnv, extendInstEnv,
lookupInstEnv, InstLookupResult(..),
classInstEnv, classDataCon
) where
......@@ -52,27 +52,25 @@ The InstInfo type summarises the information in an instance declaration
\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,
......@@ -80,6 +78,9 @@ simpleInstInfoTyCon :: InstInfo -> TyCon
simpleInstInfoTyCon inst
= case splitTyConApp_maybe (simpleInstInfoTy inst) of
Just (tycon, _) -> tycon
isLocalInst :: InstInfo -> Bool
isLocalInst info = iLocal info
\end{code}
......@@ -87,62 +88,20 @@ A tiny function which doesn't belong anywhere else.
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
\end{code}
%************************************************************************
%* *
\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}
......@@ -355,20 +314,43 @@ True => overlap is permitted, but only if one template matches the other;
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)
......@@ -378,9 +360,9 @@ addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value
-- (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)
......
This diff is collapsed.
......@@ -21,7 +21,7 @@ module TcMonad(
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,
......@@ -123,15 +123,14 @@ type TcRef a = IORef a
\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) ;
......@@ -139,12 +138,11 @@ initTc us initenv do_this
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) ;
......@@ -303,6 +301,10 @@ failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg)
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
......
......@@ -33,7 +33,7 @@ module Type (
-- Predicates and the like
mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe,
splitDictTy_maybe, isDictTy, predRepTy,
splitDictTy, splitDictTy_maybe, isDictTy, predRepTy,
mkSynTy, isSynTy, deNoteType,
......@@ -689,10 +689,14 @@ splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
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)
......
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