-- others:
import PprType
+import {-# SOURCE #-} FunDeps ( pprFundeps )
import Outputable
import SrcLoc ( SrcLoc )
import Util
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}
| 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)
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])
isDataDecl (TyData _ _ _ _ _ _ _ _) = True
isDataDecl other = False
-isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _) = True
+isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _ _) = True
isClassDecl other = False
\end{code}
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
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
= (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))
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
import PprType
import PprCore ( pprIfaceUnfolding, pprCoreRule )
+import FunDeps ( pprFundeps )
import Rules ( pprProtoCoreRule, ProtoCoreRule(..) )
import Bag ( bagToList, isEmptyBag )
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"),
{-
-----------------------------------------------------------------------------
-$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.
(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
: 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
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)
{ 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) }
| 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 }
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
= 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
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 ->
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
)
import RnMonad
+import FunDeps ( oclose )
+
import Name ( Name, OccName,
ExportFlag(..), Provenance(..),
nameOccName, NamedThing(..)
\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
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 $
-- 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.
(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
-- 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
)
)
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 ->
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_`
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
-- 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)
= (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}
%*********************************************************
%* *
%* *
%************************************************************************
-@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
\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)
\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) ->
`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)
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
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]
-> 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)
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 )
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 )
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
-- 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}
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}
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")
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),
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
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))
mkClass, classTyVars,
classKey, classSelIds, classTyCon,
- classBigSig, classInstEnv
+ classBigSig, classExtraBigSig, classInstEnv, classTvsFds
) where
#include "HsVersions.h"
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
\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,
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}
projects / ghc-hetmet.git / commitdiff