projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix scoped type variables for expression type signatures
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcClassDcl.lhs
diff --git
a/compiler/typecheck/TcClassDcl.lhs
b/compiler/typecheck/TcClassDcl.lhs
index
31e3d5a
..
9d0fb13
100644
(file)
--- a/
compiler/typecheck/TcClassDcl.lhs
+++ b/
compiler/typecheck/TcClassDcl.lhs
@@
-7,7
+7,7
@@
module TcClassDcl ( tcClassSigs, tcClassDecl2,
getGenericInstances,
MethodSpec, tcMethodBind, mkMethodBind,
module TcClassDcl ( tcClassSigs, tcClassDecl2,
getGenericInstances,
MethodSpec, tcMethodBind, mkMethodBind,
- tcAddDeclCtxt, badMethodErr
+ tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
#include "HsVersions.h"
) where
#include "HsVersions.h"
@@
-16,7
+16,7
@@
import HsSyn
import RnHsSyn ( maybeGenericMatch, extractHsTyVars )
import RnExpr ( rnLExpr )
import RnEnv ( lookupTopBndrRn, lookupImportedName )
import RnHsSyn ( maybeGenericMatch, extractHsTyVars )
import RnExpr ( rnLExpr )
import RnEnv ( lookupTopBndrRn, lookupImportedName )
-import Inst ( instToId, newDicts, newDictsAtLoc, newMethod, getOverlapFlag )
+import Inst ( instToId, newDictBndr, newDictBndrs, newMethod, getOverlapFlag )
import InstEnv ( mkLocalInstance )
import TcEnv ( tcLookupLocatedClass,
tcExtendTyVarEnv, tcExtendIdEnv,
import InstEnv ( mkLocalInstance )
import TcEnv ( tcLookupLocatedClass,
tcExtendTyVarEnv, tcExtendIdEnv,
@@
-246,9
+246,13
@@
tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
-- default methods. Better to make separate AbsBinds for each
let
(tyvars, _, _, op_items) = classBigSig clas
-- default methods. Better to make separate AbsBinds for each
let
(tyvars, _, _, op_items) = classBigSig clas
+ rigid_info = ClsSkol clas
+ origin = SigOrigin rigid_info
prag_fn = mkPragFun sigs
sig_fn = mkTcSigFun sigs
prag_fn = mkPragFun sigs
sig_fn = mkTcSigFun sigs
- tc_dm = tcDefMeth clas tyvars default_binds sig_fn prag_fn
+ clas_tyvars = tcSkolSigTyVars rigid_info tyvars
+ tc_dm = tcDefMeth origin clas clas_tyvars
+ default_binds sig_fn prag_fn
dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
-- Generate code for polymorphic default methods only
dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
-- Generate code for polymorphic default methods only
@@
-261,19
+265,17
@@
tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) ->
returnM (listToBag defm_binds, concat dm_ids_s)
mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) ->
returnM (listToBag defm_binds, concat dm_ids_s)
-tcDefMeth clas tyvars binds_in sig_fn prag_fn sel_id
+tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
= do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
= do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
- ; let rigid_info = ClsSkol clas
- clas_tyvars = tcSkolSigTyVars rigid_info tyvars
- inst_tys = mkTyVarTys clas_tyvars
+ ; let inst_tys = mkTyVarTys tyvars
dm_ty = idType sel_id -- Same as dict selector!
dm_ty = idType sel_id -- Same as dict selector!
- theta = [mkClassPred clas inst_tys]
+ cls_pred = mkClassPred clas inst_tys
local_dm_id = mkDefaultMethodId dm_name dm_ty
local_dm_id = mkDefaultMethodId dm_name dm_ty
- origin = SigOrigin rigid_info
; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
- ; [this_dict] <- newDicts origin theta
- ; (defm_bind, insts_needed) <- getLIE (tcMethodBind clas_tyvars theta [this_dict]
+ ; loc <- getInstLoc origin
+ ; this_dict <- newDictBndr loc cls_pred
+ ; (defm_bind, insts_needed) <- getLIE (tcMethodBind tyvars [cls_pred] [this_dict]
sig_fn prag_fn meth_info)
; addErrCtxt (defltMethCtxt clas) $ do
sig_fn prag_fn meth_info)
; addErrCtxt (defltMethCtxt clas) $ do
@@
-281,12
+283,12
@@
tcDefMeth clas tyvars binds_in sig_fn prag_fn sel_id
-- Check the context
{ dict_binds <- tcSimplifyCheck
(ptext SLIT("class") <+> ppr clas)
-- Check the context
{ dict_binds <- tcSimplifyCheck
(ptext SLIT("class") <+> ppr clas)
- clas_tyvars
+ tyvars
[this_dict]
insts_needed
-- Simplification can do unification
[this_dict]
insts_needed
-- Simplification can do unification
- ; checkSigTyVars clas_tyvars
+ ; checkSigTyVars tyvars
-- Inline pragmas
-- We'll have an inline pragma on the local binding, made by tcMethodBind
-- Inline pragmas
-- We'll have an inline pragma on the local binding, made by tcMethodBind
@@
-297,9
+299,9
@@
tcDefMeth clas tyvars binds_in sig_fn prag_fn sel_id
inline_prags = filter isInlineLSig (prag_fn sel_name)
; prags <- tcPrags dm_inst_id inline_prags
inline_prags = filter isInlineLSig (prag_fn sel_name)
; prags <- tcPrags dm_inst_id inline_prags
- ; let full_bind = AbsBinds clas_tyvars
+ ; let full_bind = AbsBinds tyvars
[instToId this_dict]
[instToId this_dict]
- [(clas_tyvars, local_dm_id, dm_inst_id, prags)]
+ [(tyvars, local_dm_id, dm_inst_id, prags)]
(dict_binds `unionBags` defm_bind)
; returnM (noLoc full_bind, [local_dm_id]) }}
(dict_binds `unionBags` defm_bind)
; returnM (noLoc full_bind, [local_dm_id]) }}
@@
-374,7
+376,7
@@
tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn
in
addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
in
addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
- newDictsAtLoc (sig_loc sig) (sig_theta sig) `thenM` \ meth_dicts ->
+ newDictBndrs (sig_loc sig) (sig_theta sig) `thenM` \ meth_dicts ->
let
meth_tvs = sig_tvs sig
all_tyvars = meth_tvs ++ inst_tyvars
let
meth_tvs = sig_tvs sig
all_tyvars = meth_tvs ++ inst_tyvars
@@
-630,6
+632,8
@@
get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
-- f {| a+b |} ... = ...
-- f {| x+y |} ... = ...
-- Then at this point we'll have an InstInfo for each
-- f {| a+b |} ... = ...
-- f {| x+y |} ... = ...
-- Then at this point we'll have an InstInfo for each
+ --
+ -- The class should be unary, which is why simpleInstInfoTyCon should be ok
let
tc_inst_infos :: [(TyCon, InstInfo)]
tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
let
tc_inst_infos :: [(TyCon, InstInfo)]
tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
@@
-737,8
+741,12
@@
tcAddDeclCtxt decl thing_inside
thing = case decl of
ClassDecl {} -> "class"
TySynonym {} -> "type synonym"
thing = case decl of
ClassDecl {} -> "class"
TySynonym {} -> "type synonym"
- TyData {tcdND = NewType} -> "newtype"
- TyData {tcdND = DataType} -> "data type"
+ TyFunction {} -> "type function signature"
+ TyData {tcdND = NewType} -> "newtype" ++ maybeSig
+ TyData {tcdND = DataType} -> "data type" ++ maybeSig
+
+ maybeSig | isKindSigDecl decl = " signature"
+ | otherwise = ""
ctxt = hsep [ptext SLIT("In the"), text thing,
ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
ctxt = hsep [ptext SLIT("In the"), text thing,
ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
@@
-753,9
+761,16
@@
badMethodErr clas op
= hsep [ptext SLIT("Class"), quotes (ppr clas),
ptext SLIT("does not have a method"), quotes (ppr op)]
= hsep [ptext SLIT("Class"), quotes (ppr clas),
ptext SLIT("does not have a method"), quotes (ppr op)]
+badATErr clas at
+ = hsep [ptext SLIT("Class"), quotes (ppr clas),
+ ptext SLIT("does not have an associated type"), quotes (ppr at)]
+
omittedMethodWarn sel_id
= ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
omittedMethodWarn sel_id
= ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
+omittedATWarn at
+ = ptext SLIT("No explicit AT declaration for") <+> quotes (ppr at)
+
badGenericInstance sel_id because
= sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
because]
badGenericInstance sel_id because
= sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
because]