From 836b1e90821aacc9d1e09fe78085f911597274c8 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 10 Feb 2010 14:51:55 +0000 Subject: [PATCH] Keep track of explicit kinding in HsTyVarBndr; plus fix Trac #3845 To print HsTypes correctly we should remember whether the Kind on a HsTyVarBndr came from type inference, or was put there by the user. See Note [Printing KindedTyVars] in HsTypes. So instead of changing a UserTyVar to a KindedTyVar during kind checking, we simply add a PostTcKind to the UserTyVar. The change was provoked by Trac #3830, although other changes mean that #3830 gets a diferent and better error message now. So this patch is simply doing the Right Thing for the future. This patch also fixes Trac #3845, which was caused by a *type splice* not remembering the free *term variables* mentioned in it. Result was that we build a 'let' when it should have been 'letrec'. Hence a new FreeVars field in HsSpliceTy. While I was at it, I got rid of HsSpliceTyOut and use a PostTcKind on HsSpliceTy instead, just like on the UserTyVar. --- compiler/deSugar/DsMeta.hs | 13 +++--- compiler/hsSyn/Convert.lhs | 2 +- compiler/hsSyn/HsDecls.lhs | 2 +- compiler/hsSyn/HsTypes.lhs | 84 +++++++++++++++++++++------------- compiler/hsSyn/HsUtils.lhs | 6 ++- compiler/parser/Parser.y.pp | 14 +++--- compiler/parser/RdrHsSyn.lhs | 6 +-- compiler/rename/RnHsSyn.lhs | 5 +- compiler/rename/RnTypes.lhs | 9 ++-- compiler/typecheck/TcClassDcl.lhs | 3 +- compiler/typecheck/TcEnv.lhs | 9 ++-- compiler/typecheck/TcGenDeriv.lhs | 3 +- compiler/typecheck/TcHsType.lhs | 59 ++++++------------------ compiler/typecheck/TcSplice.lhs | 12 ++--- compiler/typecheck/TcSplice.lhs-boot | 3 +- compiler/typecheck/TcTyClsDecls.lhs | 32 ++++++------- 16 files changed, 125 insertions(+), 137 deletions(-) diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 7718e4f..43c4622 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -536,9 +536,10 @@ lookupTyVarBinds tvs m = -- repTyVarBndrWithKind :: LHsTyVarBndr Name -> Core TH.Name -> DsM (Core TH.TyVarBndr) -repTyVarBndrWithKind (L _ (UserTyVar _)) = repPlainTV -repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) = - \nm -> repKind ki >>= repKindedTV nm +repTyVarBndrWithKind (L _ (UserTyVar {})) nm + = repPlainTV nm +repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm + = repKind ki >>= repKindedTV nm -- represent a type context -- @@ -632,9 +633,9 @@ repTy (HsKindSig t k) = do t1 <- repLTy t k1 <- repKind k repTSig t1 k1 -repTy (HsSpliceTy splice) = repSplice splice -repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) -repTy ty = notHandled "Exotic form of type" (ppr ty) +repTy (HsSpliceTy splice _ _) = repSplice splice +repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) +repTy ty = notHandled "Exotic form of type" (ppr ty) -- represent a kind -- diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 01af78b..d14d04a 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -641,7 +641,7 @@ cvtTvs tvs = mapM cvt_tv tvs cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) cvt_tv (TH.PlainTV nm) = do { nm' <- tName nm - ; returnL $ UserTyVar nm' + ; returnL $ UserTyVar nm' placeHolderKind } cvt_tv (TH.KindedTV nm ki) = do { nm' <- tName nm diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 000ed19..08d12b7 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -698,7 +698,7 @@ data ConDecl name -- ^ Constructor name. This is used for the DataCon itself, and for -- the user-callable wrapper Id. - , con_explicit :: HsExplicitForAll + , con_explicit :: HsExplicitFlag -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy') , con_qvars :: [LHsTyVarBndr name] diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 4417751..2e2eaab 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -9,7 +9,7 @@ HsTypes: Abstract syntax: user-defined types module HsTypes ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, - HsExplicitForAll(..), + HsExplicitFlag(..), HsContext, LHsContext, HsPred(..), LHsPred, HsQuasiQuote(..), @@ -21,20 +21,21 @@ module HsTypes ( mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, hsTyVarName, hsTyVarNames, replaceTyVarName, + hsTyVarKind, hsTyVarNameKind, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, splitHsInstDeclTy, splitHsFunType, -- Type place holder - PostTcType, placeHolderType, + PostTcType, placeHolderType, PostTcKind, placeHolderKind, -- Printing - pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr + pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, ) where import {-# SOURCE #-} HsExpr ( HsSplice, pprSplice ) +import NameSet( FreeVars ) import Type -import Coercion import HsDoc import BasicTypes import SrcLoc @@ -51,6 +52,7 @@ import FastString %************************************************************************ \begin{code} +type PostTcKind = Kind type PostTcType = Type -- Used for slots in the abstract syntax -- where we want to keep slot for a type -- to be added by the type checker...but @@ -58,6 +60,9 @@ type PostTcType = Type -- Used for slots in the abstract syntax placeHolderType :: PostTcType -- Used before typechecking placeHolderType = panic "Evaluated the place holder for a PostTcType" + +placeHolderKind :: PostTcKind -- Used before typechecking +placeHolderKind = panic "Evaluated the place holder for a PostTcKind" \end{code} %************************************************************************ @@ -134,7 +139,7 @@ data HsPred name = HsClassP name [LHsType name] -- class constraint type LHsType name = Located (HsType name) data HsType name - = HsForAllTy HsExplicitForAll -- Renamer leaves this flag unchanged, to record the way + = HsForAllTy HsExplicitFlag -- 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 [LHsTyVarBndr name] -- With ImplicitForAll, this is the empty list @@ -179,20 +184,18 @@ data HsType name | HsKindSig (LHsType name) -- (ty :: kind) Kind -- A type with a kind signature - | HsSpliceTy (HsSplice name) | HsQuasiQuoteTy (HsQuasiQuote name) - | HsDocTy (LHsType name) LHsDocString -- A documented type + | HsSpliceTy (HsSplice name) + FreeVars -- Variables free in the splice (filled in by renamer) + PostTcKind - | HsSpliceTyOut Kind -- Used just like KindedTyVar, just between - -- kcHsType and dsHsType + | HsDocTy (LHsType name) LHsDocString -- A documented type | HsBangTy HsBang (LHsType name) -- Bang-style type annotations | HsRecTy [ConDeclField name] -- Only in data type declarations -data HsExplicitForAll = Explicit | Implicit - - +data HsExplicitFlag = Explicit | Implicit data ConDeclField name -- Record fields have Haddoc docs on them = ConDeclField { cd_fld_name :: Located name, @@ -215,13 +218,13 @@ mkExplicitHsForAllTy :: [LHsTyVarBndr name] -> LHsContext name -> LHsType name - mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty -mkHsForAllTy :: HsExplicitForAll -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name +mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name -- Smart constructor for HsForAllTy mkHsForAllTy exp tvs (L _ []) 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 :: HsExplicitForAll -> [LHsTyVarBndr name] -> LHsType name -> HsType name +mk_forall_ty :: HsExplicitFlag -> [LHsTyVarBndr name] -> LHsType name -> HsType name mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty mk_forall_ty exp tvs ty = HsForAllTy exp tvs (L noSrcSpan []) ty @@ -231,7 +234,7 @@ mk_forall_ty exp tvs ty = HsForAllTy exp tvs (L noSrcSpan []) ty -- (see the sigtype production in Parser.y.pp) -- so that (forall. ty) isn't implicitly quantified -plus :: HsExplicitForAll -> HsExplicitForAll -> HsExplicitForAll +plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag Implicit `plus` Implicit = Implicit _ `plus` _ = Explicit @@ -244,16 +247,29 @@ hsExplicitTvs _ = [] type LHsTyVarBndr name = Located (HsTyVarBndr name) data HsTyVarBndr name - = UserTyVar name - | KindedTyVar name Kind - -- *** NOTA BENE *** A "monotype" in a pragma can have - -- for-alls in it, (mostly to do with dictionaries). These - -- must be explicitly Kinded. + = UserTyVar -- No explicit kinding + name -- See Note [Printing KindedTyVars] + PostTcKind + + | KindedTyVar + name + Kind + -- *** NOTA BENE *** A "monotype" in a pragma can have + -- for-alls in it, (mostly to do with dictionaries). These + -- must be explicitly Kinded. hsTyVarName :: HsTyVarBndr name -> name -hsTyVarName (UserTyVar n) = n +hsTyVarName (UserTyVar n _) = n hsTyVarName (KindedTyVar n _) = n +hsTyVarKind :: HsTyVarBndr name -> Kind +hsTyVarKind (UserTyVar _ k) = k +hsTyVarKind (KindedTyVar _ k) = k + +hsTyVarNameKind :: HsTyVarBndr name -> (name, Kind) +hsTyVarNameKind (UserTyVar n k) = (n,k) +hsTyVarNameKind (KindedTyVar n k) = (n,k) + hsLTyVarName :: LHsTyVarBndr name -> name hsLTyVarName = hsTyVarName . unLoc @@ -270,7 +286,7 @@ hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name] hsLTyVarLocNames = map hsLTyVarLocName replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2 -replaceTyVarName (UserTyVar _) n' = UserTyVar n' +replaceTyVarName (UserTyVar _ k) n' = UserTyVar n' k replaceTyVarName (KindedTyVar _ k) n' = KindedTyVar n' k \end{code} @@ -316,8 +332,8 @@ instance (OutputableBndr name) => Outputable (HsType name) where ppr ty = pprHsType ty instance (Outputable name) => Outputable (HsTyVarBndr name) where - ppr (UserTyVar name) = ppr name - ppr (KindedTyVar name kind) = pprHsTyVarBndr name kind + ppr (UserTyVar name _) = ppr name + ppr (KindedTyVar name kind) = hsep [ppr name, dcolon, pprParendKind kind] instance OutputableBndr name => Outputable (HsPred name) where ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprLHsType tys) @@ -328,11 +344,7 @@ instance OutputableBndr name => Outputable (HsPred name) where pprLHsType :: OutputableBndr name => LHsType name -> SDoc pprLHsType = pprParendHsType . unLoc -pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc -pprHsTyVarBndr name kind | isLiftedTypeKind kind = ppr name - | otherwise = hsep [ppr name, dcolon, pprParendKind kind] - -pprHsForAll :: OutputableBndr name => HsExplicitForAll -> [LHsTyVarBndr name] -> LHsContext name -> SDoc +pprHsForAll :: OutputableBndr name => HsExplicitFlag -> [LHsTyVarBndr name] -> LHsContext name -> SDoc pprHsForAll exp tvs cxt | show_forall = forall_part <+> pprHsContext (unLoc cxt) | otherwise = pprHsContext (unLoc cxt) @@ -358,6 +370,17 @@ pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) = ppr n <+> dcolon <+> ppr ty <+> ppr_mbDoc doc \end{code} +Note [Printing KindedTyVars] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Trac #3830 reminded me that we should really only print the kind +signature on a KindedTyVar if the kind signature was put there by the +programmer. During kind inference GHC now adds a PostTcKind to UserTyVars, +rather than converting to KindedTyVars as before. + +(As it happens, the message in #3830 comes out a different way now, +and the problem doesn't show up; but having the flag on a KindedTyVar +seems like the Right Thing anyway.) + \begin{code} pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int pREC_TOP = 0 -- type in ParseIface.y @@ -408,8 +431,7 @@ ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsPredTy pred) = ppr pred ppr_mono_ty _ (HsNumTy n) = integer n -- generics only -ppr_mono_ty _ (HsSpliceTy s) = pprSplice s -ppr_mono_ty _ (HsSpliceTyOut k) = text "" <> dcolon <> ppr k +ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen ctxt_prec pREC_CON $ diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 37a7205..14193e0 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -28,6 +28,7 @@ import Coercion import Type import DataCon import Name +import NameSet import BasicTypes import SrcLoc import FastString @@ -183,6 +184,9 @@ mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2 mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName mkHsSplice e = HsSplice unqualSplice e +mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName +mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind + unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) -- A name (uniquified later) to @@ -201,7 +205,7 @@ mkHsString s = HsString (mkFastString s) ------------- userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)] -userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ] +userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ] \end{code} diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index c56b0c1..3b51e58 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1014,11 +1014,9 @@ atype :: { LHsType RdrName } | '(' ctype ')' { LL $ HsParTy $2 } | '(' ctype '::' kind ')' { LL $ HsKindSig $2 (unLoc $4) } | quasiquote { L1 (HsQuasiQuoteTy (unLoc $1)) } - | '$(' exp ')' { LL $ HsSpliceTy (mkHsSplice $2 ) } - | TH_ID_SPLICE { LL $ HsSpliceTy (mkHsSplice - (L1 $ HsVar (mkUnqual varName - (getTH_ID_SPLICE $1)))) } -- $x - + | '$(' exp ')' { LL $ mkHsSpliceTy $2 } + | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ + mkUnqual varName (getTH_ID_SPLICE $1) } -- Generics | INTEGER { L1 (HsNumTy (getINTEGER $1)) } @@ -1046,7 +1044,7 @@ tv_bndrs :: { [LHsTyVarBndr RdrName] } | {- empty -} { [] } tv_bndr :: { LHsTyVarBndr RdrName } - : tyvar { L1 (UserTyVar (unLoc $1)) } + : tyvar { L1 (UserTyVar (unLoc $1) placeHolderKind) } | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) (unLoc $4)) } @@ -1364,8 +1362,8 @@ aexp2 :: { LHsExpr RdrName } -- Template Haskell Extension | TH_ID_SPLICE { L1 $ HsSpliceE (mkHsSplice (L1 $ HsVar (mkUnqual varName - (getTH_ID_SPLICE $1)))) } -- $x - | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } -- $( exp ) + (getTH_ID_SPLICE $1)))) } + | '$(' exp ')' { LL $ HsSpliceE (mkHsSplice $2) } | TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index e0e8c3c..b83bcd9 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -128,7 +128,6 @@ extract_lty (L loc ty) acc HsNumTy _ -> acc HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables HsSpliceTy {} -> acc -- Type splices mention no type variables - HsSpliceTyOut {} -> acc -- Type splices mention no type variables HsKindSig ty _ -> extract_lty ty acc HsForAllTy _ [] cx ty -> extract_lctxt cx (extract_lty ty acc) HsForAllTy _ tvs cx ty -> acc ++ (filter ((`notElem` locals) . unLoc) $ @@ -503,8 +502,7 @@ checkTParams is_family tparams = do { tyvars <- checkTyVars tparams ; return (tyvars, Nothing) } | otherwise -- Family case (b) - = do { let tyvars = [L l (UserTyVar tv) - | L l tv <- extractHsTysRdrTyVars tparams] + = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams) ; return (tyvars, Just tparams) } checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName] @@ -519,7 +517,7 @@ checkTyVars tparms = mapM chk tparms chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) | isRdrTyVar tv = return (L l (KindedTyVar tv k)) chk (L l (HsTyVar tv)) - | isRdrTyVar tv = return (L l (UserTyVar tv)) + | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind)) chk (L l _) = parseError l "Type found where type variable expected" diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs index cb0727b..60e0823 100644 --- a/compiler/rename/RnHsSyn.lhs +++ b/compiler/rename/RnHsSyn.lhs @@ -68,9 +68,8 @@ extractHsTyNames ty get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds) get (HsNumTy _) = emptyNameSet get (HsTyVar tv) = unitNameSet tv - get (HsSpliceTy {}) = emptyNameSet -- Type splices mention no type variables - get (HsSpliceTyOut {}) = emptyNameSet -- Ditto - get (HsQuasiQuoteTy {}) = emptyNameSet -- Ditto + get (HsSpliceTy _ fvs _) = fvs + get (HsQuasiQuoteTy {}) = emptyNameSet get (HsKindSig ty _) = getl ty get (HsForAllTy _ tvs ctxt ty) = (extractHsCtxtTyNames ctxt diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index ed3e6d0..e2897ee 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -185,9 +185,9 @@ rnHsType doc (HsPredTy pred) = do pred' <- rnPred doc pred return (HsPredTy pred') -rnHsType _ (HsSpliceTy sp) - = do { (sp', _fvs) <- rnSplice sp -- ToDo: deal with fvs - ; return (HsSpliceTy sp') } +rnHsType _ (HsSpliceTy sp _ k) + = do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs + ; return (HsSpliceTy sp' fvs k) } rnHsType doc (HsDocTy ty haddock_doc) = do ty' <- rnLHsType doc ty @@ -200,7 +200,6 @@ rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHC rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq ; rnHsType doc (unLoc ty) } #endif -rnHsType _ (HsSpliceTyOut {}) = panic "rnHsType" rnLHsTypes :: SDoc -> [LHsType RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name] @@ -209,7 +208,7 @@ rnLHsTypes doc tys = mapM (rnLHsType doc) tys \begin{code} -rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName] +rnForAll :: SDoc -> HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name) rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 2d113b7..0fb82cb 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -528,7 +528,8 @@ mkGenericInstance clas (hs_ty, binds) = do -- and wrap them as forall'd tyvars, so that kind inference -- works in the standard way let - sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty))) + sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $ + extractHsTyVars (noLoc hs_ty) hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty) -- Type-check the instance type, and check its form diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index bcc2169..bb4bb8d 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -319,13 +319,10 @@ tcExtendKindEnv things thing_inside upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } extend env = extendNameEnvList env [(n, AThing k) | (n,k) <- things] -tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> TcM r -> TcM r +tcExtendKindEnvTvs :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -> TcM r tcExtendKindEnvTvs bndrs thing_inside - = updLclEnv upd thing_inside - where - upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } - extend env = extendNameEnvList env pairs - pairs = [(n, AThing k) | L _ (KindedTyVar n k) <- bndrs] + = tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs) + (thing_inside bndrs) tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r tcExtendTyVarEnv tvs thing_inside diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index bcf1f07..3fb1848 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -1598,7 +1598,8 @@ genAuxBind loc (GenCon2Tag tycon) get_tag_rhs = L loc $ ExprWithTySig (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR) (nlHsApp (nlHsVar getTag_RDR) a_Expr))) - (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty)) + (noLoc (mkExplicitHsForAllTy (userHsTyVarBndrs (map noLoc tvs)) + (noLoc []) con2tag_ty)) con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs) `nlHsFunTy` diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 64da3c0..62c5eaa 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -16,7 +16,7 @@ module TcHsType ( -- Typechecking kinded types tcHsKindedContext, tcHsKindedType, tcHsBangType, - tcTyVarBndrs, dsHsType, tcLHsConResTy, + tcTyVarBndrs, dsHsType, tcDataKindSig, ExpKind(..), EkCtxt(..), -- Pattern type signatures @@ -419,12 +419,11 @@ kc_hs_type ty@(HsRecTy _) -- should have been removed by now #ifdef GHCI /* Only if bootstrapped */ -kc_hs_type (HsSpliceTy sp) = kcSpliceType sp +kc_hs_type (HsSpliceTy sp fvs _) = kcSpliceType sp fvs #else kc_hs_type ty@(HsSpliceTy {}) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty) #endif -kc_hs_type (HsSpliceTyOut {}) = panic "kc_hs_type" -- Should not happen at all kc_hs_type (HsQuasiQuoteTy {}) = panic "kc_hs_type" -- Eliminated by renamer -- remove the doc nodes here, no need to worry about the location since @@ -624,11 +623,10 @@ ds_type (HsForAllTy _ tv_names ctxt ty) ds_type (HsDocTy ty _) -- Remove the doc comment = dsHsType ty -ds_type (HsSpliceTyOut kind) +ds_type (HsSpliceTy _ _ kind) = do { kind' <- zonkTcKindToKind kind ; newFlexiTyVarTy kind' } -ds_type (HsSpliceTy {}) = panic "ds_type" ds_type (HsQuasiQuoteTy {}) = panic "ds_type" -- Eliminated by renamer dsHsTypes :: [LHsType Name] -> TcM [Type] @@ -684,35 +682,7 @@ dsHsPred (HsIParam name ty) } \end{code} -GADT constructor signatures - \begin{code} -tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType]) -tcLHsConResTy (L span res_ty) - = setSrcSpan span $ - case get_args res_ty [] of - (HsTyVar tc_name, args) - -> do { args' <- mapM dsHsType args - ; thing <- tcLookup tc_name - ; case thing of - AGlobal (ATyCon tc) -> return (tc, args') - _ -> failWithTc (badGadtDecl res_ty) } - _ -> failWithTc (badGadtDecl res_ty) - where - -- We can't call dsHsType on res_ty, and then do tcSplitTyConApp_maybe - -- because that causes a black hole, and for good reason. Building - -- the type means expanding type synonyms, and we can't do that - -- inside the "knot". So we have to work by steam. - get_args (HsAppTy (L _ fun) arg) args = get_args fun (arg:args) - get_args (HsParTy (L _ ty)) args = get_args ty args - get_args (HsOpTy ty1 (L _ tc) ty2) args = (HsTyVar tc, ty1:ty2:args) - get_args ty args = (ty, args) - -badGadtDecl :: HsType Name -> SDoc -badGadtDecl ty - = hang (ptext (sLit "Malformed constructor result type:")) - 2 (ppr ty) - addKcTypeCtxt :: LHsType Name -> TcM a -> TcM a -- Wrap a context around only if we want to show that contexts. addKcTypeCtxt (L _ (HsPredTy _)) thing = thing @@ -735,14 +705,14 @@ kcHsTyVars :: [LHsTyVarBndr Name] -> ([LHsTyVarBndr Name] -> TcM r) -- These binders are kind-annotated -- They scope over the thing inside -> TcM r -kcHsTyVars tvs thing_inside = do - bndrs <- mapM (wrapLocM kcHsTyVar) tvs - tcExtendKindEnvTvs bndrs (thing_inside bndrs) +kcHsTyVars tvs thing_inside + = do { kinded_tvs <- mapM (wrapLocM kcHsTyVar) tvs + ; tcExtendKindEnvTvs kinded_tvs thing_inside } kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name) -- Return a *kind-annotated* binder, and a tyvar with a mutable kind in it -kcHsTyVar (UserTyVar name) = KindedTyVar name <$> newKindVar -kcHsTyVar (KindedTyVar name kind) = return (KindedTyVar name kind) +kcHsTyVar (UserTyVar name _) = UserTyVar name <$> newKindVar +kcHsTyVar tv@(KindedTyVar {}) = return tv ------------------ tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking @@ -754,10 +724,9 @@ tcTyVarBndrs bndrs thing_inside = do tyvars <- mapM (zonk . unLoc) bndrs tcExtendTyVarEnv tyvars (thing_inside tyvars) where - zonk (KindedTyVar name kind) = do { kind' <- zonkTcKindToKind kind - ; return (mkTyVar name kind') } - zonk (UserTyVar name) = WARN( True, ptext (sLit "Un-kinded tyvar") <+> ppr name ) - return (mkTyVar name liftedTypeKind) + zonk (UserTyVar name kind) = do { kind' <- zonkTcKindToKind kind + ; return (mkTyVar name kind') } + zonk (KindedTyVar name kind) = return (mkTyVar name kind) ----------------------------------- tcDataKindSig :: Maybe Kind -> TcM [TyVar] @@ -867,9 +836,9 @@ tcHsPatSigType ctxt hs_ty -- should be bound by the pattern signature in_scope <- getInLocalScope ; let span = getLoc hs_ty - sig_tvs = [ L span (UserTyVar n) - | n <- nameSetToList (extractHsTyVars hs_ty), - not (in_scope n) ] + sig_tvs = userHsTyVarBndrs $ map (L span) $ + filterOut in_scope $ + nameSetToList (extractHsTyVars hs_ty) ; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty ; checkValidType ctxt sig_ty diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 8ee43f5..d67a57b 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -46,6 +46,7 @@ import TcIface import TypeRep import Name import NameEnv +import NameSet import PrelNames import HscTypes import OccName @@ -284,7 +285,7 @@ The predicate we use is TcEnv.thTopLevelId. tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId) tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) -kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) +kcSpliceType :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind) -- None of these functions add constraints to the LIE lookupThName_maybe :: TH.Name -> TcM (Maybe Name) @@ -300,7 +301,7 @@ runAnnotation :: CoreAnnTarget -> LHsExpr Name -> TcM Annotation tcBracket x _ = pprPanic "Cant do tcBracket without GHCi" (ppr x) tcSpliceExpr e = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) tcSpliceDecls x = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr x) -kcSpliceType x = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) +kcSpliceType x fvs = pprPanic "Cant do kcSpliceType without GHCi" (ppr x) lookupThName_maybe n = pprPanic "Cant do lookupThName_maybe without GHCi" (ppr n) @@ -495,7 +496,7 @@ tcTopSpliceExpr tc_action Very like splicing an expression, but we don't yet share code. \begin{code} -kcSpliceType (HsSplice name hs_expr) +kcSpliceType splice@(HsSplice name hs_expr) fvs = setSrcSpan (getLoc hs_expr) $ do { stage <- getStage ; case stage of { @@ -518,11 +519,8 @@ kcSpliceType (HsSplice name hs_expr) -- Here (h 4) :: Q Type -- but $(h 4) :: a i.e. any type, of any kind - -- We return a HsSpliceTyOut, which serves to convey the kind to - -- the ensuing TcHsType.dsHsType, which makes up a non-committal - -- type variable of a suitable kind ; kind <- newKindVar - ; return (HsSpliceTyOut kind, kind) + ; return (HsSpliceTy splice fvs kind, kind) }}} kcTopSpliceType :: LHsExpr Name -> TcM (HsType Name, TcKind) diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot index 32d3e5a..d8cd81b 100644 --- a/compiler/typecheck/TcSplice.lhs-boot +++ b/compiler/typecheck/TcSplice.lhs-boot @@ -3,6 +3,7 @@ module TcSplice where import HsSyn ( HsSplice, HsBracket, HsQuasiQuote, HsExpr, HsType, LHsType, LHsExpr, LPat, LHsDecl ) import Name ( Name ) +import NameSet ( FreeVars ) import RdrName ( RdrName ) import TcRnTypes( TcM, TcId ) import TcType ( BoxyRhoType, TcKind ) @@ -13,7 +14,7 @@ tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId) -kcSpliceType :: HsSplice Name +kcSpliceType :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind) tcBracket :: HsBracket Name diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 9c3abc5..229e997 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -481,7 +481,7 @@ getInitialKind decl ; res_kind <- mk_res_kind decl ; return (tcdName decl, mkArrowKinds arg_kinds res_kind) } where - mk_arg_kind (UserTyVar _) = newKindVar + mk_arg_kind (UserTyVar _ _) = newKindVar mk_arg_kind (KindedTyVar _ kind) = return kind mk_res_kind (TyFamily { tcdKind = Just kind }) = return kind @@ -513,7 +513,7 @@ kcSynDecl (AcyclicSCC (L loc decl)) <+> brackets (ppr k_tvs)) ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl) ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl))) - ; let tc_kind = foldr (mkArrowKind . kindedTyVarKind) rhs_kind k_tvs + ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }), (unLoc (tcdLName decl), tc_kind)) }) @@ -521,10 +521,6 @@ kcSynDecl (CyclicSCC decls) = do { recSynErr decls; failM } -- Fail here to avoid error cascade -- of out-of-scope tycons -kindedTyVarKind :: LHsTyVarBndr Name -> Kind -kindedTyVarKind (L _ (KindedTyVar _ k)) = k -kindedTyVarKind x = pprPanic "kindedTyVarKind" (ppr x) - ------------------------------------------------------------------------ kcTyClDecl :: TyClDecl Name -> TcM (TyClDecl Name) -- Not used for type synonyms (see kcSynDecl) @@ -566,14 +562,16 @@ kcTyClDeclBody decl thing_inside = tcAddDeclCtxt decl $ do { tc_ty_thing <- tcLookupLocated (tcdLName decl) ; let tc_kind = case tc_ty_thing of - AThing k -> k - _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing) + AThing k -> k + _ -> pprPanic "kcTyClDeclBody" (ppr tc_ty_thing) (kinds, _) = splitKindFunTys tc_kind hs_tvs = tcdTyVars decl kinded_tvs = ASSERT( length kinds >= length hs_tvs ) - [ L loc (KindedTyVar (hsTyVarName tv) k) - | (L loc tv, k) <- zip hs_tvs kinds] - ; tcExtendKindEnvTvs kinded_tvs (thing_inside kinded_tvs) } + zipWith add_kind hs_tvs kinds + ; tcExtendKindEnvTvs kinded_tvs thing_inside } + where + add_kind (L loc (UserTyVar n _)) k = L loc (UserTyVar n k) + add_kind (L loc (KindedTyVar n _)) k = L loc (KindedTyVar n k) -- Kind check a data declaration, assuming that we already extended the -- kind environment with the type variables of the left-hand side (these @@ -633,11 +631,13 @@ kcFamilyDecl classTvs decl@(TyFamily {tcdKind = kind}) -- default result kind is '*' } where - unifyClassParmKinds (L _ (KindedTyVar n k)) - | Just classParmKind <- lookup n classTyKinds = unifyKind k classParmKind - | otherwise = return () - unifyClassParmKinds x = pprPanic "kcFamilyDecl/unifyClassParmKinds" (ppr x) - classTyKinds = [(n, k) | L _ (KindedTyVar n k) <- classTvs] + unifyClassParmKinds (L _ tv) + | (n,k) <- hsTyVarNameKind tv + , Just classParmKind <- lookup n classTyKinds + = unifyKind k classParmKind + | otherwise = return () + classTyKinds = [hsTyVarNameKind tv | L _ tv <- classTvs] + kcFamilyDecl _ (TySynonym {}) -- type family defaults = panic "TcTyClsDecls.kcFamilyDecl: not implemented yet" kcFamilyDecl _ d = pprPanic "kcFamilyDecl" (ppr d) -- 1.7.10.4