projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Implement -X=GADTs and -X=RelaxedPolyRec
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcInstDcls.lhs
diff --git
a/compiler/typecheck/TcInstDcls.lhs
b/compiler/typecheck/TcInstDcls.lhs
index
ac5c896
..
0dbb775
100644
(file)
--- a/
compiler/typecheck/TcInstDcls.lhs
+++ b/
compiler/typecheck/TcInstDcls.lhs
@@
-147,9
+147,8
@@
tcInstDecls1 tycl_decls inst_decls deriv_decls
-- (they recover, so that we get more than one error each
-- round)
-- (they recover, so that we get more than one error each
-- round)
- -- (1) Do class instance declarations and instances of indexed
- -- types
- ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls }
+ -- (1) Do class and family instance declarations
+ ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
; idx_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls
; idx_tycons <- mappM tcIdxTyInstDeclTL idxty_decls
@@
-193,7
+192,7
@@
tcInstDecls1 tycl_decls inst_decls deriv_decls
-- !!!TODO: Need to perform this check for the TyThing of type functions,
-- too.
tcIdxTyInstDeclTL ldecl@(L loc decl) =
-- !!!TODO: Need to perform this check for the TyThing of type functions,
-- too.
tcIdxTyInstDeclTL ldecl@(L loc decl) =
- do { tything <- tcIdxTyInstDecl ldecl
+ do { tything <- tcFamInstDecl ldecl
; setSrcSpan loc $
when (isAssocFamily tything) $
addErr $ assocInClassErr (tcdName decl)
; setSrcSpan loc $
when (isAssocFamily tything) $
addErr $ assocInClassErr (tcdName decl)
@@
-221,7
+220,7
@@
addFamInsts tycons thing_inside
mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
(ppr tything)
mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
(ppr tything)
-\end{code}
+\end{code}
\begin{code}
tcLocalInstDecl1 :: LInstDecl Name
\begin{code}
tcLocalInstDecl1 :: LInstDecl Name
@@
-240,14
+239,10
@@
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
badBootDeclErr
; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
badBootDeclErr
- -- Typecheck the instance type itself. We can't use
- -- tcHsSigType, because it's not a valid user type.
- ; kinded_ty <- kcHsSigType poly_ty
- ; poly_ty' <- tcHsKindedType kinded_ty
- ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
+ ; (tyvars, theta, tau) <- tcHsInstHead poly_ty
-- Next, process any associated types.
-- Next, process any associated types.
- ; idx_tycons <- mappM tcIdxTyInstDecl ats
+ ; idx_tycons <- mappM tcFamInstDecl ats
-- Now, check the validity of the instance.
; (clas, inst_tys) <- checkValidInstHead tau
-- Now, check the validity of the instance.
; (clas, inst_tys) <- checkValidInstHead tau
@@
-257,7
+252,7
@@
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
-- Finally, construct the Core representation of the instance.
-- (This no longer includes the associated types.)
-- Finally, construct the Core representation of the instance.
-- (This no longer includes the associated types.)
- ; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc)
+ ; dfun_name <- newDFunName clas inst_tys loc
; overlap_flag <- getOverlapFlag
; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
ispec = mkLocalInstance dfun overlap_flag
; overlap_flag <- getOverlapFlag
; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys
ispec = mkLocalInstance dfun overlap_flag
@@
-278,11
+273,11
@@
tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
checkValidAndMissingATs clas inst_tys ats
= do { -- Issue a warning for each class AT that is not defined in this
-- instance.
checkValidAndMissingATs clas inst_tys ats
= do { -- Issue a warning for each class AT that is not defined in this
-- instance.
- ; let classDefATs = listToNameSet . map tyConName . classATs $ clas
- definedATs = listToNameSet . map (tcdName.unLoc.fst) $ ats
- omitted = classDefATs `minusNameSet` definedATs
+ ; let class_ats = map tyConName (classATs clas)
+ defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
+ omitted = filterOut (`elemNameSet` defined_ats) class_ats
; warn <- doptM Opt_WarnMissingMethods
; warn <- doptM Opt_WarnMissingMethods
- ; mapM_ (warnTc warn . omittedATWarn) (nameSetToList omitted)
+ ; mapM_ (warnTc warn . omittedATWarn) omitted
-- Ensure that all AT indexes that correspond to class parameters
-- coincide with the types in the instance head. All remaining
-- Ensure that all AT indexes that correspond to class parameters
-- coincide with the types in the instance head. All remaining
@@
-483,7
+478,7
@@
tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id)
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
= do { let dfun_id = instanceDFunId ispec
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
= do { let dfun_id = instanceDFunId ispec
- rigid_info = InstSkol dfun_id
+ rigid_info = InstSkol
origin = SigOrigin rigid_info
inst_ty = idType dfun_id
; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
origin = SigOrigin rigid_info
inst_ty = idType dfun_id
; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
@@
-518,7
+513,8
@@
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
make_wrapper inst_loc tvs theta (Just preds) -- Case (a)
= ASSERT( null tvs && null theta )
do { dicts <- newDictBndrs inst_loc preds
make_wrapper inst_loc tvs theta (Just preds) -- Case (a)
= ASSERT( null tvs && null theta )
do { dicts <- newDictBndrs inst_loc preds
- ; sc_binds <- addErrCtxt superClassCtxt (tcSimplifySuperClasses [] [] dicts)
+ ; sc_binds <- addErrCtxt superClassCtxt $
+ tcSimplifySuperClasses inst_loc [] dicts
-- Use tcSimplifySuperClasses to avoid creating loops, for the
-- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify
; return (map instToId dicts, idHsWrapper, sc_binds) }
-- Use tcSimplifySuperClasses to avoid creating loops, for the
-- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify
; return (map instToId dicts, idHsWrapper, sc_binds) }
@@
-584,12
+580,13
@@
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds })
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
= let
dfun_id = instanceDFunId ispec
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
= let
dfun_id = instanceDFunId ispec
- rigid_info = InstSkol dfun_id
+ rigid_info = InstSkol
inst_ty = idType dfun_id
inst_ty = idType dfun_id
+ loc = srcLocSpan (getSrcLoc dfun_id)
in
-- Prime error recovery
recoverM (returnM emptyLHsBinds) $
in
-- Prime error recovery
recoverM (returnM emptyLHsBinds) $
- setSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $
+ setSrcSpan loc $
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
-- Instantiate the instance decl with skolem constants
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
-- Instantiate the instance decl with skolem constants
@@
-610,7
+607,7
@@
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
newDictBndrs sc_loc sc_theta' `thenM` \ sc_dicts ->
getInstLoc origin `thenM` \ inst_loc ->
newDictBndrs inst_loc dfun_theta' `thenM` \ dfun_arg_dicts ->
newDictBndrs sc_loc sc_theta' `thenM` \ sc_dicts ->
getInstLoc origin `thenM` \ inst_loc ->
newDictBndrs inst_loc dfun_theta' `thenM` \ dfun_arg_dicts ->
- newDictBndr inst_loc (mkClassPred clas inst_tys') `thenM` \ this_dict ->
+ newDictBndr inst_loc (mkClassPred clas inst_tys') `thenM` \ this_dict ->
-- Default-method Ids may be mentioned in synthesised RHSs,
-- but they'll already be in the environment.
-- Default-method Ids may be mentioned in synthesised RHSs,
-- but they'll already be in the environment.
@@
-626,9
+623,8
@@
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
-- Don't include this_dict in the 'givens', else
-- sc_dicts get bound by just selecting from this_dict!!
addErrCtxt superClassCtxt
-- Don't include this_dict in the 'givens', else
-- sc_dicts get bound by just selecting from this_dict!!
addErrCtxt superClassCtxt
- (tcSimplifySuperClasses inst_tyvars'
- dfun_arg_dicts
- sc_dicts) `thenM` \ sc_binds ->
+ (tcSimplifySuperClasses inst_loc
+ dfun_arg_dicts sc_dicts) `thenM` \ sc_binds ->
-- It's possible that the superclass stuff might unified one
-- of the inst_tyavars' with something in the envt
-- It's possible that the superclass stuff might unified one
-- of the inst_tyavars' with something in the envt
@@
-643,7
+639,7
@@
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
scs_and_meths = map instToId sc_dicts ++ meth_ids
this_dict_id = instToId this_dict
inline_prag | null dfun_arg_dicts = []
scs_and_meths = map instToId sc_dicts ++ meth_ids
this_dict_id = instToId this_dict
inline_prag | null dfun_arg_dicts = []
- | otherwise = [InlinePrag (Inline AlwaysActive True)]
+ | otherwise = [L loc (InlinePrag (Inline AlwaysActive True))]
-- Always inline the dfun; this is an experimental decision
-- because it makes a big performance difference sometimes.
-- Often it means we can do the method selection, and then
-- Always inline the dfun; this is an experimental decision
-- because it makes a big performance difference sometimes.
-- Often it means we can do the method selection, and then