projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Adding pushing of hpc translation status through hi files.
[ghc-hetmet.git]
/
compiler
/
typecheck
/
TcTyClsDecls.lhs
diff --git
a/compiler/typecheck/TcTyClsDecls.lhs
b/compiler/typecheck/TcTyClsDecls.lhs
index
7623b19
..
3155e09
100644
(file)
--- a/
compiler/typecheck/TcTyClsDecls.lhs
+++ b/
compiler/typecheck/TcTyClsDecls.lhs
@@
-241,9
+241,9
@@
tcFamInstDecl (L loc decl)
tcAddDeclCtxt decl $
do { -- type families require -ftype-families and can't be in an
-- hs-boot file
tcAddDeclCtxt decl $
do { -- type families require -ftype-families and can't be in an
-- hs-boot file
- ; gla_exts <- doptM Opt_TypeFamilies
+ ; type_families <- doptM Opt_TypeFamilies
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file?
- ; checkTc gla_exts $ badFamInstDecl (tcdLName decl)
+ ; checkTc type_families $ badFamInstDecl (tcdLName decl)
; checkTc (not is_boot) $ badBootFamInstDeclErr
-- perform kind and type checking
; checkTc (not is_boot) $ badBootFamInstDeclErr
-- perform kind and type checking
@@
-693,7
+693,6
@@
tcTyClDecl1 calc_isrec
; stupid_theta <- tcHsKindedContext ctxt
; want_generic <- doptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
; stupid_theta <- tcHsKindedContext ctxt
; want_generic <- doptM Opt_Generics
; unbox_strict <- doptM Opt_UnboxStrictFields
- ; gla_exts <- doptM Opt_GlasgowExts
; empty_data_decls <- doptM Opt_EmptyDataDecls
; kind_signatures <- doptM Opt_KindSignatures
; gadt_ok <- doptM Opt_GADTs
; empty_data_decls <- doptM Opt_EmptyDataDecls
; kind_signatures <- doptM Opt_KindSignatures
; gadt_ok <- doptM Opt_GADTs
@@
-1058,19
+1057,20
@@
checkNewDataCon con
-------------------------------
checkValidClass :: Class -> TcM ()
checkValidClass cls
-------------------------------
checkValidClass :: Class -> TcM ()
checkValidClass cls
- = do { -- CHECK ARITY 1 FOR HASKELL 1.4
- gla_exts <- doptM Opt_GlasgowExts
+ = do { constrained_class_methods <- doptM Opt_ConstrainedClassMethods
; multi_param_type_classes <- doptM Opt_MultiParamTypeClasses
; multi_param_type_classes <- doptM Opt_MultiParamTypeClasses
+ ; fundep_classes <- doptM Opt_FunctionalDependencies
-- Check that the class is unary, unless GlaExs
; checkTc (notNull tyvars) (nullaryClassErr cls)
; checkTc (multi_param_type_classes || unary) (classArityErr cls)
-- Check that the class is unary, unless GlaExs
; checkTc (notNull tyvars) (nullaryClassErr cls)
; checkTc (multi_param_type_classes || unary) (classArityErr cls)
+ ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)
-- Check the super-classes
; checkValidTheta (ClassSCCtxt (className cls)) theta
-- Check the class operations
-- Check the super-classes
; checkValidTheta (ClassSCCtxt (className cls)) theta
-- Check the class operations
- ; mappM_ (check_op gla_exts) op_stuff
+ ; mappM_ (check_op constrained_class_methods) op_stuff
-- Check that if the class has generic methods, then the
-- class has only one parameter. We can't do generic
-- Check that if the class has generic methods, then the
-- class has only one parameter. We can't do generic
@@
-1078,11
+1078,11
@@
checkValidClass cls
; checkTc (unary || no_generics) (genericMultiParamErr cls)
}
where
; checkTc (unary || no_generics) (genericMultiParamErr cls)
}
where
- (tyvars, theta, _, op_stuff) = classBigSig cls
+ (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls
unary = isSingleton tyvars
no_generics = null [() | (_, GenDefMeth) <- op_stuff]
unary = isSingleton tyvars
no_generics = null [() | (_, GenDefMeth) <- op_stuff]
- check_op gla_exts (sel_id, dm)
+ check_op constrained_class_methods (sel_id, dm)
= addErrCtxt (classOpCtxt sel_id tau) $ do
{ checkValidTheta SigmaCtxt (tail theta)
-- The 'tail' removes the initial (C a) from the
= addErrCtxt (classOpCtxt sel_id tau) $ do
{ checkValidTheta SigmaCtxt (tail theta)
-- The 'tail' removes the initial (C a) from the
@@
-1110,11
+1110,11
@@
checkValidClass cls
op_ty = idType sel_id
(_,theta1,tau1) = tcSplitSigmaTy op_ty
(_,theta2,tau2) = tcSplitSigmaTy tau1
op_ty = idType sel_id
(_,theta1,tau1) = tcSplitSigmaTy op_ty
(_,theta2,tau2) = tcSplitSigmaTy tau1
- (theta,tau) | gla_exts = (theta1 ++ theta2, tau2)
- | otherwise = (theta1, mkPhiTy (tail theta1) tau1)
+ (theta,tau) | constrained_class_methods = (theta1 ++ theta2, tau2)
+ | otherwise = (theta1, mkPhiTy (tail theta1) tau1)
-- Ugh! The function might have a type like
-- op :: forall a. C a => forall b. (Eq b, Eq a) => tau2
-- Ugh! The function might have a type like
-- op :: forall a. C a => forall b. (Eq b, Eq a) => tau2
- -- With -fglasgow-exts, we want to allow this, even though the inner
+ -- With -XConstrainedClassMethods, we want to allow this, even though the inner
-- forall has an (Eq a) constraint. Whereas in general, each constraint
-- in the context of a for-all must mention at least one quantified
-- type variable. What a mess!
-- forall has an (Eq a) constraint. Whereas in general, each constraint
-- in the context of a for-all must mention at least one quantified
-- type variable. What a mess!
@@
-1141,6
+1141,10
@@
classArityErr cls
= vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
parens (ptext SLIT("Use -XMultiParamTypeClasses to allow multi-parameter classes"))]
= vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
parens (ptext SLIT("Use -XMultiParamTypeClasses to allow multi-parameter classes"))]
+classFunDepsErr cls
+ = vcat [ptext SLIT("Fundeps in class") <+> quotes (ppr cls),
+ parens (ptext SLIT("Use -XFunctionalDependencies to allow fundeps"))]
+
noClassTyVarErr clas op
= sep [ptext SLIT("The class method") <+> quotes (ppr op),
ptext SLIT("mentions none of the type variables of the class") <+>
noClassTyVarErr clas op
= sep [ptext SLIT("The class method") <+> quotes (ppr op),
ptext SLIT("mentions none of the type variables of the class") <+>