Commit 42a51e93 authored by simonpj's avatar simonpj

[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.
parent 1c52a209
......@@ -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}
......@@ -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
;
......
......@@ -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;
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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}
......@@ -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 ->
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment