projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2000-03-24 17:49:29 by simonpj]
[ghc-hetmet.git]
/
ghc
/
compiler
/
typecheck
/
TcInstDcls.lhs
diff --git
a/ghc/compiler/typecheck/TcInstDcls.lhs
b/ghc/compiler/typecheck/TcInstDcls.lhs
index
5bd3471
..
0d9ffac
100644
(file)
--- a/
ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/
ghc/compiler/typecheck/TcInstDcls.lhs
@@
-14,7
+14,7
@@
import HsSyn ( HsDecl(..), InstDecl(..),
andMonoBindList
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
andMonoBindList
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
-import TcHsSyn ( TcMonoBinds,
+import TcHsSyn ( TcMonoBinds, mkHsConApp,
maybeBoxedPrimType
)
maybeBoxedPrimType
)
@@
-23,7
+23,8
@@
import TcClassDcl ( tcMethodBind, checkFromThisClass )
import TcMonad
import RnMonad ( RnNameSupply, Fixities )
import Inst ( Inst, InstOrigin(..),
import TcMonad
import RnMonad ( RnNameSupply, Fixities )
import Inst ( Inst, InstOrigin(..),
- newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
+ newDicts, newClassDicts,
+ LIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcInstId
import TcDeriv ( tcDeriving )
import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths,
tcAddImportedIdInfo, tcInstId
@@
-39,7
+40,7
@@
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances )
import Class ( classBigSig, Class )
import Var ( idName, idType, Id, TyVar )
import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances )
import Class ( classBigSig, Class )
import Var ( idName, idType, Id, TyVar )
-import DataCon ( isNullaryDataCon, splitProductType_maybe, dataConId )
+import DataCon ( isNullaryDataCon, splitProductType_maybe )
import Maybes ( maybeToBool, catMaybes, expectJust )
import MkId ( mkDictFunId )
import Module ( ModuleName )
import Maybes ( maybeToBool, catMaybes, expectJust )
import MkId ( mkDictFunId )
import Module ( ModuleName )
@@
-48,14
+49,15
@@
import NameSet ( emptyNameSet )
import PrelInfo ( eRROR_ID )
import PprType ( pprConstraint )
import SrcLoc ( SrcLoc )
import PrelInfo ( eRROR_ID )
import PprType ( pprConstraint )
import SrcLoc ( SrcLoc )
-import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
+import TyCon ( isSynTyCon, tyConDerivings )
import Type ( Type, isUnLiftedType, mkTyVarTys,
splitSigmaTy, isTyVarTy,
import Type ( Type, isUnLiftedType, mkTyVarTys,
splitSigmaTy, isTyVarTy,
- splitTyConApp_maybe, splitDictTy_maybe, unUsgTy,
- splitAlgTyConApp_maybe,
- tyVarsOfTypes
+ splitTyConApp_maybe, splitDictTy_maybe,
+ getClassTys_maybe, splitAlgTyConApp_maybe,
+ classesToPreds, classesOfPreds,
+ unUsgTy, tyVarsOfTypes
)
)
-import Subst ( mkTopTyVarSubst, substTheta )
+import Subst ( mkTopTyVarSubst, substClasses )
import VarSet ( mkVarSet, varSetElems )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( stringTy )
import VarSet ( mkVarSet, varSetElems )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( stringTy )
@@
-175,9
+177,10
@@
tcInstDecl1 unf_env (InstDecl poly_ty binds uprags dfun_name src_loc)
tcHsTopType poly_ty `thenTc` \ poly_ty' ->
let
(tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
tcHsTopType poly_ty `thenTc` \ poly_ty' ->
let
(tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
- (clas, inst_tys) = case splitDictTy_maybe dict_ty of
- Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
- Just pair -> pair
+ constr = classesOfPreds theta
+ (clas, inst_tys) = case splitDictTy_maybe dict_ty of
+ Just ct -> ct
+ Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
in
-- Check for respectable instance type, and context
in
-- Check for respectable instance type, and context
@@
-187,19
+190,19
@@
tcInstDecl1 unf_env (InstDecl poly_ty binds uprags dfun_name src_loc)
-- instance CCallable [Char]
(if isLocallyDefined dfun_name then
scrutiniseInstanceHead clas inst_tys `thenNF_Tc_`
-- instance CCallable [Char]
(if isLocallyDefined dfun_name then
scrutiniseInstanceHead clas inst_tys `thenNF_Tc_`
- mapNF_Tc scrutiniseInstanceConstraint theta
+ mapNF_Tc scrutiniseInstanceConstraint constr
else
returnNF_Tc []
) `thenNF_Tc_`
-- Make the dfun id
let
else
returnNF_Tc []
) `thenNF_Tc_`
-- Make the dfun id
let
- dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
+ dfun_id = mkDictFunId dfun_name clas tyvars inst_tys constr
-- Add info from interface file
final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
in
-- Add info from interface file
final_dfun_id = tcAddImportedIdInfo unf_env dfun_id
in
- returnTc (unitBag (InstInfo clas tyvars inst_tys theta
+ returnTc (unitBag (InstInfo clas tyvars inst_tys constr
final_dfun_id
binds src_loc uprags))
\end{code}
final_dfun_id
binds src_loc uprags))
\end{code}
@@
-324,22
+327,22
@@
tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
origin = InstanceDeclOrigin
origin = InstanceDeclOrigin
- (class_tyvars, sc_theta, sc_sel_ids, op_items) = classBigSig clas
+ (class_tyvars, sc_theta, _, op_items) = classBigSig clas
dm_ids = [dm_id | (_, dm_id, _) <- op_items]
-- Instantiate the theta found in the original instance decl
dm_ids = [dm_id | (_, dm_id, _) <- op_items]
-- Instantiate the theta found in the original instance decl
- inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars'))
- inst_decl_theta
+ inst_decl_theta' = substClasses (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars'))
+ inst_decl_theta
-- Instantiate the super-class context with inst_tys
-- Instantiate the super-class context with inst_tys
- sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
+ sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
in
-- Create dictionary Ids from the specified instance contexts.
in
-- Create dictionary Ids from the specified instance contexts.
- newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
+ newClassDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) ->
- newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
- newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
+ newClassDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
+ newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
-- Check that all the method bindings come from this class
checkFromThisClass clas op_items monobinds `thenNF_Tc_`
-- Check that all the method bindings come from this class
checkFromThisClass clas op_items monobinds `thenNF_Tc_`
@@
-348,8
+351,9
@@
tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
tcExtendGlobalValEnv dm_ids (
-- Default-method Ids may be mentioned in synthesised RHSs
tcExtendGlobalValEnv dm_ids (
-- Default-method Ids may be mentioned in synthesised RHSs
- mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' inst_decl_theta'
- monobinds uprags True)
+ mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys'
+ (classesToPreds inst_decl_theta')
+ monobinds uprags True)
op_items
)) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
op_items
)) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
@@
-435,13
+439,12
@@
tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
(HsLitOut (HsString msg) stringTy)
| otherwise -- The common case
(HsLitOut (HsString msg) stringTy)
| otherwise -- The common case
- = foldl HsApp (TyApp (HsVar (dataConId dict_constr)) inst_tys')
- (map HsVar (sc_dict_ids ++ meth_ids))
+ = mkHsConApp dict_constr inst_tys' (map HsVar (sc_dict_ids ++ meth_ids))
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
-- We do this rather than generate an HsCon directly, because
-- it means that the special cases (e.g. dictionary with only one
-- We don't produce a binding for the dict_constr; instead we
-- rely on the simplifier to unfold this saturated application
-- We do this rather than generate an HsCon directly, because
-- it means that the special cases (e.g. dictionary with only one
- -- member) are dealt with by the common MkId.mkDataConId code rather
+ -- member) are dealt with by the common MkId.mkDataConWrapId code rather
-- than needing to be repeated here.
where
-- than needing to be repeated here.
where
@@
-585,7
+588,7
@@
creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
\begin{code}
instConstraintErr clas tys
\begin{code}
instConstraintErr clas tys
- = hang (ptext SLIT("Illegal constaint") <+>
+ = hang (ptext SLIT("Illegal constraint") <+>
quotes (pprConstraint clas tys) <+>
ptext SLIT("in instance context"))
4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
quotes (pprConstraint clas tys) <+>
ptext SLIT("in instance context"))
4 (ptext SLIT("(Instance contexts must constrain only type variables)"))