X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=26e6dee936f88cd196c79a3bcb7798f96948a757;hb=3ca33229d4b9c1ed2829318631e73e748154f3ff;hp=cb8861d943980838429d467164f67910e53a5a26;hpb=a18aa9d7055561810945b810584b02f685c01089;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index cb8861d..26e6dee 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -11,7 +11,7 @@ module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) w 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 @@ -20,7 +20,7 @@ import RnHsSyn 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, @@ -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_` @@ -552,9 +560,11 @@ rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau) -- 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 @@ -565,7 +575,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 @@ -578,25 +588,20 @@ rnHsPolyType doc other_ty = rnHsType doc other_ty -- 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 -> @@ -673,25 +678,43 @@ rnHsTypes doc tys = mapFvRn (rnHsType doc) tys 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} %********************************************************* %* * @@ -882,9 +905,9 @@ classTyVarNotInOpTyErr clas_tyvar sig 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)] @@ -917,7 +940,7 @@ forAllErr doc ty tyvar 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")) ] @@ -925,7 +948,7 @@ univErr doc constraint ty (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 =>."))] $$