From: simonpj Date: Tue, 27 Jul 1999 07:31:24 +0000 (+0000) Subject: [project @ 1999-07-27 07:31:16 by simonpj] X-Git-Tag: Approximately_9120_patches~5954 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=3df40b7b78044206bbcffe3e2c0a57d901baf5e8;p=ghc-hetmet.git [project @ 1999-07-27 07:31:16 by simonpj] Do a more correct job of explicit for-alls in types --- diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index dc00198..8e3704c 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -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 diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 606181b..066bc1c 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$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] } diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index 3621264..83450fa 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -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 } diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 8a381e1..ad4a408 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -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 diff --git a/ghc/compiler/rename/RnSource.hi-boot b/ghc/compiler/rename/RnSource.hi-boot index 21e9592..399a3c9 100644 --- a/ghc/compiler/rename/RnSource.hi-boot +++ b/ghc/compiler/rename/RnSource.hi-boot @@ -1,9 +1,11 @@ _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) ;; diff --git a/ghc/compiler/rename/RnSource.hi-boot-5 b/ghc/compiler/rename/RnSource.hi-boot-5 index bb0593a..f2a15df 100644 --- a/ghc/compiler/rename/RnSource.hi-boot-5 +++ b/ghc/compiler/rename/RnSource.hi-boot-5 @@ -1,6 +1,8 @@ __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) ; diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 702ac98..a1e1678 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -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)] diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 95a5bdd..4f33951 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -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