Skip to content
Snippets Groups Projects
Commit 3df40b7b authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

[project @ 1999-07-27 07:31:16 by simonpj] 

Do a more correct job of explicit for-alls in types
parent 6ef0bc6c
No related merge requests found
Hide whitespace changes
Inline Side-by-side
Showing
with 106 additions and 67 deletions
ghc/compiler/hsSyn/HsTypes.lhs
+ 22
− 7
View file @ 3df40b7b
......@@ -66,8 +66,22 @@ data MonoUsageAnn name
| MonoUsVar name
mkHsForAllTy [] [] ty = ty
mkHsForAllTy tvs ctxt ty = HsForAllTy (Just tvs) ctxt ty
-- Combine adjacent for-alls.
-- The following awkward situation can happen otherwise:
-- f :: forall a. ((Num a) => Int)
-- might generate HsForAll (Just [a]) [] (HsForAll Nothing [Num a] t)
-- Then a isn't discovered as ambiguous, and we abstract the AbsBinds wrt []
-- but the export list abstracts f wrt [a]. Disaster.
--
-- A valid type must have one for-all at the top of the type, or of the fn arg types
mkHsForAllTy (Just []) [] ty = ty -- Explicit for-all with no tyvars
mkHsForAllTy mtvs1 [] (HsForAllTy mtvs2 ctxt ty) = HsForAllTy (mtvs1 `plus` mtvs2) ctxt ty
where
mtvs1 `plus` Nothing = mtvs1
Nothing `plus` mtvs2 = mtvs2
(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
mkHsUsForAllTy uvs ty = foldr (\ uv ty -> MonoUsgForAllTy uv ty)
ty uvs
......@@ -103,7 +117,8 @@ instance (Outputable name) => Outputable (HsTyVar name) where
ppr (UserTyVar name) = ppr name
ppr (IfaceTyVar name kind) = hsep [ppr name, dcolon, ppr kind]
pprForAll [] = empty
-- Better to see those for-alls
-- pprForAll [] = empty
pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".")
pprContext :: (Outputable name) => Context name -> SDoc
......@@ -133,11 +148,11 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty
ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty)
= maybeParen (ctxt_prec >= pREC_FUN) $
sep [pprForAll tvs, pprContext ctxt, pprHsType ty]
sep [pp_tvs, pprContext ctxt, pprHsType ty]
where
tvs = case maybe_tvs of
Just tvs -> tvs
Nothing -> []
pp_tvs = case maybe_tvs of
Just tvs -> pprForAll tvs
Nothing -> text "{- implicit forall -}"
ppr_mono_ty ctxt_prec (MonoTyVar name)
= ppr name
......
ghc/compiler/parser/Parser.y
+ 6
− 7
View file @ 3df40b7b
{-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.11 1999/07/26 16:06:28 simonpj Exp $
$Id: Parser.y,v 1.12 1999/07/27 07:31:18 simonpj Exp $
Haskell grammar.
......@@ -403,9 +403,7 @@ signdecl :: { RdrBinding }
[ RdrSig (Sig n $4 $2) | n <- $1 ] }
sigtype :: { RdrNameHsType }
: ctype { case $1 of
HsForAllTy _ _ _ -> $1
other -> HsForAllTy Nothing [] $1 }
: ctype { mkHsForAllTy Nothing [] $1 }
{-
ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var
......@@ -502,9 +500,10 @@ inst_type :: { RdrNameHsType }
ctype :: { RdrNameHsType }
: 'forall' tyvars '.' context type
{ HsForAllTy (Just $2) $4 $5 }
| 'forall' tyvars '.' type { HsForAllTy (Just $2) [] $4 }
| context type { HsForAllTy Nothing $1 $2 }
{ mkHsForAllTy (Just $2) $4 $5 }
| 'forall' tyvars '.' type { mkHsForAllTy (Just $2) [] $4 }
| context type { mkHsForAllTy Nothing $1 $2 }
-- A type of form (context => type) is an *implicit* HsForAllTy
| type { $1 }
types0 :: { [RdrNameHsType] }
......
ghc/compiler/rename/ParseIface.y
+ 1
− 1
View file @ 3df40b7b
......@@ -403,7 +403,7 @@ field : var_names1 '::' type { ($1, Unbanged $3) }
type :: { RdrNameHsType }
type : '__fuall' fuall '=>' type { mkHsUsForAllTy $2 $4 }
| '__forall' forall context '=>' type
{ mkHsForAllTy $2 $3 $5 }
{ mkHsForAllTy (Just $2) $3 $5 }
| btype '->' type { MonoFunTy $1 $3 }
| btype { $1 }
......
ghc/compiler/rename/RnExpr.lhs
+ 2
− 2
View file @ 3df40b7b
......@@ -18,7 +18,7 @@ module RnExpr (
#include "HsVersions.h"
import {-# SOURCE #-} RnBinds ( rnBinds )
import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsPolyType, rnHsType )
import HsSyn
import RdrHsSyn
......@@ -70,7 +70,7 @@ rnPat (VarPatIn name)
rnPat (SigPatIn pat ty)
| opt_GlasgowExts
= rnPat pat `thenRn` \ (pat', fvs1) ->
rnHsType doc ty `thenRn` \ (ty', fvs2) ->
rnHsPolyType doc ty `thenRn` \ (ty', fvs2) ->
returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
| otherwise
......
ghc/compiler/rename/RnSource.hi-boot
+ 5
− 3
View file @ 3df40b7b
_interface_ RnSource 1
_exports_
RnSource rnHsType rnHsSigType;
RnSource rnHsType rnHsPolyType rnHsSigType;
_declarations_
1 rnHsType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
-> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
1 rnHsSigType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
-> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
1 rnHsType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
-> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
1 rnHsPolyType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType
-> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;;
ghc/compiler/rename/RnSource.hi-boot-5
+ 5
− 3
View file @ 3df40b7b
__interface RnSource 1 0 where
__export RnSource rnHsSigType rnHsType;
__export RnSource rnHsType rnHsSigType rnHsPolyType;
1 rnHsType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType
-> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
1 rnHsSigType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType
-> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
1 rnHsType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType
-> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
1 rnHsPolyType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType
-> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;
ghc/compiler/rename/RnSource.lhs
+ 60
− 42
View file @ 3df40b7b
......@@ -4,7 +4,7 @@
\section[RnSource]{Main pass of renamer}
\begin{code}
module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType ) where
module RnSource ( rnDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsPolyType ) where
#include "HsVersions.h"
......@@ -106,7 +106,7 @@ rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) ->
rnDecl (SigD (IfaceSig name ty id_infos loc))
= pushSrcLocRn loc $
lookupBndrRn name `thenRn` \ name' ->
rnHsType doc_str ty `thenRn` \ (ty',fvs1) ->
rnHsPolyType doc_str ty `thenRn` \ (ty',fvs1) ->
mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) ->
returnRn (SigD (IfaceSig name' ty' id_infos' loc), fvs1 `plusFV` fvs2)
where
......@@ -420,7 +420,7 @@ rnDecl (RuleD (RuleDecl rule_name tvs vars lhs rhs src_loc))
get_var (RuleBndrSig v _) = v
rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs)
rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) ->
rn_var (RuleBndrSig v t, id) = rnHsPolyType doc t `thenRn` \ (t', fvs) ->
returnRn (RuleBndrSig id t', fvs)
\end{code}
......@@ -474,7 +474,7 @@ rnConDetails doc locn (InfixCon ty1 ty2)
returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2)
rnConDetails doc locn (NewCon ty mb_field)
= rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
= rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
rn_field mb_field `thenRn` \ new_mb_field ->
returnRn (NewCon new_ty new_mb_field, fvs)
where
......@@ -496,15 +496,15 @@ rnField doc (names, ty)
returnRn ((new_names, new_ty), fvs)
rnBangTy doc (Banged ty)
= rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
= rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
returnRn (Banged new_ty, fvs)
rnBangTy doc (Unbanged ty)
= rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
= rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
returnRn (Unbanged new_ty, fvs)
rnBangTy doc (Unpacked ty)
= rnHsType doc ty `thenRn` \ (new_ty, fvs) ->
= rnHsPolyType doc ty `thenRn` \ (new_ty, fvs) ->
returnRn (Unpacked new_ty, fvs)
-- This data decl will parse OK
......@@ -534,36 +534,15 @@ rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
-- rnHsSigType is used for source-language type signatures,
-- which use *implicit* universal quantification.
rnHsSigType doc_str ty
= rnHsType (text "the type signature for" <+> doc_str) ty
= rnHsPolyType (text "the type signature for" <+> doc_str) 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) . extractHsTyRdrTyVars)
False
tys
---------------------------------------
rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
-- rnHsPolyType is prepared to see a for-all; rnHsType is not
-- The former is called for the top level of type sigs and function args.
rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars)
rnHsType doc (HsForAllTy Nothing ctxt ty)
---------------------------------------
rnHsPolyType 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}
......@@ -575,7 +554,7 @@ rnHsType doc (HsForAllTy Nothing ctxt ty)
checkConstraints False doc forall_tyvars ctxt ty `thenRn` \ ctxt' ->
rnForAll doc (map UserTyVar forall_tyvars) ctxt' ty
rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
rnHsPolyType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
-- Explicit quantification.
-- Check that the forall'd tyvars are a subset of the
-- free tyvars in the tau-type part
......@@ -601,13 +580,49 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
checkConstraints True doc forall_tyvar_names ctxt tau `thenRn` \ ctxt' ->
rnForAll doc forall_tyvars ctxt' tau
rnHsPolyType doc other_ty = rnHsType doc other_ty
-- 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) . extractHsTyRdrTyVars)
False
tys
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 (Just new_tyvars) new_ctxt new_ty,
cxt_fvs `plusFV` ty_fvs)
---------------------------------------
rnHsType doc ty@(HsForAllTy _ _ inner_ty)
= addErrRn (unexpectedForAllTy ty) `thenRn_`
rnHsPolyType doc ty
rnHsType doc (MonoTyVar tyvar)
= lookupOccRn tyvar `thenRn` \ tyvar' ->
returnRn (MonoTyVar tyvar', unitFV tyvar')
rnHsType doc (MonoFunTy ty1 ty2)
= rnHsType doc ty1 `thenRn` \ (ty1', fvs1) ->
rnHsType doc ty2 `thenRn` \ (ty2', fvs2) ->
= rnHsPolyType doc ty1 `thenRn` \ (ty1', fvs1) ->
-- Might find a for-all as the arg of a function type
rnHsPolyType doc ty2 `thenRn` \ (ty2', fvs2) ->
-- Or as the result. This happens when reading Prelude.hi
-- when we find return :: forall m. Monad m -> forall a. a -> m a
returnRn (MonoFunTy ty1' ty2', fvs1 `plusFV` fvs2)
rnHsType doc (MonoListTy ty)
......@@ -711,7 +726,7 @@ rnRuleBody (UfRuleBody str vars args rhs)
\begin{code}
rnCoreExpr (UfType ty)
= rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
= rnHsPolyType (text "unfolding type") ty `thenRn` \ (ty', fvs) ->
returnRn (UfType ty', fvs)
rnCoreExpr (UfVar v)
......@@ -770,7 +785,7 @@ rnCoreExpr (UfLet (UfRec pairs) body)
\begin{code}
rnCoreBndr (UfValBinder name ty) thing_inside
= rnHsType doc ty `thenRn` \ (ty', fvs1) ->
= rnHsPolyType doc ty `thenRn` \ (ty', fvs1) ->
bindCoreLocalFVRn name ( \ name' ->
thing_inside (UfValBinder name' ty')
) `thenRn` \ (result, fvs2) ->
......@@ -798,7 +813,7 @@ rnCoreAlt (con, bndrs, rhs)
returnRn (result, fvs1 `plusFV` fvs3)
rnNote (UfCoerce ty)
= rnHsType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
= rnHsPolyType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) ->
returnRn (UfCoerce ty', fvs)
rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs)
......@@ -817,7 +832,7 @@ rnUfCon (UfLitCon lit)
= returnRn (UfLitCon lit, emptyFVs)
rnUfCon (UfLitLitCon lit ty)
= rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) ->
= rnHsPolyType (text "litlit") ty `thenRn` \ (ty', fvs) ->
returnRn (UfLitLitCon lit ty', fvs)
rnUfCon (UfPrimOp op)
......@@ -910,6 +925,9 @@ ctxtErr explicit_forall doc tyvars constraint ty
$$
(ptext SLIT("In") <+> doc)
unexpectedForAllTy ty
= ptext SLIT("Unexpected forall type:") <+> ppr ty
badRuleLhsErr name lhs
= sep [ptext SLIT("Rule") <+> ptext name <> colon,
nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)]
......
ghc/compiler/typecheck/TcType.lhs
+ 5
− 2
View file @ 3df40b7b
......@@ -312,8 +312,11 @@ zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars
zonkTcTyVarBndr :: TcTyVar -> NF_TcM s TcTyVar
zonkTcTyVarBndr tyvar
= zonkTcTyVar tyvar `thenNF_Tc` \ (TyVarTy tyvar') ->
returnNF_Tc tyvar'
= zonkTcTyVar tyvar `thenNF_Tc` \ ty ->
case ty of
TyVarTy tyvar' -> returnNF_Tc tyvar'
_ -> pprTrace "zonkTcTyVarBndr" (ppr tyvar <+> ppr ty) $
returnNF_Tc tyvar
zonkTcTyVar :: TcTyVar -> NF_TcM s TcType
zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnNF_Tc (TyVarTy tv)) tyvar
......
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