From: simonpj Date: Tue, 21 Oct 2003 12:54:22 +0000 (+0000) Subject: [project @ 2003-10-21 12:54:17 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~343 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=1bade0c9060d3aec4fd4590803d411d54f0ea927;p=ghc-hetmet.git [project @ 2003-10-21 12:54:17 by simonpj] 1. A tiresome change to HsType, to keep a record of whether or not the HsForAll was originally explicitly-quantified. This is solely so that the type checker can print out messages that show the source code the programmer wrote. Tiresome but easy. 2. Improve reporting of kind errors. --- diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index fa48574..685bb9b 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -19,7 +19,7 @@ import HsSyn as Hs HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..), Stmt(..), HsBinds(..), MonoBinds(..), Sig(..), Pat(..), HsConDetails(..), HsOverLit, BangType(..), - placeHolderType, HsType(..), + placeHolderType, HsType(..), HsExplicitForAll(..), HsTyVarBndr(..), HsContext, mkSimpleMatch, mkHsForAllTy ) @@ -98,9 +98,7 @@ cvt_top (InstanceD tys ty decs) = Left $ InstD (InstDecl inst_ty binds sigs loc0) where (binds, sigs) = cvtBindsAndSigs decs - inst_ty = HsForAllTy Nothing - (cvt_context tys) - (HsPredTy (cvt_pred ty)) + inst_ty = mkImplicitHsForAllTy (cvt_context tys) (HsPredTy (cvt_pred ty)) cvt_top (Meta.SigD nm typ) = Left $ Hs.SigD (Sig (vName nm) (cvtType typ) loc0) @@ -321,9 +319,8 @@ cvtType ty = trans (root ty []) trans (VarT nm, args) = foldl HsAppTy (HsTyVar (tName nm)) args trans (ConT tc, args) = foldl HsAppTy (HsTyVar (tconName tc)) args - trans (ForallT tvs cxt ty, []) = mkHsForAllTy (Just (cvt_tvs tvs)) - (cvt_context cxt) - (cvtType ty) + trans (ForallT tvs cxt ty, []) = mkExplicitHsForAllTy + (cvt_tvs tvs) (cvt_context cxt) (cvtType ty) split_ty_app :: Meta.Type -> (Meta.Type, [Meta.Type]) split_ty_app ty = go ty [] diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 547da27..2643fdb 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -476,7 +476,7 @@ unbangedType ty = BangType HsNoBang ty \begin{code} instance (OutputableBndr name) => Outputable (ConDecl name) where ppr (ConDecl con tvs cxt con_details loc) - = sep [pprHsForAll tvs cxt, ppr_con_details con con_details] + = sep [pprHsForAll Explicit tvs cxt, ppr_con_details con con_details] ppr_con_details con (InfixCon ty1 ty2) = hsep [ppr ty1, ppr con, ppr ty2] diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 6d8013c..e3e2262 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -5,10 +5,10 @@ \begin{code} module HsTypes ( - HsType(..), HsTyVarBndr(..), + HsType(..), HsTyVarBndr(..), HsExplicitForAll(..), , HsContext, HsPred(..) - , mkHsForAllTy, mkHsDictTy, mkHsIParamTy + , mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkHsDictTy, mkHsIParamTy , hsTyVarName, hsTyVarNames, replaceTyVarName , splitHsInstDeclTy @@ -32,6 +32,7 @@ import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind ) import BasicTypes ( IPName, Boxity, tupleParens ) import PrelNames ( unboundKey ) import SrcLoc ( noSrcLoc ) +import CmdLineOpts ( opt_PprStyle_Debug ) import Outputable \end{code} @@ -80,7 +81,11 @@ data HsPred name = HsClassP name [HsType name] | HsIParam (IPName name) (HsType name) data HsType name - = HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures + = HsForAllTy HsExplicitForAll -- Renamer leaves this flag unchanged, to record the way + -- the user wrote it originally, so that the printer can + -- print it as the user wrote it + [HsTyVarBndr name] -- With ImplicitForAll, this is the empty list + -- until the renamer fills in the variables (HsContext name) (HsType name) @@ -117,6 +122,7 @@ data HsType name | HsKindSig (HsType name) -- (ty :: kind) Kind -- A type with a kind signature +data HsExplicitForAll = Explicit | Implicit ----------------------- -- Combine adjacent for-alls. @@ -128,18 +134,22 @@ data HsType name -- -- A valid type must have one for-all at the top of the type, or of the fn arg types -mkHsForAllTy mtvs [] ty = mk_forall_ty mtvs ty -mkHsForAllTy mtvs ctxt ty = HsForAllTy mtvs ctxt ty +mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty +mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty + +mkHsForAllTy :: HsExplicitForAll -> [HsTyVarBndr name] -> HsContext name -> HsType name -> HsType name +-- Smart constructor for HsForAllTy +mkHsForAllTy exp tvs [] ty = mk_forall_ty exp tvs ty +mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty -- mk_forall_ty makes a pure for-all type (no context) -mk_forall_ty (Just []) ty = ty -- Explicit for-all with no tyvars -mk_forall_ty mtvs1 (HsParTy ty) = mk_forall_ty mtvs1 ty -mk_forall_ty mtvs1 (HsForAllTy mtvs2 ctxt ty) = mkHsForAllTy (mtvs1 `plus` mtvs2) ctxt ty -mk_forall_ty mtvs1 ty = HsForAllTy mtvs1 [] ty +mk_forall_ty Explicit [] ty = ty -- Explicit for-all with no tyvars +mk_forall_ty exp tvs (HsParTy ty) = mk_forall_ty exp tvs ty +mk_forall_ty exp1 tvs1 (HsForAllTy exp2 tvs2 ctxt ty) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty +mk_forall_ty exp tvs ty = HsForAllTy exp tvs [] ty -mtvs1 `plus` Nothing = mtvs1 -Nothing `plus` mtvs2 = mtvs2 -(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2) +Implicit `plus` Implicit = Implicit +exp1 `plus` exp2 = Explicit mkHsDictTy cls tys = HsPredTy (HsClassP cls tys) mkHsIParamTy v ty = HsPredTy (HsIParam v ty) @@ -183,7 +193,8 @@ splitHsInstDeclTy splitHsInstDeclTy inst_ty = case inst_ty of - HsForAllTy (Just tvs) cxt1 tau + HsForAllTy _ tvs cxt1 tau -- The type vars should have been + -- computed by now, even if they were implicit -> (tvs, cxt1++cxt2, cls, tys) where (cxt2, cls, tys) = split_tau tau @@ -226,8 +237,14 @@ pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name | otherwise = hsep [ppr name, dcolon, pprParendKind kind] -pprHsForAll [] [] = empty -pprHsForAll tvs cxt = ptext SLIT("forall") <+> interppSP tvs <+> pprHsContext cxt +pprHsForAll exp tvs cxt + | show_forall = forall_part <+> pprHsContext cxt + | otherwise = pprHsContext cxt + where + show_forall = opt_PprStyle_Debug + || (not (null tvs) && is_explicit) + is_explicit = case exp of {Explicit -> True; Implicit -> False} + forall_part = ptext SLIT("forall") <+> interppSP tvs <> dot pprHsContext :: (Outputable name) => HsContext name -> SDoc pprHsContext [] = empty @@ -264,16 +281,11 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty -- (b) Drop top-level for-all type variables in user style -- since they are implicit in Haskell prepare sty (HsParTy ty) = prepare sty ty -prepare sty (HsForAllTy _ cxt ty) | userStyle sty = (HsForAllTy Nothing cxt ty) prepare sty ty = ty -ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty) +ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) = maybeParen ctxt_prec pREC_FUN $ - sep [pp_header, ppr_mono_ty pREC_TOP ty] - where - pp_header = case maybe_tvs of - Just tvs -> pprHsForAll tvs ctxt - Nothing -> pprHsContext ctxt + sep [pprHsForAll exp tvs ctxt, ppr_mono_ty pREC_TOP ty] ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2 diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 925be4e..c9bcf45 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.126 2003/10/09 11:59:02 simonpj Exp $ +$Id: Parser.y,v 1.127 2003/10/21 12:54:21 simonpj Exp $ Haskell grammar. @@ -673,7 +673,8 @@ sigtypes :: { [RdrNameHsType] } | sigtypes ',' sigtype { $3 : $1 } sigtype :: { RdrNameHsType } - : ctype { mkHsForAllTy Nothing [] $1 } + : ctype { mkImplicitHsForAllTy [] $1 } + -- Wrap an Implicit forall if there isn't one there already sig_vars :: { [RdrName] } : sig_vars ',' var { $3 : $1 } @@ -684,8 +685,8 @@ sig_vars :: { [RdrName] } -- A ctype is a for-all type ctype :: { RdrNameHsType } - : 'forall' tv_bndrs '.' ctype { mkHsForAllTy (Just $2) [] $4 } - | context '=>' type { mkHsForAllTy Nothing $1 $3 } + : 'forall' tv_bndrs '.' ctype { mkExplicitHsForAllTy $2 [] $4 } + | context '=>' type { mkImplicitHsForAllTy $1 $3 } -- A type of form (context => type) is an *implicit* HsForAllTy | type { $1 } diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index 4f025f9..32e8d91 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -318,8 +318,8 @@ ifaceExtRdrName :: IfaceExtName -> RdrName ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other) -add_forall tv (HsForAllTy (Just tvs) cxt t) = HsForAllTy (Just (tv:tvs)) cxt t -add_forall tv t = HsForAllTy (Just [tv]) [] t +add_forall tv (HsForAllTy exp tvs cxt t) = HsForAllTy exp (tv:tvs) cxt t +add_forall tv t = HsForAllTy Explicit [tv] [] t happyError :: P a happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 4ecdec3..feee920 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -194,23 +194,22 @@ extract_ctxt ctxt acc = foldr extract_pred acc ctxt extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys extract_pred (HsIParam n ty) acc = extract_ty ty acc -extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (HsListTy ty) acc = extract_ty ty acc -extract_ty (HsPArrTy ty) acc = extract_ty ty acc -extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys -extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (HsPredTy p) acc = extract_pred p acc -extract_ty (HsTyVar tv) acc = tv : acc -extract_ty (HsForAllTy Nothing cx ty) acc = extract_ctxt cx (extract_ty ty acc) -extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (HsParTy ty) acc = extract_ty ty acc --- Generics -extract_ty (HsNumTy num) acc = acc -extract_ty (HsKindSig ty k) acc = extract_ty ty acc -extract_ty (HsForAllTy (Just tvs) ctxt ty) +extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsListTy ty) acc = extract_ty ty acc +extract_ty (HsPArrTy ty) acc = extract_ty ty acc +extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys +extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsPredTy p) acc = extract_pred p acc +extract_ty (HsTyVar tv) acc = tv : acc +extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc) +extract_ty (HsParTy ty) acc = extract_ty ty acc +extract_ty (HsNumTy num) acc = acc +extract_ty (HsKindSig ty k) acc = extract_ty ty acc +extract_ty (HsForAllTy exp [] cx ty) acc = extract_ctxt cx (extract_ty ty acc) +extract_ty (HsForAllTy exp tvs cx ty) acc = acc ++ (filter (`notElem` locals) $ - extract_ctxt ctxt (extract_ty ty [])) + extract_ctxt cx (extract_ty ty [])) where locals = hsTyVarNames tvs @@ -378,14 +377,14 @@ hsIfaceName rdr_name -- Qualify unqualifed occurrences | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name) hsIfaceType :: HsType RdrName -> IfaceType -hsIfaceType (HsForAllTy mb_tvs cxt ty) - = foldr (IfaceForAllTy . hsIfaceTv) rho tvs +hsIfaceType (HsForAllTy exp tvs cxt ty) + = foldr (IfaceForAllTy . hsIfaceTv) rho tvs' where rho = foldr (IfaceFunTy . IfacePredTy . hsIfacePred) tau cxt tau = hsIfaceType ty - tvs = case mb_tvs of - Just tvs -> tvs - Nothing -> map UserTyVar (extractHsRhoRdrTyVars cxt ty) + tvs' = case exp of + Explicit -> tvs + Implicit -> map UserTyVar (extractHsRhoRdrTyVars cxt ty) hsIfaceType ty@(HsTyVar _) = hs_tc_app ty [] hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty [] @@ -634,14 +633,14 @@ tyConToDataCon tc checkInstType :: RdrNameHsType -> P RdrNameHsType checkInstType t = case t of - HsForAllTy tvs ctxt ty -> + HsForAllTy exp tvs ctxt ty -> checkDictTy ty [] >>= \ dict_ty -> - return (HsForAllTy tvs ctxt dict_ty) + return (HsForAllTy exp tvs ctxt dict_ty) HsParTy ty -> checkInstType ty ty -> checkDictTy ty [] >>= \ dict_ty-> - return (HsForAllTy Nothing [] dict_ty) + return (HsForAllTy Implicit [] [] dict_ty) checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar] checkTyVars tvs @@ -769,7 +768,7 @@ checkPat e [] = case e of -- but they aren't explicit forall points. Hence -- we have to remove the implicit forall here. let t' = case t of - HsForAllTy Nothing [] ty -> ty + HsForAllTy Implicit _ [] ty -> ty other -> other in return (SigPatIn e t') diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 716309d..c26edbe 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -86,11 +86,10 @@ extractHsTyNames ty get (HsNumTy n) = emptyNameSet get (HsTyVar tv) = unitNameSet tv get (HsKindSig ty k) = get ty - get (HsForAllTy (Just tvs) + get (HsForAllTy _ tvs ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty) `minusNameSet` mkNameSet (hsTyVarNames 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/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index 4b6f799..cf998b6 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -75,7 +75,7 @@ want a gratuitous knot. \begin{code} rnHsType :: SDoc -> RdrNameHsType -> RnM RenamedHsType -rnHsType doc (HsForAllTy Nothing ctxt ty) +rnHsType doc (HsForAllTy Implicit _ ctxt ty) -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} @@ -89,9 +89,9 @@ rnHsType doc (HsForAllTy Nothing ctxt ty) -- class C a where { op :: a -> a } forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned in - rnForAll doc (map UserTyVar forall_tyvars) ctxt ty + rnForAll doc Implicit (map UserTyVar forall_tyvars) ctxt ty -rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau) +rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) -- Explicit quantification. -- Check that the forall'd tyvars are actually -- mentioned in the type, and produce a warning if not @@ -103,7 +103,7 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau) warn_guys = filter (`notElem` mentioned) forall_tyvar_names in mappM_ (forAllWarn doc tau) warn_guys `thenM_` - rnForAll doc forall_tyvars ctxt tau + rnForAll doc Explicit forall_tyvars ctxt tau rnHsType doc (HsTyVar tyvar) = lookupOccRn tyvar `thenM` \ tyvar' -> @@ -167,11 +167,11 @@ rnHsTypes doc tys = mappM (rnHsType doc) tys \begin{code} -rnForAll doc forall_tyvars ctxt ty +rnForAll doc exp forall_tyvars ctxt ty = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> rnContext doc ctxt `thenM` \ new_ctxt -> rnHsType doc ty `thenM` \ new_ty -> - returnM (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty) + returnM (HsForAllTy exp new_tyvars new_ctxt new_ty) \end{code} diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index a0b0a4e..07a0a94 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -544,7 +544,7 @@ checkSigsTyVars qtvs sigs where check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc) = addSrcLoc src_loc $ - addErrCtxt (ptext SLIT("When checking the type signature for") + addErrCtxt (ptext SLIT("In the type signature for") <+> quotes (ppr id)) $ addErrCtxtM (sigCtxt id sig_tyvars sig_theta sig_tau) $ checkSigTyVarsWrt (idFreeTyVars id) sig_tyvars diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 5e515b6..e18982f 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -12,10 +12,11 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2, #include "HsVersions.h" -import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..), +import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..), HsExpr(..), HsLit(..), Pat(WildPat), HsTyVarBndr(..), + HsExplicitForAll(..), mkSimpleMatch, andMonoBinds, andMonoBindList, - isPragSig, placeHolderType, mkHsForAllTy + isPragSig, placeHolderType, mkExplicitHsForAllTy ) import BasicTypes ( RecFlag(..), NewOrData(..) ) import RnHsSyn ( RenamedTyClDecl, RenamedSig, @@ -699,8 +700,12 @@ groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest eqPatType :: HsType Name -> HsType Name -> Bool -- A very simple equality function, only for -- type patterns in generic function definitions. -eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2 -eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2 +eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2 +eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2 +eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2 && op1 == op2 +eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2 +eqPatType (HsParTy t1) t2 = t1 `eqPatType` t2 +eqPatType t1 (HsParTy t2) = t1 `eqPatType` t2 eqPatType _ _ = False --------------------------------- @@ -717,7 +722,7 @@ mkGenericInstance clas loc (hs_ty, binds) -- works in the standard way let sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty)) - hs_forall_ty = mkHsForAllTy (Just sig_tvs) [] hs_ty + hs_forall_ty = mkExplicitHsForAllTy sig_tvs [] hs_ty in -- Type-check the instance type, and check its form tcHsSigType GenPatCtxt hs_forall_ty `thenM` \ forall_inst_ty -> @@ -798,7 +803,7 @@ dupGenericInsts tc_inst_infos ptext SLIT("All the type patterns for a generic type constructor must be identical") ] where - ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst) + ppr_inst_ty (tc,inst) = ppr tc <+> ppr (simpleInstInfoTy inst) mixedGenericErr op = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 562510e..d3c6ee7 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -986,7 +986,7 @@ caseScrutCtxt expr = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr) exprSigCtxt expr - = hang (ptext SLIT("When checking the type signature of the expression:")) + = hang (ptext SLIT("In the type signature of the expression:")) 4 (ppr expr) exprCtxt expr diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 9cef7b8..96680aa 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -1167,7 +1167,7 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) get_tag_rhs = ExprWithTySig (HsLam (mkSimpleHsAlt (VarPat a_RDR) (HsApp (HsVar getTag_RDR) a_Expr))) - (HsForAllTy (Just (map UserTyVar tvs)) [] con2tag_ty) + (mkExplicitHsForAllTy (map UserTyVar tvs) [] con2tag_ty) con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon)) (map HsTyVar tvs) diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 9a73ff3..d85c492 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -32,14 +32,14 @@ import TcEnv ( tcExtendTyVarEnv, tcExtendTyVarKindEnv, TyThing(..), TcTyThing(..), getInLocalScope ) -import TcMType ( newKindVar, tcInstType, newMutTyVar, +import TcMType ( newKindVar, newOpenTypeKind, tcInstType, newMutTyVar, zonkTcType, zonkTcKindToKind, checkValidType, UserTypeCtxt(..), pprHsSigCtxt ) -import TcUnify ( unifyKind, unifyFunKind, unifyTypeKind ) +import TcUnify ( unifyKind, unifyFunKind ) import TcType ( Type, PredType(..), ThetaType, TyVarDetails(..), TcTyVar, TcKind, TcThetaType, TcTauType, - mkTyVarTy, mkTyVarTys, mkFunTy, + mkTyVarTy, mkTyVarTys, mkFunTy, isTypeKind, mkForAllTys, mkFunTys, tcEqType, isPredTy, mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, liftedTypeKind, unliftedTypeKind, eqKind, @@ -204,15 +204,21 @@ tcHsKindedContext hs_theta = mappM dsHsPred hs_theta \begin{code} --------------------------- kcLiftedType :: HsType Name -> TcM (HsType Name) - -- The type ty must be a *lifted* *type* +-- The type ty must be a *lifted* *type* kcLiftedType ty = kcCheckHsType ty liftedTypeKind --------------------------- kcTypeType :: HsType Name -> TcM (HsType Name) - -- The type ty must be a *type*, but it can be lifted or unlifted +-- The type ty must be a *type*, but it can be lifted or unlifted +-- Be sure to use checkExpectedKind, rather than simply unifying +-- with (Type bx), because it gives better error messages kcTypeType ty = kcHsType ty `thenM` \ (ty', kind) -> - unifyTypeKind kind `thenM_` + if isTypeKind kind then + return ty' + else + newOpenTypeKind `thenM` \ type_kind -> + checkExpectedKind (ppr ty) kind type_kind `thenM_` returnM ty' --------------------------- @@ -292,14 +298,14 @@ kcHsType (HsPredTy pred) = kcHsPred pred `thenM` \ pred' -> returnM (HsPredTy pred', liftedTypeKind) -kcHsType (HsForAllTy (Just tv_names) context ty) +kcHsType (HsForAllTy exp tv_names context ty) = kcHsTyVars tv_names $ \ tv_names' -> kcHsContext context `thenM` \ ctxt' -> kcLiftedType ty `thenM` \ ty' -> -- The body of a forall must be of kind * -- In principle, I suppose, we could allow unlifted types, -- but it seems simpler to stick to lifted types for now. - returnM (HsForAllTy (Just tv_names') ctxt' ty', liftedTypeKind) + returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) --------------------------- kcApps :: TcKind -- Function kind @@ -483,7 +489,7 @@ dsHsType (HsPredTy pred) = dsHsPred pred `thenM` \ pred' -> returnM (mkPredTy pred') -dsHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty) +dsHsType full_ty@(HsForAllTy exp tv_names ctxt ty) = tcTyVarBndrs tv_names $ \ tyvars -> mappM dsHsPred ctxt `thenM` \ theta -> dsHsType ty `thenM` \ tau -> diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 8bb4754..4ee1bbb 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -680,9 +680,9 @@ simplified: only zeze2 is extracted and its body is simplified. \begin{code} instDeclCtxt1 hs_inst_ty = inst_decl_ctxt (case hs_inst_ty of - HsForAllTy _ _ (HsPredTy pred) -> ppr pred - HsPredTy pred -> ppr pred - other -> ppr hs_inst_ty) -- Don't expect this + HsForAllTy _ _ _ (HsPredTy pred) -> ppr pred + HsPredTy pred -> ppr pred + other -> ppr hs_inst_ty) -- Don't expect this instDeclCtxt2 dfun_ty = inst_decl_ctxt (ppr (mkClassPred cls tys)) where diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index c6ee4d7..b2c86cc 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -14,7 +14,7 @@ module TcMType ( newTyVar, newSigTyVar, newTyVarTy, -- Kind -> TcM TcType newTyVarTys, -- Int -> Kind -> TcM [TcType] - newKindVar, newKindVars, newBoxityVar, + newKindVar, newKindVars, newOpenTypeKind, putTcTyVar, getTcTyVar, newMutTyVar, readMutTyVar, writeMutTyVar, @@ -49,7 +49,7 @@ import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see repres ) import TcType ( TcType, TcThetaType, TcTauType, TcPredType, TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..), - tcEqType, tcCmpPred, isClassPred, + tcEqType, tcCmpPred, isClassPred, mkTyConApp, typeCon, tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, tcSplitForAllTys, tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy, @@ -134,6 +134,10 @@ newBoxityVar :: TcM TcKind -- Really TcBoxity newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) superBoxity VanillaTv `thenM` \ kv -> returnM (TyVarTy kv) + +newOpenTypeKind :: TcM TcKind +newOpenTypeKind = newBoxityVar `thenM` \ bx_var -> + returnM (mkTyConApp typeCon [bx_var]) \end{code} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 44b0c2a..45f662b 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -86,7 +86,7 @@ module TcType ( Kind, -- Stuff to do with kinds is insensitive to pre/post Tc unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind, - isTypeKind, isAnyTypeKind, + isTypeKind, isAnyTypeKind, typeCon, Type, PredType(..), ThetaType, mkForAllTy, mkForAllTys, @@ -117,7 +117,7 @@ import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend import Type ( -- Re-exports tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, Kind, Type, PredType(..), - ThetaType, unliftedTypeKind, + ThetaType, unliftedTypeKind, typeCon, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, mkForAllTy, mkForAllTys, defaultKind, isTypeKind, isAnyTypeKind, diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index cb4f73b..9feb547 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -11,7 +11,7 @@ module TcUnify ( -- Various unifications unifyTauTy, unifyTauTyList, unifyTauTyLists, - unifyKind, unifyKinds, unifyTypeKind, unifyFunKind, + unifyKind, unifyKinds, unifyFunKind, -------------------------------- -- Holes @@ -47,7 +47,7 @@ import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType, ) import Inst ( newDicts, instToId, tcInstCall ) import TcMType ( getTcTyVar, putTcTyVar, tcInstType, newKindVar, - newTyVarTy, newTyVarTys, newBoxityVar, + newTyVarTy, newTyVarTys, newOpenTypeKind, zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV ) import TcSimplify ( tcSimplifyCheck ) import TysWiredIn ( listTyCon, parrTyCon, tupleTyCon ) @@ -921,8 +921,8 @@ unifyTypeKind ty@(TyVarTy tyvar) = getTcTyVar tyvar `thenM` \ maybe_ty -> case maybe_ty of Just ty' -> unifyTypeKind ty' - Nothing -> newBoxityVar `thenM` \ bx_var -> - putTcTyVar tyvar (mkTyConApp typeCon [bx_var]) `thenM_` + Nothing -> newOpenTypeKind `thenM` \ kind -> + putTcTyVar tyvar kind `thenM_` returnM () unifyTypeKind ty