From: lewie Date: Tue, 30 Nov 1999 16:10:26 +0000 (+0000) Subject: [project @ 1999-11-30 16:10:07 by lewie] X-Git-Tag: Approximately_9120_patches~5465 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=e1e1d0204ff754def1b3675f539372fd4691d78d;p=ghc-hetmet.git [project @ 1999-11-30 16:10:07 by lewie] First bits o' functional dependencies - just the syntax and related datatypes, plus started moving some of the static checks from the renamer (where we don't know about fundeps) to later in the typechecker. --- diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 32e0a8c..9a39e1b 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -30,6 +30,7 @@ import Var ( TyVar ) -- others: import PprType +import {-# SOURCE #-} FunDeps ( pprFundeps ) import Outputable import SrcLoc ( SrcLoc ) import Util @@ -85,7 +86,7 @@ hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x) tyClDeclName :: TyClDecl name pat -> name tyClDeclName (TyData _ _ name _ _ _ _ _) = name tyClDeclName (TySynonym name _ _ _) = name -tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ _) = name +tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ _ _) = name \end{code} \begin{code} @@ -131,6 +132,7 @@ data TyClDecl name pat | ClassDecl (Context name) -- context... name -- name of the class [HsTyVar name] -- the class type variables + [([name], [name])] -- functional dependencies [Sig name] -- methods' signatures (MonoBinds name pat) -- default methods (ClassPragmas name) @@ -143,7 +145,7 @@ data TyClDecl name pat countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int) -- class, data, newtype, synonym decls countTyClDecls decls - = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ _ <- decls], + = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ _ _ <- decls], length [() | TyData DataType _ _ _ _ _ _ _ <- decls], length [() | TyData NewType _ _ _ _ _ _ _ <- decls], length [() | TySynonym _ _ _ _ <- decls]) @@ -156,7 +158,7 @@ isSynDecl other = False isDataDecl (TyData _ _ _ _ _ _ _ _) = True isDataDecl other = False -isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _) = True +isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _ _) = True isClassDecl other = False \end{code} @@ -178,7 +180,7 @@ instance (Outputable name, Outputable pat) NewType -> SLIT("newtype") DataType -> SLIT("data") - ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ _ src_loc) + ppr (ClassDecl context clas tyvars fds sigs methods pragmas _ _ _ src_loc) | null sigs -- No "where" part = top_matter @@ -189,7 +191,7 @@ instance (Outputable name, Outputable pat) char '}'])] where top_matter = hsep [ptext SLIT("class"), pprContext context, - ppr clas, hsep (map (ppr) tyvars)] + ppr clas, hsep (map (ppr) tyvars), pprFundeps fds] ppr_sig sig = ppr sig <> semi diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index a733c0f..dc2a2cc 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -329,7 +329,7 @@ ppSourceStats short (HsModule name version exports imports decls src_loc) = (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds}) data_info other = (0,0) - class_info (ClassDecl _ _ _ meth_sigs def_meths _ _ _ _ _) + class_info (ClassDecl _ _ _ _ meth_sigs def_meths _ _ _ _ _) = case count_sigs meth_sigs of (_,classops,_,_) -> (classops, addpr (count_monobinds def_meths)) diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 99275c5..0f1bfe8 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -46,7 +46,7 @@ import OccName ( OccName, pprOccName ) import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConTheta, tyConTyVars, tyConDataCons ) -import Class ( Class, classBigSig ) +import Class ( Class, classExtraBigSig ) import FieldLabel ( fieldLabelName, fieldLabelType ) import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType, Type, ThetaType @@ -54,6 +54,7 @@ import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType, import PprType import PprCore ( pprIfaceUnfolding, pprCoreRule ) +import FunDeps ( pprFundeps ) import Rules ( pprProtoCoreRule, ProtoCoreRule(..) ) import Bag ( bagToList, isEmptyBag ) @@ -549,11 +550,12 @@ ifaceClass clas ppr_decl_context sc_theta, ppr clas, -- Print the name pprTyVarBndrs clas_tyvars, + pprFundeps clas_fds, pp_ops, semi ] where - (clas_tyvars, sc_theta, _, op_stuff) = classBigSig clas + (clas_tyvars, clas_fds, sc_theta, _, op_stuff) = classExtraBigSig clas pp_ops | null op_stuff = empty | otherwise = hsep [ptext SLIT("where"), diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 44dd9e9..811607a 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.16 1999/11/25 10:34:53 simonpj Exp $ +$Id: Parser.y,v 1.17 1999/11/30 16:10:11 lewie Exp $ Haskell grammar. @@ -324,14 +324,14 @@ topdecl :: { RdrBinding } (TyData NewType cs c ts [$5] $6 NoDataPragmas $1))) } - | srcloc 'class' ctype where + | srcloc 'class' ctype fds where {% checkDataHeader $3 `thenP` \(cs,c,ts) -> let (binds,sigs) = cvMonoBindsAndSigs cvClassOpSig - (groupBindings $4) + (groupBindings $5) in returnP (RdrHsDecl (TyClD - (mkClassDecl cs c ts sigs binds + (mkClassDecl cs c ts $4 sigs binds NoClassPragmas $1))) } | srcloc 'instance' inst_type where @@ -526,6 +526,21 @@ tyvars :: { [RdrNameHsTyVar] } : tyvars tyvar { UserTyVar $2 : $1 } | {- empty -} { [] } +fds :: { [([RdrName], [RdrName])] } + : {- empty -} { [] } + | '|' fds1 { reverse $2 } + +fds1 :: { [([RdrName], [RdrName])] } + : fds1 ',' fd { $3 : $1 } + | fd { [$1] } + +fd :: { ([RdrName], [RdrName]) } + : varids0 '->' varids0 { (reverse $1, reverse $3) } + +varids0 :: { [RdrName] } + : {- empty -} { [] } + | varids0 tyvar { $2 : $1 } + ----------------------------------------------------------------------------- -- Datatype declarations diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 6478ba1..23801c7 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -201,8 +201,8 @@ file (which would be equally good). Similarly for mkClassOpSig and default-method names. \begin{code} -mkClassDecl cxt cname tyvars sigs mbinds prags loc - = ClassDecl cxt cname tyvars sigs mbinds prags tname dname sc_sel_names loc +mkClassDecl cxt cname tyvars fds sigs mbinds prags loc + = ClassDecl cxt cname tyvars fds sigs mbinds prags tname dname sc_sel_names loc where cls_occ = rdrNameOcc cname dname = mkRdrUnqual (mkClassDataConOcc cls_occ) diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index df52ddd..e507f7e 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -302,8 +302,8 @@ decl : src_loc var_name '::' type maybe_idinfo { TyClD (TyData DataType $3 $4 $5 $6 Nothing noDataPragmas $1) } | src_loc 'newtype' decl_context tc_name tv_bndrs newtype_constr { TyClD (TyData NewType $3 $4 $5 $6 Nothing noDataPragmas $1) } - | src_loc 'class' decl_context tc_name tv_bndrs csigs - { TyClD (mkClassDecl $3 $4 $5 $6 EmptyMonoBinds + | src_loc 'class' decl_context tc_name tv_bndrs fds csigs + { TyClD (mkClassDecl $3 $4 $5 $6 $7 EmptyMonoBinds noClassPragmas $1) } | src_loc fixity mb_fix var_or_data_name { FixD (FixitySig $4 (Fixity $3 $2) $1) } @@ -581,6 +581,22 @@ tv_bndrs :: { [HsTyVar RdrName] } | tv_bndr tv_bndrs { $1 : $2 } --------------------------------------------------- +fds :: { [([RdrName], [RdrName])] } + : {- empty -} { [] } + | '|' fds1 { reverse $2 } + +fds1 :: { [([RdrName], [RdrName])] } + : fds1 ',' fd { $3 : $1 } + | fd { [$1] } + +fd :: { ([RdrName], [RdrName]) } + : varids0 '->' varids0 { (reverse $1, reverse $3) } + +varids0 :: { [RdrName] } + : {- empty -} { [] } + | varids0 tv_name { $2 : $1 } + +--------------------------------------------------- kind :: { Kind } : akind { $1 } | akind '->' kind { mkArrowKind $1 $3 } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 8926aeb..9893a3e 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -399,7 +399,7 @@ vars of the source program, and extracts from the decl the gate names. getGates source_fvs (SigD (IfaceSig _ ty _ _)) = extractHsTyNames ty -getGates source_fvs (TyClD (ClassDecl ctxt cls tvs sigs _ _ _ _ _ _)) +getGates source_fvs (TyClD (ClassDecl ctxt cls tvs _ sigs _ _ _ _ _ _)) = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) (map getTyVarName tvs) `addOneToNameSet` cls diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 2e10d79..e1c4d08 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -783,7 +783,7 @@ getDeclBinders new_name (TyClD (TySynonym tycon _ _ src_loc)) = new_name tycon src_loc `thenRn` \ tycon_name -> returnRn (Just (AvailTC tycon_name [tycon_name])) -getDeclBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ _ _ _ src_loc)) +getDeclBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ _ _ _ src_loc)) = new_name cname src_loc `thenRn` \ class_name -> -- Record the names for the class ops @@ -852,7 +852,7 @@ and the dict fun of an instance decl, because both of these have bindings of their own elsewhere. \begin{code} -getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ sigs _ _ tname dname snames src_loc)) +getDeclSysBinders new_name (TyClD (ClassDecl _ cname _ _ sigs _ _ tname dname snames src_loc)) = new_name dname src_loc `thenRn` \ datacon_name -> new_name tname src_loc `thenRn` \ tycon_name -> sequenceRn [new_name n src_loc | n <- snames] `thenRn` \ scsel_names -> diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 911718c..333cad9 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -331,7 +331,7 @@ fixitiesFromLocalDecls gbl_env decls getFixities acc (FixD fix) = fix_decl acc fix - getFixities acc (TyClD (ClassDecl _ _ _ sigs _ _ _ _ _ _)) + getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ _ _ _)) = foldlRn fix_decl acc [sig | FixSig sig <- sigs] -- Get fixities from class decl sigs too. getFixities acc other_decl diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index cb8861d..cbcd3dd 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -32,6 +32,8 @@ import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, ) import RnMonad +import FunDeps ( oclose ) + import Name ( Name, OccName, ExportFlag(..), Provenance(..), nameOccName, NamedThing(..) @@ -61,6 +63,8 @@ It also does the following error checks: \item Checks that tyvars are used properly. This includes checking for undefined tyvars, and tyvars in contexts that are ambiguous. +(Some of this checking has now been moved to module @TcMonoType@, +since we don't have functional dependency information at this point.) \item Checks that all variable occurences are defined. \item @@ -158,7 +162,7 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc)) where syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) -rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas +rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas tname dname snames src_loc)) = pushSrcLocRn src_loc $ @@ -181,6 +185,9 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas -- Check the superclasses rnContext cls_doc context `thenRn` \ (context', cxt_fvs) -> + -- Check the functional dependencies + rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) -> + -- Check the signatures let -- First process the class op sigs, then the fixity sigs. @@ -188,7 +195,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas (fix_sigs, non_sigs) = partition isFixitySig non_op_sigs in checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` - mapFvRn (rn_op cname' clas_tyvar_names) op_sigs + mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) -> mapRn_ (unknownSigErr) non_sigs `thenRn_` let @@ -208,11 +215,12 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas -- for instance decls. ASSERT(isNoClassPragmas pragmas) - returnRn (TyClD (ClassDecl context' cname' tyvars' (fixs' ++ sigs') mbinds' + returnRn (TyClD (ClassDecl context' cname' tyvars' fds' (fixs' ++ sigs') mbinds' NoClassPragmas tname' dname' snames' src_loc), sig_fvs `plusFV` fix_fvs `plusFV` cxt_fvs `plusFV` + fds_fvs `plusFV` meth_fvs ) ) @@ -225,7 +233,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas meth_rdr_names_w_locs = bagToList (collectMonoBinders mbinds) meth_rdr_names = map fst meth_rdr_names_w_locs - rn_op clas clas_tyvars sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn) + rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op dm_rdr_name explicit_dm ty locn) = pushSrcLocRn locn $ lookupBndrRn op `thenRn` \ op_name -> @@ -233,7 +241,7 @@ rnDecl (TyClD (ClassDecl context cname tyvars sigs mbinds pragmas rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) -> let check_in_op_ty clas_tyvar = - checkRn (clas_tyvar `elemNameSet` op_ty_fvs) + checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs) (classTyVarNotInOpTyErr clas_tyvar sig) in mapRn_ check_in_op_ty clas_tyvars `thenRn_` @@ -565,7 +573,7 @@ rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau) forall_tyvar_names = map getTyVarName forall_tyvars in - mapRn_ (forAllErr doc tau) bad_guys `thenRn_` + -- mapRn_ (forAllErr doc tau) bad_guys `thenRn_` mapRn_ (forAllWarn doc tau) warn_guys `thenRn_` checkConstraints doc forall_tyvar_names mentioned_in_tau ctxt tau `thenRn` \ ctxt' -> rnForAll doc forall_tyvars ctxt' tau @@ -583,16 +591,11 @@ checkConstraints doc forall_tyvars tau_vars ctxt ty -- Remove problem ones, to avoid duplicate error message. where check ct@(_,tys) - | ambiguous = failWithRn Nothing (ambigErr doc ct ty) | not_univ = failWithRn Nothing (univErr doc ct ty) | otherwise = returnRn (Just ct) where ct_vars = extractHsTysRdrTyVars tys - ambiguous = -- All the universally-quantified tyvars in the constraint must appear in the tau ty - -- (will change when we get functional dependencies) - not (all (\ct_var -> not (ct_var `elem` forall_tyvars) || ct_var `elem` tau_vars) ct_vars) - not_univ = -- At least one of the tyvars in each constraint must -- be universally quantified. This restriction isn't in Hugs not (any (`elem` forall_tyvars) ct_vars) @@ -692,6 +695,23 @@ rnContext doc ctxt = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2) \end{code} +\begin{code} +rnFds :: SDoc -> [([RdrName],[RdrName])] -> RnMS ([([Name],[Name])], FreeVars) + +rnFds doc fds + = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) -> + returnRn (theta, plusFVs fvs_s) + where + rn_fds (tys1, tys2) + = rnHsTyVars doc tys1 `thenRn` \ (tys1', fvs1) -> + rnHsTyVars doc tys2 `thenRn` \ (tys2', fvs2) -> + returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2) + +rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs +rnHsTyvar doc tyvar + = lookupOccRn tyvar `thenRn` \ tyvar' -> + returnRn (tyvar', unitFV tyvar') +\end{code} %********************************************************* %* * diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 8c0ac2a..6a64ece 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -482,7 +482,7 @@ is doing. %* * %************************************************************************ -@getTyVarsToGen@ decides what type variables generalise over. +@getTyVarsToGen@ decides what type variables to generalise over. For a "restricted group" -- see the monomorphism restriction for a definition -- we bind no dictionaries, and diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 6c0568c..a623b73 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -106,7 +106,7 @@ Death to "ExpandingDicts". \begin{code} kcClassDecl (ClassDecl context class_name - tyvar_names class_sigs def_methods pragmas + tyvar_names fundeps class_sigs def_methods pragmas tycon_name datacon_name sc_sel_names src_loc) = -- CHECK ARITY 1 FOR HASKELL 1.4 checkTc (opt_GlasgowExts || length tyvar_names == 1) @@ -138,7 +138,7 @@ kcClassDecl (ClassDecl context class_name \begin{code} tcClassDecl1 rec_env rec_inst_mapper rec_vrcs (ClassDecl context class_name - tyvar_names class_sigs def_methods pragmas + tyvar_names fundeps class_sigs def_methods pragmas tycon_name datacon_name sc_sel_names src_loc) = -- LOOK THINGS UP IN THE ENVIRONMENT tcLookupTy class_name `thenTc` \ (class_kind, _, AClass rec_class) -> @@ -151,6 +151,9 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs `thenTc` \ (sc_theta, sc_tys, sc_sel_ids) -> -- traceTc (text "tcClassCtxt done" <+> ppr class_name) `thenTc_` + -- CHECK THE FUNCTIONAL DEPENDENCIES, + tcFundeps fundeps `thenTc` \ fds -> + -- CHECK THE CLASS SIGNATURES, mapTc (tcClassSig rec_env rec_class tyvars) (filter isClassOpSig class_sigs) @@ -160,7 +163,7 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs let (op_tys, op_items) = unzip sig_stuff rec_class_inst_env = rec_inst_mapper rec_class - clas = mkClass class_name tyvars + clas = mkClass class_name tyvars fds sc_theta sc_sel_ids op_items tycon rec_class_inst_env @@ -199,6 +202,18 @@ tcClassDecl1 rec_env rec_inst_mapper rec_vrcs returnTc clas \end{code} +\begin{code} +tcFundeps = mapTc tc_fundep +tc_fundep (us, vs) = + mapTc tc_fd_tyvar us `thenTc` \ us' -> + mapTc tc_fd_tyvar vs `thenTc` \ vs' -> + returnTc (us', vs') +tc_fd_tyvar v = + tcLookupTy v `thenTc` \(_, _, thing) -> + case thing of + ATyVar tv -> returnTc tv + -- ZZ else should fail more gracefully +\end{code} \begin{code} tcClassContext :: Name -> Class -> [TyVar] @@ -324,7 +339,7 @@ tcClassDecl2 :: RenamedTyClDecl -- The class declaration -> NF_TcM s (LIE, TcMonoBinds) tcClassDecl2 (ClassDecl context class_name - tyvar_names class_sigs default_binds pragmas _ _ _ src_loc) + tyvar_names _ class_sigs default_binds pragmas _ _ _ src_loc) | not (isLocallyDefined class_name) = returnNF_Tc (emptyLIE, EmptyMonoBinds) diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 86963d3..bd94924 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -36,11 +36,13 @@ import Type ( Type, ThetaType, UsageAnn(..), mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy, boxedTypeKind, unboxedTypeKind, tyVarsOfType, mkArrowKinds, getTyVar_maybe, getTyVar, - tidyOpenType, tidyOpenTypes, tidyTyVar + tidyOpenType, tidyOpenTypes, tidyTyVar, + tyVarsOfType, tyVarsOfTypes ) +import PprType ( pprConstraint ) import Subst ( mkTopTyVarSubst, substTy ) import Id ( mkVanillaId, idName, idType, idFreeTyVars ) -import Var ( TyVar, mkTyVar, mkNamedUVar ) +import Var ( TyVar, mkTyVar, mkNamedUVar, varName ) import VarEnv import VarSet import Bag ( bagToList ) @@ -49,6 +51,7 @@ import PrelInfo ( cCallishClassKeys ) import TyCon ( TyCon ) import Name ( Name, OccName, isLocallyDefined ) import TysWiredIn ( mkListTy, mkTupleTy, mkUnboxedTupleTy ) +import UniqFM ( elemUFM, foldUFM ) import SrcLoc ( SrcLoc ) import Unique ( Unique, Uniquable(..) ) import Util ( zipWithEqual, zipLazy, mapAccumL ) @@ -182,9 +185,10 @@ tc_type_kind (MonoUsgForAllTy uv_name ty) returnTc (kind, mkUsForAllTy uv tc_ty) tc_type_kind (HsForAllTy (Just tv_names) context ty) - = tcExtendTyVarScope tv_names $ \ tyvars -> + = tcExtendTyVarScope tv_names $ \ tyvars -> tcContext context `thenTc` \ theta -> tc_type_kind ty `thenTc` \ (kind, tau) -> + tcGetInScopeTyVars `thenTc` \ in_scope_vars -> let body_kind | null theta = kind | otherwise = boxedTypeKind @@ -193,7 +197,16 @@ tc_type_kind (HsForAllTy (Just tv_names) context ty) -- give overloaded functions like -- f :: forall a. Num a => (# a->a, a->a #) -- And we want these to get through the type checker + check ct@(c,tys) | ambiguous = failWithTc (ambigErr ct tau) + | otherwise = returnTc () + where ct_vars = tyVarsOfTypes tys + forall_tyvars = map varName in_scope_vars + tau_vars = tyVarsOfType tau + ambig ct_var = (varName ct_var `elem` forall_tyvars) && + not (ct_var `elemUFM` tau_vars) + ambiguous = foldUFM ((||) . ambig) False ct_vars in + mapTc check theta `thenTc_` returnTc (body_kind, mkSigmaTy tyvars theta tau) \end{code} @@ -667,4 +680,9 @@ tyConAsClassErr name tyVarAsClassErr name = ptext SLIT("Type variable used as a class:") <+> ppr name + +ambigErr (c, ts) ty + = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprConstraint c ts), + nest 4 (ptext SLIT("for the type:") <+> ppr ty), + nest 4 (ptext SLIT("Each forall'd type variable mentioned by the constraint must appear after the =>."))] \end{code} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 5240d83..3535313 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -155,7 +155,7 @@ tcAddDeclCtxt decl thing_inside where (name, loc, thing) = case decl of - (ClassDecl _ name _ _ _ _ _ _ _ loc) -> (name, loc, "class") + (ClassDecl _ name _ _ _ _ _ _ _ _ loc) -> (name, loc, "class") (TySynonym name _ _ loc) -> (name, loc, "type synonym") (TyData NewType _ name _ _ _ _ loc) -> (name, loc, "data type") (TyData DataType _ name _ _ _ _ loc) -> (name, loc, "newtype") @@ -206,7 +206,7 @@ getTyBinding1 (TyData _ _ name tyvars _ _ _ _) Nothing, ATyCon (error "ATyCon: data"))) -getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _) +getTyBinding1 (ClassDecl _ name tyvars _ _ _ _ _ _ _ _) = mapNF_Tc kcHsTyVar tyvars `thenNF_Tc` \ arg_kinds -> returnNF_Tc (name, (foldr mkArrowKind boxedTypeKind arg_kinds, Just (length tyvars), @@ -271,7 +271,7 @@ Edges in Type/Class decls mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique]) -mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _) +mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _ _ _ _) = Just (decl, getUnique name, map (getUnique . fst) ctxt) mk_cls_edges other_decl = Nothing @@ -287,7 +287,7 @@ mk_edges decl@(TyData _ ctxt name _ condecls derivs _ _) mk_edges decl@(TySynonym name _ rhs _) = (decl, getUnique name, uniqSetToList (get_ty rhs)) -mk_edges decl@(ClassDecl ctxt name _ sigs _ _ _ _ _ _) +mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _ _ _ _) = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` get_sigs sigs)) diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 78661b1..4083f56 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -9,7 +9,7 @@ module Class ( mkClass, classTyVars, classKey, classSelIds, classTyCon, - classBigSig, classInstEnv + classBigSig, classExtraBigSig, classInstEnv, classTvsFds ) where #include "HsVersions.h" @@ -39,7 +39,8 @@ data Class classKey :: Unique, -- Key for fast comparison className :: Name, - classTyVars :: [TyVar], -- The class type variables + classTyVars :: [TyVar], -- The class type variables + classFunDeps :: [([TyVar], [TyVar])], -- The functional dependencies classSCTheta :: [(Class,[Type])], -- Immediate superclasses, and the classSCSels :: [Id], -- corresponding selector functions to @@ -63,17 +64,19 @@ The @mkClass@ function fills in the indirect superclasses. \begin{code} mkClass :: Name -> [TyVar] + -> [([TyVar], [TyVar])] -> [(Class,[Type])] -> [Id] -> [(Id, Id, Bool)] -> TyCon -> InstEnv -> Class -mkClass name tyvars super_classes superdict_sels +mkClass name tyvars fds super_classes superdict_sels op_stuff tycon class_insts = Class { classKey = getUnique name, className = name, classTyVars = tyvars, + classFunDeps = fds, classSCTheta = super_classes, classSCSels = superdict_sels, classOpStuff = op_stuff, @@ -93,9 +96,16 @@ The rest of these functions are just simple selectors. classSelIds (Class {classSCSels = sc_sels, classOpStuff = op_stuff}) = sc_sels ++ [op_sel | (op_sel, _, _) <- op_stuff] +classTvsFds c + = (classTyVars c, classFunDeps c) + classBigSig (Class {classTyVars = tyvars, classSCTheta = sc_theta, classSCSels = sc_sels, classOpStuff = op_stuff}) = (tyvars, sc_theta, sc_sels, op_stuff) +classExtraBigSig (Class {classTyVars = tyvars, classFunDeps = fundeps, + classSCTheta = sc_theta, classSCSels = sc_sels, + classOpStuff = op_stuff}) + = (tyvars, fundeps, sc_theta, sc_sels, op_stuff) \end{code}