import RnExpr
import HsSyn
import HsPragmas
-import HsTypes ( getTyVarName, pprClassAssertion, cmpHsTypes )
+import HsTypes ( getTyVarName, pprHsPred, cmpHsTypes )
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, isRdrTyVar )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl,
extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsTysRdrTyVars
import HsCore
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, unknownSigErr )
-import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn,
+import RnEnv ( bindTyVarsRn, lookupBndrRn, lookupOccRn, getIPName,
lookupImplicitOccRn,
bindLocalsRn, bindLocalRn, bindLocalsFVRn, bindUVarRn,
bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn,
)
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_`
-- context in which case it's an error
= let
mentioned_in_tau = extractHsTyRdrTyVars tau
- mentioned_in_ctxt = nub [tv | (_,tys) <- ctxt,
- ty <- tys,
+ mentioned_in_ctxt = nub [tv | p <- ctxt,
+ ty <- tys_of_pred p,
tv <- extractHsTyRdrTyVars ty]
+ tys_of_pred (HsPClass clas tys) = tys
+ tys_of_pred (HsPIParam n ty) = [ty]
dubious_guys = filter (`notElem` mentioned_in_tau) forall_tyvar_names
-- dubious = explicitly quantified but not mentioned in tau type
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
-- of the tau-type part, this guarantees that every constraint mentions
-- at least one of the free tyvars in ty
checkConstraints doc forall_tyvars tau_vars ctxt ty
- = mapRn check ctxt `thenRn` \ maybe_ctxt' ->
+ = mapRn (checkPred doc forall_tyvars ty) ctxt `thenRn` \ maybe_ctxt' ->
returnRn (catMaybes maybe_ctxt')
-- 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)
+checkPred doc forall_tyvars ty p@(HsPClass clas tys)
+ | not_univ = failWithRn Nothing (univErr doc p ty)
+ | otherwise = returnRn (Just p)
+ where
+ ct_vars = extractHsTysRdrTyVars tys
+ 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)
+checkPred doc forall_tyvars ty p@(HsPIParam _ _)
+ = returnRn (Just p)
rnForAll doc forall_tyvars ctxt ty
= bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars ->
rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars)
rnContext doc ctxt
- = mapAndUnzipRn rn_ctxt ctxt `thenRn` \ (theta, fvs_s) ->
+ = mapAndUnzipRn (rnPred doc) ctxt `thenRn` \ (theta, fvs_s) ->
let
- (_, dup_asserts) = removeDups cmp_assert theta
+ (_, dup_asserts) = removeDups (cmpHsPred compare) theta
in
-- Check for duplicate assertions
-- If this isn't an error, then it ought to be:
mapRn_ (addWarnRn . dupClassAssertWarn theta) dup_asserts `thenRn_`
returnRn (theta, plusFVs fvs_s)
- where
- rn_ctxt (clas, tys)
- = lookupOccRn clas `thenRn` \ clas_name ->
- rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
- returnRn ((clas_name, tys'), fvs `addOneFV` clas_name)
- cmp_assert (c1,tys1) (c2,tys2)
- = (c1 `compare` c2) `thenCmp` (cmpHsTypes compare tys1 tys2)
+rnPred doc (HsPClass clas tys)
+ = lookupOccRn clas `thenRn` \ clas_name ->
+ rnHsTypes doc tys `thenRn` \ (tys', fvs) ->
+ returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name)
+rnPred doc (HsPIParam n ty)
+ = getIPName n `thenRn` \ name ->
+ rnHsType doc ty `thenRn` \ (ty', fvs) ->
+ returnRn (HsPIParam name ty', fvs)
\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}
%*********************************************************
%* *
dupClassAssertWarn ctxt (assertion : dups)
= sep [hsep [ptext SLIT("Duplicate class assertion"),
- quotes (pprClassAssertion assertion),
+ quotes (pprHsPred assertion),
ptext SLIT("in the context:")],
- nest 4 (pprContext ctxt <+> ptext SLIT("..."))]
+ nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
badDataCon name
= hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
univErr doc constraint ty
= sep [ptext SLIT("All of the type variable(s) in the constraint")
- <+> quotes (pprClassAssertion constraint)
+ <+> quotes (pprHsPred constraint)
<+> ptext SLIT("are already in scope"),
nest 4 (ptext SLIT("At least one must be universally quantified here"))
]
(ptext SLIT("In") <+> doc)
ambigErr doc constraint ty
- = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprClassAssertion constraint),
+ = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprHsPred constraint),
nest 4 (ptext SLIT("in the type:") <+> ppr ty),
nest 4 (ptext SLIT("Each forall-d type variable mentioned by the constraint must appear after the =>."))]
$$
projects / ghc-hetmet.git / blobdiff