From: simonpj Date: Mon, 15 Mar 1999 15:11:11 +0000 (+0000) Subject: [project @ 1999-03-15 15:11:03 by simonpj] X-Git-Tag: Approximately_9120_patches~6392 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=42a51e933ba157f926d17404157e5fdc30890543;p=ghc-hetmet.git [project @ 1999-03-15 15:11:03 by simonpj] Make clear in HsType whether a for-all is explicit in the source program or not. Implicit for-alls now look like HsForAllTy Nothing ctxt ty while explicit ones look like HsForAllTy (Just tvs) ctxt ty Before this, the scope analysis stuff in RnSource was actually wrong (not that anyone had noticed), but Alex Ferguson did notice a bogus (sort-of-duplicate) error message on types like f :: Eq a => Int -> Int which led me to spot the deeper problem. Anyway, it's all cool now. --- diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 3f7237e..74e39e1 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -37,7 +37,7 @@ type ClassAssertion name = (name, [HsType name]) -- doesn't have to be when reading interface files data HsType name - = HsForAllTy [HsTyVar name] + = HsForAllTy (Maybe [HsTyVar name]) -- Nothing for implicitly quantified signatures (Context name) (HsType name) @@ -59,7 +59,7 @@ data HsType name [HsType name] mkHsForAllTy [] [] ty = ty -mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty +mkHsForAllTy tvs ctxt ty = HsForAllTy (Just tvs) ctxt ty data HsTyVar name = UserTyVar name @@ -120,9 +120,13 @@ pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc pprHsType ty = ppr_mono_ty pREC_TOP ty pprParendHsType ty = ppr_mono_ty pREC_CON ty -ppr_mono_ty ctxt_prec (HsForAllTy tvs ctxt ty) +ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty) = maybeParen (ctxt_prec >= pREC_FUN) $ sep [pprForAll tvs, pprContext ctxt, pprHsType ty] + where + tvs = case maybe_tvs of + Just tvs -> tvs + Nothing -> [] ppr_mono_ty ctxt_prec (MonoTyVar name) = ppr name @@ -179,8 +183,8 @@ cmpHsTypes cmp tys1 [] = GT cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2 cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2) - = cmpList (cmpHsTyVar cmp) tvs1 tvs2 `thenCmp` - cmpContext cmp c1 c2 `thenCmp` + = cmpMaybe (cmpList (cmpHsTyVar cmp)) tvs1 tvs2 `thenCmp` + cmpContext cmp c1 c2 `thenCmp` cmpHsType cmp t1 t2 cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2) @@ -221,4 +225,10 @@ cmpContext cmp a b where cmp_ctxt (c1, tys1) (c2, tys2) = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2 + +-- Should be in Maybes, I guess +cmpMaybe cmp Nothing Nothing = EQ +cmpMaybe cmp Nothing (Just x) = LT +cmpMaybe cmp (Just x) Nothing = GT +cmpMaybe cmp (Just x) (Just y) = x `cmp` y \end{code} diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 37984e8..4e4b317 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -507,7 +507,7 @@ instd : instkey inst_type maybe_where { $$ = mkibind($2,$3,startlineno); } /* Compare polytype */ /* [July 98: first production was tautype DARROW tautype, but I can't see why.] */ inst_type : apptype DARROW apptype { is_context_format( $3, 0 ); /* Check the instance head */ - $$ = mkforall(Lnil,type2context($1),$3); } + $$ = mkimp_forall(type2context($1),$3); } | apptype { is_context_format( $1, 0 ); /* Check the instance head */ $$ = $1; } ; @@ -705,7 +705,7 @@ polyatype : atype polytype : FORALL tyvars1 DOT apptype DARROW tautype { $$ = mkforall($2, type2context($4), $6); } | FORALL tyvars1 DOT tautype { $$ = mkforall($2, Lnil, $4); } - | apptype DARROW tautype { $$ = mkforall(Lnil, type2context($1), $3); } + | apptype DARROW tautype { $$ = mkimp_forall( type2context($1), $3); } | tautype ; diff --git a/ghc/compiler/parser/ttype.ugn b/ghc/compiler/parser/ttype.ugn index d89ee20..1058a99 100644 --- a/ghc/compiler/parser/ttype.ugn +++ b/ghc/compiler/parser/ttype.ugn @@ -25,5 +25,7 @@ type ttype; forall : < gtforalltv : list; /* tyvars */ gtforallctxt : list; /* theta */ gtforallt : ttype; >; + imp_forall : < gtiforallctxt : list ; /* Implicit forall; no explicit tyvars */ + gtiforallt : ttype; >; end; diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index 452e2a5..8091b74 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -115,17 +115,18 @@ extract_ctxt ctxt acc = foldr extract_ass acc ctxt where extract_ass (cls, tys) acc = foldr extract_ty acc tys -extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (MonoListTy ty) acc = extract_ty ty acc -extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys -extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (MonoDictTy cls tys) acc = foldr extract_ty acc tys -extract_ty (MonoTyVar tv) acc = insertTV tv acc -extract_ty (HsForAllTy tvs ctxt ty) acc = acc ++ - (filter (`notElem` locals) $ - extract_ctxt ctxt (extract_ty ty [])) - where - locals = map getTyVarName tvs +extract_ty (MonoTyApp ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (MonoListTy ty) acc = extract_ty ty acc +extract_ty (MonoTupleTy tys _) acc = foldr extract_ty acc tys +extract_ty (MonoFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (MonoDictTy cls tys) acc = foldr extract_ty acc tys +extract_ty (MonoTyVar tv) acc = insertTV tv acc +extract_ty (HsForAllTy (Just tvs) ctxt ty) + acc = acc ++ + (filter (`notElem` locals) $ + extract_ctxt ctxt (extract_ty ty [])) + where + locals = map getTyVarName tvs insertTV name acc | isRdrTyVar name = name : acc insertTV other acc = acc diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 9c68e07..edd0039 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -739,16 +739,21 @@ wlkHsSigType ttype -- make sure it starts with a ForAll case ty of HsForAllTy _ _ _ -> returnUgn ty - other -> returnUgn (HsForAllTy [] [] ty) + other -> returnUgn (HsForAllTy Nothing [] ty) wlkHsType :: U_ttype -> UgnM RdrNameHsType wlkHsType ttype = case ttype of - U_forall u_tyvars u_theta u_ty -> -- context + U_forall u_tyvars u_theta u_ty -> -- Explicit forall wlkList rdTvId u_tyvars `thenUgn` \ tyvars -> wlkContext u_theta `thenUgn` \ theta -> wlkHsType u_ty `thenUgn` \ ty -> - returnUgn (HsForAllTy (map UserTyVar tyvars) theta ty) + returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta ty) + + U_imp_forall u_theta u_ty -> -- Implicit forall + wlkContext u_theta `thenUgn` \ theta -> + wlkHsType u_ty `thenUgn` \ ty -> + returnUgn (HsForAllTy Nothing theta ty) U_namedtvar tv -> -- type variable wlkTvId tv `thenUgn` \ tyvar -> @@ -786,11 +791,16 @@ wlkInstType ttype wlkList rdTvId u_tyvars `thenUgn` \ tyvars -> wlkContext u_theta `thenUgn` \ theta -> wlkClsTys inst_head `thenUgn` \ (clas, tys) -> - returnUgn (HsForAllTy (map UserTyVar tyvars) theta (MonoDictTy clas tys)) + returnUgn (HsForAllTy (Just (map UserTyVar tyvars)) theta (MonoDictTy clas tys)) + + U_imp_forall u_theta inst_head -> + wlkContext u_theta `thenUgn` \ theta -> + wlkClsTys inst_head `thenUgn` \ (clas, tys) -> + returnUgn (HsForAllTy Nothing theta (MonoDictTy clas tys)) other -> -- something else wlkClsTys other `thenUgn` \ (clas, tys) -> - returnUgn (HsForAllTy [] [] (MonoDictTy clas tys)) + returnUgn (HsForAllTy Nothing [] (MonoDictTy clas tys)) \end{code} \begin{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index d723fd4..29abb3b 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -81,9 +81,11 @@ extractHsTyNames ty get (MonoFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 get (MonoDictTy cls tys) = unitNameSet cls `unionNameSets` extractHsTyNames_s tys get (MonoTyVar tv) = unitNameSet tv - get (HsForAllTy tvs ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty) + get (HsForAllTy (Just tvs) + ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty) `minusNameSet` mkNameSet (map getTyVarName tvs) + get ty@(HsForAllTy Nothing _ _) = pprPanic "extractHsTyNames" (ppr ty) extractHsTyNames_s :: [RenamedHsType] -> NameSet extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 1fd4d95..1dddb22 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -51,7 +51,7 @@ import Bag ( bagToList ) import Outputable import SrcLoc ( SrcLoc ) import UniqFM ( lookupUFM ) -import Maybes ( maybeToBool ) +import Maybes ( maybeToBool, catMaybes ) import Util \end{code} @@ -271,8 +271,8 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc)) rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) -> let inst_tyvars = case inst_ty' of - HsForAllTy inst_tyvars _ _ -> inst_tyvars - other -> [] + HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars + other -> [] -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too in @@ -495,59 +495,59 @@ rnIfaceType doc ty = rnHsType doc ty `thenRn` \ (ty,_) -> returnRn ty + +rnForAll doc forall_tyvars ctxt ty + = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars -> + rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) -> + rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) -> + returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty, + cxt_fvs `plusFV` ty_fvs) + +-- Check that each constraint mentions at least one of the forall'd type variables +-- Since the forall'd type variables are a subset of the free tyvars +-- of the tau-type part, this guarantees that every constraint mentions +-- at least one of the free tyvars in ty +checkConstraints explicit_forall doc forall_tyvars ctxt ty + = mapRn check ctxt `thenRn` \ maybe_ctxt' -> + returnRn (catMaybes maybe_ctxt') + -- Remove problem ones, to avoid duplicate error message. + where + check ct@(_,tys) + | forall_mentioned = returnRn (Just ct) + | otherwise = addErrRn (ctxtErr explicit_forall doc forall_tyvars ct ty) `thenRn_` + returnRn Nothing + where + forall_mentioned = foldr ((||) . any (`elem` forall_tyvars) . extractHsTyVars) + False + tys + + rnHsType :: SDoc -> RdrNameHsType -> RnMS s (RenamedHsType, FreeVars) -rnHsType doc (HsForAllTy [] ctxt ty) +rnHsType doc (HsForAllTy Nothing ctxt ty) -- From source code (no kinds on tyvars) - -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} - -- - -- We insist that the universally quantified type vars is a superset of FV(C) - -- It follows that FV(T) is a superset of FV(C), so that the context constrains - -- no type variables that don't appear free in the tau-type part. - = getLocalNameEnv `thenRn` \ name_env -> let mentioned_tyvars = extractHsTyVars ty forall_tyvars = filter (not . (`elemFM` name_env)) mentioned_tyvars - - ctxt_w_ftvs :: [((RdrName,[RdrNameHsType]), [RdrName])] - ctxt_w_ftvs = [ (constraint, foldr ((++) . extractHsTyVars) [] tys) - | constraint@(_,tys) <- ctxt] - - -- A 'non-poly constraint' is one that does not mention *any* - -- of the forall'd type variables - non_poly_constraints = filter non_poly ctxt_w_ftvs - non_poly (c,ftvs) = not (any (`elem` forall_tyvars) ftvs) - - -- A 'non-mentioned' constraint is one that mentions a - -- type variable that does not appear in 'ty' - non_mentioned_constraints = filter non_mentioned ctxt_w_ftvs - non_mentioned (c,ftvs) = any (not . (`elem` mentioned_tyvars)) ftvs - - -- Zap the context if there's a problem, to avoid duplicate error message. - ctxt' | null non_poly_constraints && null non_mentioned_constraints = ctxt - | otherwise = [] in - mapRn (ctxtErr1 doc forall_tyvars ty) non_poly_constraints `thenRn_` - mapRn (ctxtErr2 doc ty) non_mentioned_constraints `thenRn_` - - (bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ new_tyvars -> - rnContext doc ctxt' `thenRn` \ (new_ctxt, cxt_fvs) -> - rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) -> - returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty, - cxt_fvs `plusFV` ty_fvs) - ) - -rnHsType doc (HsForAllTy tvs ctxt ty) - -- tvs are non-empty, hence must be from an interface file - -- (tyvars may be kinded) - = bindTyVarsFVRn doc tvs $ \ new_tyvars -> - rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) -> - rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) -> - returnRn (mkHsForAllTy new_tyvars new_ctxt new_ty, - cxt_fvs `plusFV` ty_fvs) + checkConstraints False doc forall_tyvars ctxt ty `thenRn` \ ctxt' -> + rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty + +rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt ty) + -- Explicit quantification. + -- Check that the forall'd tyvars are a subset of the + -- free tyvars in the tau-type part + = let + mentioned_tyvars = extractHsTyVars ty + bad_guys = filter (`notElem` mentioned_tyvars) forall_tyvar_names + forall_tyvar_names = map getTyVarName forall_tyvars + in + mapRn (forAllErr doc ty) bad_guys `thenRn_` + checkConstraints True doc forall_tyvar_names ctxt ty `thenRn` \ ctxt' -> + rnForAll doc forall_tyvars ctxt' ty rnHsType doc (MonoTyVar tyvar) = lookupOccRn tyvar `thenRn` \ tyvar' -> @@ -791,23 +791,21 @@ dupClassAssertWarn ctxt (assertion : dups) badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] -ctxtErr1 doc tyvars ty (constraint, _) +forAllErr doc ty tyvar = addErrRn ( - sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+> - ptext SLIT("does not mention any of"), - nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars)), - nest 4 (ptext SLIT("of the type") <+> quotes (ppr ty)) - ] + sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), + nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))] $$ - (ptext SLIT("In") <+> doc) - ) + (ptext SLIT("In") <+> doc)) -ctxtErr2 doc ty (constraint,_) - = addErrRn ( - sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint), - nest 4 (ptext SLIT("mentions type variables that do not appear in the type")), - nest 4 (quotes (ppr ty))] - $$ - (ptext SLIT("In") <+> doc) - ) +ctxtErr explicit_forall doc tyvars constraint ty + = sep [ptext SLIT("The constraint") <+> quotes (pprClassAssertion constraint) <+> + ptext SLIT("does not mention any of"), + if explicit_forall then + nest 4 (ptext SLIT("the universally quantified type variables") <+> braces (interpp'SP tyvars)) + else + nest 4 (ptext SLIT("the type variables in the type") <+> quotes (ppr ty)) + ] + $$ + (ptext SLIT("In") <+> doc) \end{code} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index d7bd21c..6eb256d 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -152,7 +152,7 @@ tc_type_kind (MonoDictTy class_name tys) = tcClassAssertion (class_name, tys) `thenTc` \ (clas, arg_tys) -> returnTc (boxedTypeKind, mkDictTy clas arg_tys) -tc_type_kind (HsForAllTy tv_names context ty) +tc_type_kind (HsForAllTy (Just tv_names) context ty) = tcExtendTyVarScope tv_names $ \ tyvars -> tcContext context `thenTc` \ theta -> tc_boxed_type ty `thenTc` \ tau ->