diff options
| author | mynguyen <mnguyen1@brynmawr.edu> | 2018-12-18 11:52:26 -0500 |
|---|---|---|
| committer | Richard Eisenberg <rae@cs.brynmawr.edu> | 2019-01-03 08:57:32 -0500 |
| commit | 17bd163566153babbf51adaff8397f948ae363ca (patch) | |
| tree | ef25e933481def276de4cdcad77eb4a34a76444b | |
| parent | 6e4e63764aaf558cf177c2a9c2da345b2a360ea6 (diff) | |
| download | haskell-17bd163566153babbf51adaff8397f948ae363ca.tar.gz | |
Visible kind application
Summary:
This patch implements visible kind application (GHC Proposal 15/#12045), as well as #15360 and #15362.
It also refactors unnamed wildcard handling, and requires that type equations in type families in Template Haskell be
written with full type on lhs. PartialTypeSignatures are on and warnings are off automatically with visible kind
application, just like in term-level.
There are a few remaining issues with this patch, as documented in
ticket #16082.
Includes a submodule update for Haddock.
Test Plan: Tests T12045a/b/c/TH1/TH2, T15362, T15592a
Reviewers: simonpj, goldfire, bgamari, alanz, RyanGlScott, Iceland_jack
Subscribers: ningning, Iceland_jack, RyanGlScott, int-index, rwbarton, mpickering, carter
GHC Trac Issues: `#12045`, `#15362`, `#15592`, `#15788`, `#15793`, `#15795`, `#15797`, `#15799`, `#15801`, `#15807`, `#15816`
Differential Revision: https://phabricator.haskell.org/D5229
141 files changed, 3059 insertions, 1204 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 9b2256e913..9906fc729b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -352,7 +352,7 @@ repRoleD _ = panic "repRoleD" repDataDefn :: Core TH.Name -> Either (Core [TH.TyVarBndrQ]) -- the repTyClD case - (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ]) + (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ) -- the repDataFamInstD case -> HsDataDefn GhcRn -> DsM (Core TH.DecQ) @@ -465,18 +465,28 @@ repAssocTyFamDefaults = mapM rep_deflt rep_deflt (dL->L _ (FamEqn { feqn_tycon = tc , feqn_bndrs = bndrs , feqn_pats = tys + , feqn_fixity = fixity , feqn_rhs = rhs })) = addTyClTyVarBinds tys $ \ _ -> do { tc1 <- lookupLOcc tc ; no_bndrs <- ASSERT( isNothing bndrs ) coreNothingList tyVarBndrQTyConName ; tys1 <- repLTys (hsLTyVarBndrsToTypes tys) - ; tys2 <- coreList typeQTyConName tys1 + ; lhs <- case fixity of + Prefix -> do { head_ty <- repNamedTyCon tc1 + ; repTapps head_ty tys1 } + Infix -> do { (t1:t2:args) <- checkTys tys1 + ; head_ty <- repTInfix t1 tc1 t2 + ; repTapps head_ty args } ; rhs1 <- repLTy rhs - ; eqn1 <- repTySynEqn no_bndrs tys2 rhs1 - ; repTySynInst tc1 eqn1 } + ; eqn1 <- repTySynEqn no_bndrs lhs rhs1 + ; repTySynInst eqn1 } rep_deflt _ = panic "repAssocTyFamDefaults" + checkTys :: [Core TH.TypeQ] -> DsM [Core TH.TypeQ] + checkTys tys@(_:_:_) = return tys + checkTys _ = panic "repAssocTyFamDefaults:checkTys" + ------------------------- -- represent fundeps -- @@ -547,18 +557,19 @@ repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat repStandaloneDerivD _ = panic "repStandaloneDerivD" repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ) -repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn }) - = do { let tc_name = tyFamInstDeclLName decl - ; tc <- lookupLOcc tc_name -- See note [Binders and occurrences] - ; eqn1 <- repTyFamEqn eqn - ; repTySynInst tc eqn1 } +repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) + = do { eqn1 <- repTyFamEqn eqn + ; repTySynInst eqn1 } repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ) repTyFamEqn (HsIB { hsib_ext = var_names - , hsib_body = FamEqn { feqn_bndrs = mb_bndrs + , hsib_body = FamEqn { feqn_tycon = tc_name + , feqn_bndrs = mb_bndrs , feqn_pats = tys + , feqn_fixity = fixity , feqn_rhs = rhs }}) - = do { let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn + = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = var_names , hsq_dependent = emptyNameSet } -- Yuk , hsq_explicit = fromMaybe [] mb_bndrs } @@ -566,21 +577,39 @@ repTyFamEqn (HsIB { hsib_ext = var_names do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName repTyVarBndr mb_bndrs - ; tys1 <- repLTys tys - ; tys2 <- coreList typeQTyConName tys1 + ; tys1 <- case fixity of + Prefix -> repTyArgs (repNamedTyCon tc) tys + Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys + ; t1' <- repLTy t1 + ; t2' <- repLTy t2 + ; repTyArgs (repTInfix t1' tc t2') args } ; rhs1 <- repLTy rhs - ; repTySynEqn mb_bndrs1 tys2 rhs1 } } + ; repTySynEqn mb_bndrs1 tys1 rhs1 } } + where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn] + checkTys tys@(HsValArg _:HsValArg _:_) = return tys + checkTys _ = panic "repTyFamEqn:checkTys" repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn" repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn" +repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ) +repTyArgs f [] = f +repTyArgs f (HsValArg ty : as) = do { f' <- f + ; ty' <- repLTy ty + ; repTyArgs (repTapp f' ty') as } +repTyArgs f (HsTypeArg ki : as) = do { f' <- f + ; ki' <- repLTy ki + ; repTyArgs (repTappKind f' ki') as } +repTyArgs f (HsArgPar _ : as) = repTyArgs f as + repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ) repDataFamInstD (DataFamInstDecl { dfid_eqn = (HsIB { hsib_ext = var_names , hsib_body = FamEqn { feqn_tycon = tc_name , feqn_bndrs = mb_bndrs , feqn_pats = tys + , feqn_fixity = fixity , feqn_rhs = defn }})}) - = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] + = do { tc <- lookupLOcc tc_name -- See note [Binders and occurrences] ; let hs_tvs = HsQTvs { hsq_ext = HsQTvsRn { hsq_implicit = var_names , hsq_dependent = emptyNameSet } -- Yuk @@ -589,8 +618,18 @@ repDataFamInstD (DataFamInstDecl { dfid_eqn = do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName repTyVarBndr mb_bndrs - ; tys1 <- repList typeQTyConName repLTy tys + ; tys1 <- case fixity of + Prefix -> repTyArgs (repNamedTyCon tc) tys + Infix -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys + ; t1' <- repLTy t1 + ; t2' <- repLTy t2 + ; repTyArgs (repTInfix t1' tc t2') args } ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } } + + where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn] + checkTys tys@(HsValArg _: HsValArg _: _) = return tys + checkTys _ = panic "repDataFamInstD:checkTys" + repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _)) = panic "repDataFamInstD" repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _))) @@ -1136,6 +1175,10 @@ repTy (HsAppTy _ f a) = do f1 <- repLTy f a1 <- repLTy a repTapp f1 a1 +repTy (HsAppKindTy _ ty ki) = do + ty1 <- repLTy ty + ki1 <- repLTy ki + repTappKind ty1 ki1 repTy (HsFunTy _ f a) = do f1 <- repLTy f a1 <- repLTy a @@ -1174,7 +1217,7 @@ repTy (HsExplicitTupleTy _ tys) = do repTy (HsTyLit _ lit) = do lit' <- repTyLit lit repTLit lit' -repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard +repTy (HsWildCardTy _) = repTWildCard repTy (HsIParamTy _ n t) = do n' <- rep_implicit_param_name (unLoc n) t' <- repLTy t @@ -2191,26 +2234,26 @@ repFun (MkC nm) (MkC b) = rep2 funDName [nm, b] repData :: Core TH.CxtQ -> Core TH.Name -> Either (Core [TH.TyVarBndrQ]) - (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ]) + (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ) -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ) repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs) = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs] -repData (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig) - (MkC cons) (MkC derivs) - = rep2 dataInstDName [cxt, nm, mb_bndrs, tys, ksig, cons, derivs] +repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons) + (MkC derivs) + = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs] repNewtype :: Core TH.CxtQ -> Core TH.Name -> Either (Core [TH.TyVarBndrQ]) - (Core (Maybe [TH.TyVarBndrQ]), Core [TH.TypeQ]) + (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ) -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ] -> DsM (Core TH.DecQ) repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con) (MkC derivs) = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs] -repNewtype (MkC cxt) (MkC nm) (Right (MkC mb_bndrs, MkC tys)) (MkC ksig) - (MkC con) (MkC derivs) - = rep2 newtypeInstDName [cxt, nm, mb_bndrs, tys, ksig, con, derivs] +repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con) + (MkC derivs) + = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs] repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ] -> Core TH.TypeQ -> DsM (Core TH.DecQ) @@ -2309,9 +2352,9 @@ repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phas repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ) repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e] -repTySynInst :: Core TH.Name -> Core TH.TySynEqnQ -> DsM (Core TH.DecQ) -repTySynInst (MkC nm) (MkC eqn) - = rep2 tySynInstDName [nm, eqn] +repTySynInst :: Core TH.TySynEqnQ -> DsM (Core TH.DecQ) +repTySynInst (MkC eqn) + = rep2 tySynInstDName [eqn] repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ] -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ) @@ -2336,7 +2379,7 @@ repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns) = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns] repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) -> - Core [TH.TypeQ] -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ) + Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ) repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs) = rep2 tySynEqnName [mb_bndrs, lhs, rhs] @@ -2429,6 +2472,9 @@ repTvar (MkC s) = rep2 varTName [s] repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ) repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2] +repTappKind :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ) +repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki] + repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ) repTapps f [] = return f repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } @@ -2467,6 +2513,10 @@ repTConstraint = rep2 constraintKName [] repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ) repNamedTyCon (MkC s) = rep2 conTName [s] +repTInfix :: Core TH.TypeQ -> Core TH.Name -> Core TH.TypeQ + -> DsM (Core TH.TypeQ) +repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2] + repTupleTyCon :: Int -> DsM (Core TH.TypeQ) -- Note: not Core Int; it's easier to be direct here repTupleTyCon i = do dflags <- getDynFlags diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs index 6fcc9243f8..eafafbbde9 100644 --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -328,6 +328,10 @@ instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans [loc a, loc tvs, loc b, loc c] loc _ = noSrcSpan +instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where + loc (HsValArg tm) = loc tm + loc (HsTypeArg ty) = loc ty + loc (HsArgPar sp) = sp instance HasLoc (HsDataDefn GhcRn) where loc def@(HsDataDefn{}) = loc $ dd_cons def @@ -1339,6 +1343,10 @@ instance ToHie (TScoped (LHsType GhcRn)) where [ toHie a , toHie b ] + HsAppKindTy _ ty ki -> + [ toHie ty + , toHie $ TS (ResolvedScopes []) ki + ] HsFunTy _ a b -> [ toHie a , toHie b @@ -1387,14 +1395,14 @@ instance ToHie (TScoped (LHsType GhcRn)) where [ toHie tys ] HsTyLit _ _ -> [] - HsWildCardTy e -> - [ toHie e - ] + HsWildCardTy _ -> [] HsStarTy _ _ -> [] XHsType _ -> [] -instance ToHie HsWildCardInfo where - toHie (AnonWildCard name) = toHie $ C Use name +instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where + toHie (HsValArg tm) = toHie tm + toHie (HsTypeArg ty) = toHie ty + toHie (HsArgPar sp) = pure $ locOnly sp instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 3c78a4c3d8..59b42bda0f 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -40,7 +40,7 @@ import Outputable import MonadUtils ( foldrM ) import qualified Data.ByteString as BS -import Control.Monad( unless, liftM, ap, (<=<) ) +import Control.Monad( unless, liftM, ap ) import Data.Maybe( catMaybes, isNothing ) import Language.Haskell.TH as TH hiding (sigP) @@ -296,8 +296,8 @@ cvtDec (DataFamilyD tc tvs kind) ; returnJustL $ TyClD noExt $ FamDecl noExt $ FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing } -cvtDec (DataInstD ctxt tc bndrs tys ksig constrs derivs) - = do { (ctxt', tc', bndrs', typats') <- cvt_tyinst_hdr ctxt tc bndrs tys +cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs) + = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys ; ksig' <- cvtKind `traverse` ksig ; cons' <- mapM cvtConstr constrs ; derivs' <- cvtDerivs derivs @@ -317,8 +317,8 @@ cvtDec (DataInstD ctxt tc bndrs tys ksig constrs derivs) , feqn_rhs = defn , feqn_fixity = Prefix } }}} -cvtDec (NewtypeInstD ctxt tc bndrs tys ksig constr derivs) - = do { (ctxt', tc', bndrs', typats') <- cvt_tyinst_hdr ctxt tc bndrs tys +cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs) + = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys ; ksig' <- cvtKind `traverse` ksig ; con' <- cvtConstr constr ; derivs' <- cvtDerivs derivs @@ -337,9 +337,8 @@ cvtDec (NewtypeInstD ctxt tc bndrs tys ksig constr derivs) , feqn_rhs = defn , feqn_fixity = Prefix } }}} -cvtDec (TySynInstD tc eqn) - = do { tc' <- tconNameL tc - ; (dL->L _ eqn') <- cvtTySynEqn tc' eqn +cvtDec (TySynInstD eqn) + = do { (dL->L _ eqn') <- cvtTySynEqn eqn ; returnJustL $ InstD noExt $ TyFamInstD { tfid_ext = noExt , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } } @@ -352,7 +351,7 @@ cvtDec (OpenTypeFamilyD head) cvtDec (ClosedTypeFamilyD head eqns) = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head - ; eqns' <- mapM (cvtTySynEqn tc') eqns + ; eqns' <- mapM cvtTySynEqn eqns ; returnJustL $ TyClD noExt $ FamDecl noExt $ FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix result' injectivity' } @@ -412,18 +411,35 @@ cvtDec (TH.ImplicitParamBindD _ _) = failWith (text "Implicit parameter binding only allowed in let or where") ---------------- -cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn GhcPs) -cvtTySynEqn tc (TySynEqn mb_bndrs lhs rhs) - = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs - ; lhs' <- mapM (wrap_apps <=< cvtType) lhs - ; rhs' <- cvtType rhs - ; returnL $ mkHsImplicitBndrs - $ FamEqn { feqn_ext = noExt - , feqn_tycon = tc - , feqn_bndrs = mb_bndrs' - , feqn_pats = lhs' - , feqn_fixity = Prefix - , feqn_rhs = rhs' } } +cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs) +cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) + = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs + ; (head_ty, args) <- split_ty_app lhs + ; case head_ty of + ConT nm -> do { nm' <- tconNameL nm + ; rhs' <- cvtType rhs + ; args' <- mapM wrap_tyargs args + ; returnL $ mkHsImplicitBndrs + $ FamEqn { feqn_ext = noExt + , feqn_tycon = nm' + , feqn_bndrs = mb_bndrs' + , feqn_pats = args' + , feqn_fixity = Prefix + , feqn_rhs = rhs' } } + InfixT t1 nm t2 -> do { nm' <- tconNameL nm + ; args' <- mapM cvtType [t1,t2] + ; rhs' <- cvtType rhs + ; returnL $ mkHsImplicitBndrs + $ FamEqn { feqn_ext = noExt + , feqn_tycon = nm' + , feqn_bndrs = mb_bndrs' + , feqn_pats = + (map HsValArg args') ++ args + , feqn_fixity = Hs.Infix + , feqn_rhs = rhs' } } + _ -> failWith $ text "Invalid type family instance LHS:" + <+> text (show lhs) + } ---------------- cvt_ci_decs :: MsgDoc -> [TH.Dec] @@ -458,17 +474,25 @@ cvt_tycl_hdr cxt tc tvs ; return (cxt', tc', tvs') } -cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> Maybe [TH.TyVarBndr] -> [TH.Type] +cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type -> CvtM ( LHsContext GhcPs , Located RdrName , Maybe [LHsTyVarBndr GhcPs] , HsTyPats GhcPs) -cvt_tyinst_hdr cxt tc bndrs tys - = do { cxt' <- cvtContext cxt - ; tc' <- tconNameL tc +cvt_datainst_hdr cxt bndrs tys + = do { cxt' <- cvtContext cxt ; bndrs' <- traverse (mapM cvt_tv) bndrs - ; tys' <- mapM (wrap_apps <=< cvtType) tys - ; return (cxt', tc', bndrs', tys') } + ; (head_ty, args) <- split_ty_app tys + ; case head_ty of + ConT nm -> do { nm' <- tconNameL nm + ; args' <- mapM wrap_tyargs args + ; return (cxt', nm', bndrs', args') } + InfixT t1 nm t2 -> do { nm' <- tconNameL nm + ; args' <- mapM cvtType [t1,t2] + ; return (cxt', nm', bndrs', + ((map HsValArg args') ++ args)) } + _ -> failWith $ text "Invalid type instance header:" + <+> text (show tys) } ---------------- cvt_tyfam_head :: TypeFamilyHead @@ -1299,54 +1323,67 @@ cvtType = cvtTypeKind "type" cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs) cvtTypeKind ty_str ty = do { (head_ty, tys') <- split_ty_app ty + ; let m_normals = mapM extract_normal tys' + where extract_normal (HsValArg ty) = Just ty + extract_normal _ = Nothing + ; case head_ty of TupleT n - | tys' `lengthIs` n -- Saturated - -> if n==1 then return (head tys') -- Singleton tuples treated - -- like nothing (ie just parens) - else returnL (HsTupleTy noExt - HsBoxedOrConstraintTuple tys') - | n == 1 - -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) - | otherwise - -> mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName (tupleTyCon Boxed n)))) tys' + | Just normals <- m_normals + , normals `lengthIs` n -- Saturated + -> if n==1 then return (head normals) -- Singleton tuples treated + -- like nothing (ie just parens) + else returnL (HsTupleTy noExt + HsBoxedOrConstraintTuple normals) + | n == 1 + -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) + | otherwise + -> mk_apps + (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n)))) + tys' UnboxedTupleT n - | tys' `lengthIs` n -- Saturated - -> returnL (HsTupleTy noExt HsUnboxedTuple tys') + | Just normals <- m_normals + , normals `lengthIs` n -- Saturated + -> returnL (HsTupleTy noExt HsUnboxedTuple normals) | otherwise - -> mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys' + -> mk_apps + (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n)))) + tys' UnboxedSumT n | n < 2 -> failWith $ vcat [ text "Illegal sum arity:" <+> text (show n) , nest 2 $ text "Sums must have an arity of at least 2" ] - | tys' `lengthIs` n -- Saturated - -> returnL (HsSumTy noExt tys') + | Just normals <- m_normals + , normals `lengthIs` n -- Saturated + -> returnL (HsSumTy noExt normals) | otherwise - -> mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName (sumTyCon n)))) - tys' + -> mk_apps + (HsTyVar noExt NotPromoted (noLoc (getRdrName (sumTyCon n)))) + tys' ArrowT - | [x',y'] <- tys' -> do + | Just normals <- m_normals + , [x',y'] <- normals -> do x'' <- case unLoc x' of HsFunTy{} -> returnL (HsParTy noExt x') HsForAllTy{} -> returnL (HsParTy noExt x') -- #14646 HsQualTy{} -> returnL (HsParTy noExt x') -- #15324 _ -> return x' returnL (HsFunTy noExt x'' y') - | otherwise -> - mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName funTyCon))) - tys' + | otherwise + -> mk_apps + (HsTyVar noExt NotPromoted (noLoc (getRdrName funTyCon))) + tys' ListT - | [x'] <- tys' -> returnL (HsListTy noExt x') - | otherwise -> - mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName listTyCon))) - tys' + | Just normals <- m_normals + , [x'] <- normals -> do + returnL (HsListTy noExt x') + | otherwise + -> mk_apps + (HsTyVar noExt NotPromoted (noLoc (getRdrName listTyCon))) + tys' + VarT nm -> do { nm' <- tNameL nm ; mk_apps (HsTyVar noExt NotPromoted nm') tys' } ConT nm -> do { nm' <- tconName nm @@ -1387,15 +1424,16 @@ cvtTypeKind ty_str ty -> do { s' <- tconName s ; t1' <- cvtType t1 ; t2' <- cvtType t2 - ; mk_apps (HsTyVar noExt NotPromoted (noLoc s')) - (t1' : t2' : tys') + ; mk_apps + (HsTyVar noExt NotPromoted (noLoc s')) + ([HsValArg t1', HsValArg t2'] ++ tys') } UInfixT t1 s t2 -> do { t2' <- cvtType t2 - ; t <- cvtOpAppT t1 s t2' -- Note [Converting UInfix] + ; t <- cvtOpAppT t1 s t2' ; mk_apps (unLoc t) tys' - } + } -- Note [Converting UInfix] ParensT t -> do { t' <- cvtType t @@ -1403,45 +1441,48 @@ cvtTypeKind ty_str ty } PromotedT nm -> do { nm' <- cName nm - ; let hs_ty = HsTyVar noExt IsPromoted (noLoc nm') - ; mk_apps hs_ty tys' } + ; mk_apps (HsTyVar noExt IsPromoted (noLoc nm')) + tys' } -- Promoted data constructor; hence cName PromotedTupleT n - | n == 1 - -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str))) - | m == n -- Saturated - -> returnL (HsExplicitTupleTy noExt tys') - | otherwise - -> mk_apps (HsTyVar noExt IsPromoted - (noLoc (getRdrName (tupleDataCon Boxed n)))) tys' - where - m = length tys' + | n == 1 + -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str))) + | Just normals <- m_normals + , normals `lengthIs` n -- Saturated + -> returnL (HsExplicitTupleTy noExt normals) + | otherwise + -> mk_apps + (HsTyVar noExt IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n)))) + tys' PromotedNilT -> mk_apps (HsExplicitListTy noExt IsPromoted []) tys' PromotedConsT -- See Note [Representing concrete syntax in types] -- in Language.Haskell.TH.Syntax - | [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- tys' - -> returnL (HsExplicitListTy noExt ip (ty1:tys2)) - | otherwise - -> mk_apps (HsTyVar noExt IsPromoted - (noLoc (getRdrName consDataCon))) - tys' + | Just normals <- m_normals + , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals + -> do + returnL (HsExplicitListTy noExt ip (ty1:tys2)) + | otherwise + -> mk_apps + (HsTyVar noExt IsPromoted (noLoc (getRdrName consDataCon))) + tys' StarT - -> mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName liftedTypeKindTyCon))) - tys' + -> mk_apps + (HsTyVar noExt NotPromoted (noLoc (getRdrName liftedTypeKindTyCon))) + tys' ConstraintT - -> mk_apps (HsTyVar noExt NotPromoted - (noLoc (getRdrName constraintKindTyCon))) - tys' + -> mk_apps + (HsTyVar noExt NotPromoted (noLoc (getRdrName constraintKindTyCon))) + tys' EqualityT - | [x',y'] <- tys' -> + | Just normals <- m_normals + , [x',y'] <- normals -> let px = parenthesizeHsType opPrec x' py = parenthesizeHsType opPrec y' in returnL (HsOpTy noExt px (noLoc eqTyCon_RDR) py) @@ -1462,21 +1503,35 @@ cvtTypeKind ty_str ty } -- | Constructs an application of a type to arguments passed in a list. -mk_apps :: HsType GhcPs -> [LHsType GhcPs] -> CvtM (LHsType GhcPs) +mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs) mk_apps head_ty [] = returnL head_ty -mk_apps head_ty (ty:tys) = +mk_apps head_ty (arg:args) = do { head_ty' <- returnL head_ty - ; p_ty <- add_parens ty - ; mk_apps (HsAppTy noExt head_ty' p_ty) tys } - where + ; case arg of + HsValArg ty -> do { p_ty <- add_parens ty + ; mk_apps (HsAppTy noExt head_ty' p_ty) args } + HsTypeArg ki -> do { p_ki <- add_parens ki + ; mk_apps (HsAppKindTy noExt head_ty' p_ki) args } + HsArgPar _ -> mk_apps (HsParTy noExt head_ty') args + } + where -- See Note [Adding parens for splices] add_parens lt@(dL->L _ t) | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt) | otherwise = return lt +-- See Note [Adding parens for splices] wrap_apps :: LHsType GhcPs -> CvtM (LHsType GhcPs) -wrap_apps t@(dL->L _ HsAppTy {}) = returnL (HsParTy noExt t) -wrap_apps t = return t +wrap_apps t@(dL->L _ HsAppTy {}) = returnL (HsParTy noExt t) +wrap_apps t@(dL->L _ HsAppKindTy {}) = returnL (HsParTy noExt t) +wrap_apps t = return t + +wrap_tyargs :: LHsTypeArg GhcPs -> CvtM (LHsTypeArg GhcPs) +wrap_tyargs (HsValArg ty) = do { ty' <- wrap_apps ty + ; return $ HsValArg ty'} +wrap_tyargs (HsTypeArg ki) = do { ki' <- wrap_apps ki + ; return $ HsTypeArg ki'} +wrap_tyargs argPar = return argPar -- --------------------------------------------------------------------- -- Note [Adding parens for splices] @@ -1508,10 +1563,12 @@ mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL go arg ret_ty = do { ret_ty_l <- returnL ret_ty ; return (HsFunTy noExt arg ret_ty_l) } -split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsType GhcPs]) +split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs]) split_ty_app ty = go ty [] where - go (AppT f a) as' = do { a' <- cvtType a; go f (a':as') } + go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') } + go (AppKindT ty ki) as' = do { ki' <- cvtKind ki; go ty (HsTypeArg ki':as') } + go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') } go f as = return (f,as) cvtTyLit :: TH.TyLit -> HsTyLit diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index c541a129ce..110c0fb488 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -901,13 +901,13 @@ data Sig pass -- -- > f :: Num a => a -> a -- - -- After renaming, this list of Names contains the named and unnamed + -- After renaming, this list of Names contains the named -- wildcards brought into scope by this signature. For a signature - -- @_ -> _a -> Bool@, the renamer will give the unnamed wildcard @_@ - -- a freshly generated name, e.g. @_w@. @_w@ and the named wildcard @_a@ - -- are then both replaced with fresh meta vars in the type. Their names - -- are stored in the type signature that brought them into scope, in - -- this third field to be more specific. + -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@ + -- untouched, and the named wildcard @_a@ is then replaced with + -- fresh meta vars in the type. Their names are stored in the type + -- signature that brought them into scope, in this third field to be + -- more specific. -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon', -- 'ApiAnnotation.AnnComma' diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index 246f8f9b9b..2b8c16311d 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -1525,7 +1525,7 @@ type LTyFamInstEqn pass = Located (TyFamInstEqn pass) type LTyFamDefltEqn pass = Located (TyFamDefltEqn pass) -- | Haskell Type Patterns -type HsTyPats pass = [LHsType pass] +type HsTyPats pass = [LHsTypeArg pass] {- Note [Family instance declaration binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/hsSyn/HsExtension.hs b/compiler/hsSyn/HsExtension.hs index 2dff478e55..9a017c250f 100644 --- a/compiler/hsSyn/HsExtension.hs +++ b/compiler/hsSyn/HsExtension.hs @@ -916,6 +916,7 @@ type family XForAllTy x type family XQualTy x type family XTyVar x type family XAppTy x +type family XAppKindTy x type family XFunTy x type family XListTy x type family XTupleTy x @@ -942,6 +943,7 @@ type ForallXType (c :: * -> Constraint) (x :: *) = , c (XQualTy x) , c (XTyVar x) , c (XAppTy x) + , c (XAppKindTy x) , c (XFunTy x) , c (XListTy x) , c (XTupleTy x) diff --git a/compiler/hsSyn/HsInstances.hs b/compiler/hsSyn/HsInstances.hs index 9a9f21d046..39507362cf 100644 --- a/compiler/hsSyn/HsInstances.hs +++ b/compiler/hsSyn/HsInstances.hs @@ -382,6 +382,10 @@ deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc) +deriving instance Data (LHsTypeArg GhcPs) +deriving instance Data (LHsTypeArg GhcRn) +deriving instance Data (LHsTypeArg GhcTc) + -- deriving instance (DataIdLR p p) => Data (ConDeclField p) deriving instance Data (ConDeclField GhcPs) deriving instance Data (ConDeclField GhcRn) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 4ab15b2625..73443587fe 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -8,6 +8,7 @@ HsTypes: Abstract syntax: user-defined types {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types] @@ -27,6 +28,8 @@ module HsTypes ( HsContext, LHsContext, noLHsContext, HsTyLit(..), HsIPName(..), hsIPNameFS, + HsArg(..), numVisibleArgs, + LHsTypeArg, LBangType, BangType, HsSrcBang(..), HsImplBang(..), @@ -42,8 +45,7 @@ module HsTypes ( rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc, unambiguousFieldOcc, ambiguousFieldOcc, - HsWildCardInfo(..), mkAnonWildCardTy, pprAnonWildCard, - wildCardName, sameWildCard, + mkAnonWildCardTy, pprAnonWildCard, mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, @@ -57,7 +59,7 @@ module HsTypes ( splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy, splitHsFunType, splitHsAppTys, hsTyGetAppHead_maybe, - mkHsOpTy, mkHsAppTy, mkHsAppTys, + mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy, ignoreParens, hsSigType, hsSigWcType, hsLTyVarBndrToType, hsLTyVarBndrsToTypes, @@ -88,6 +90,7 @@ import SrcLoc import Outputable import FastString import Maybes( isJust ) +import Util ( count ) import Data.Data hiding ( Fixity, Prefix, Infix ) @@ -187,8 +190,8 @@ A wildcard in a type can be * An anonymous wildcard, written '_' In HsType this is represented by HsWildCardTy. - After the renamer, this contains a Name which uniquely - identifies this particular occurrence. + The renamer leaves it untouched, and it is later given fresh meta tyvars in + the typechecker. * A named wildcard, written '_a', '_foo', etc @@ -208,9 +211,13 @@ Note carefully: Here _a is an ordinary forall'd binder, but (With NamedWildCards) _b is a named wildcard. (See the comments in Trac #10982) -* All wildcards, whether named or anonymous, are bound by the - HsWildCardBndrs construct, which wraps types that are allowed - to have wildcards. +* Named wildcards are bound by the HsWildCardBndrs construct, which wraps + types that are allowed to have wildcards. Unnamed wildcards however are left + unchanged until typechecking, where we give them fresh wild tyavrs and + determine whether or not to emit hole constraints on each wildcard + (we don't if it's a visible type/kind argument or a type family pattern). + See related notes Note [Wildcards in visible kind application] + and Note [Wildcards in visible type application] in TcHsType.hs * After type checking is done, we report what types the wildcards got unified with. @@ -371,7 +378,8 @@ data HsWildCardBndrs pass thing -- See Note [The wildcard story for types] = HsWC { hswc_ext :: XHsWC pass thing -- after the renamer - -- Wild cards, both named and anonymous + -- Wild cards, only named + -- See Note [Wildcards in visible kind application] , hswc_body :: thing -- Main payload (type or list of types) @@ -537,6 +545,10 @@ data HsType pass -- For details on above see note [Api annotations] in ApiAnnotation + | HsAppKindTy (XAppKindTy pass) -- type level type app + (LHsType pass) + (LHsKind pass) + | HsFunTy (XFunTy pass) (LHsType pass) -- function type (LHsType pass) @@ -667,8 +679,6 @@ data HsType pass | HsWildCardTy (XWildCardTy pass) -- A type wildcard -- See Note [The wildcard story for types] - -- A anonymous wild card ('_'). A fresh Name is generated for - -- each individual anonymous wildcard during renaming -- ^ - 'ApiAnnotation.AnnKeywordId' : None -- For details on above see note [Api annotations] in ApiAnnotation @@ -700,6 +710,8 @@ type instance XIParamTy (GhcPass _) = NoExt type instance XStarTy (GhcPass _) = NoExt type instance XKindSig (GhcPass _) = NoExt +type instance XAppKindTy (GhcPass _) = NoExt + type instance XSpliceTy GhcPs = NoExt type instance XSpliceTy GhcRn = NoExt type instance XSpliceTy GhcTc = Kind @@ -718,9 +730,7 @@ type instance XExplicitTupleTy GhcTc = [Kind] type instance XTyLit (GhcPass _) = NoExt -type instance XWildCardTy GhcPs = NoExt -type instance XWildCardTy GhcRn = HsWildCardInfo -type instance XWildCardTy GhcTc = HsWildCardInfo +type instance XWildCardTy (GhcPass _) = NoExt type instance XXType (GhcPass _) = NewHsTypeX @@ -733,11 +743,6 @@ data HsTyLit | HsStrTy SourceText FastString deriving Data -newtype HsWildCardInfo -- See Note [The wildcard story for types] - = AnonWildCard (Located Name) - deriving Data - -- A anonymous wild card ('_'). A fresh Name is generated for - -- each individual anonymous wildcard during renaming {- Note [HsForAllTy tyvar binders] @@ -1009,13 +1014,6 @@ hsLTyVarBndrsToTypes (HsQTvs { hsq_explicit = tvbs }) = map hsLTyVarBndrToType t hsLTyVarBndrsToTypes (XLHsQTyVars _) = panic "hsLTyVarBndrsToTypes" --------------------- -wildCardName :: HsWildCardInfo -> Name -wildCardName (AnonWildCard (L _ n)) = n - --- Two wild cards are the same when they have the same location -sameWildCard :: Located HsWildCardInfo -> Located HsWildCardInfo -> Bool -sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2 - ignoreParens :: LHsType pass -> LHsType pass ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty ignoreParens ty = ty @@ -1047,6 +1045,11 @@ mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p) mkHsAppTys = foldl' mkHsAppTy +mkHsAppKindTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) + -> LHsType (GhcPass p) +mkHsAppKindTy ty k + = addCLoc ty k (HsAppKindTy noExt ty k) + {- ************************************************************************ * * @@ -1068,7 +1071,9 @@ splitHsFunType (L _ (HsParTy _ ty)) splitHsFunType (L _ (HsFunTy _ x y)) | (args, res) <- splitHsFunType y = (x:args, res) - +{- This is not so correct, because it won't work with visible kind app, in case + someone wants to write '(->) @k1 @k2 t1 t2'. Fixing this would require changing + ConDeclGADT abstract syntax -} splitHsFunType orig_ty@(L _ (HsAppTy _ t1 t2)) = go t1 [t2] where -- Look for (->) t1 t2, possibly with parenthesisation @@ -1087,22 +1092,59 @@ splitHsFunType other = ([], other) -- used to examine the result of a GADT-like datacon, so it doesn't handle -- *all* cases (like lists, tuples, (~), etc.) hsTyGetAppHead_maybe :: LHsType (GhcPass p) - -> Maybe (Located (IdP (GhcPass p)), [LHsType (GhcPass p)]) -hsTyGetAppHead_maybe = go [] + -> Maybe (Located (IdP (GhcPass p))) +hsTyGetAppHead_maybe = go where - go tys (L _ (HsTyVar _ _ ln)) = Just (ln, tys) - go tys (L _ (HsAppTy _ l r)) = go (r : tys) l - go tys (L _ (HsOpTy _ l (L loc n) r)) = Just (L loc n, l : r : tys) - go tys (L _ (HsParTy _ t)) = go tys t - go tys (L _ (HsKindSig _ t _)) = go tys t - go _ _ = Nothing - -splitHsAppTys :: LHsType GhcRn -> [LHsType GhcRn] - -> (LHsType GhcRn, [LHsType GhcRn]) -splitHsAppTys (L _ (HsAppTy _ f a)) as = splitHsAppTys f (a:as) -splitHsAppTys (L _ (HsParTy _ f)) as = splitHsAppTys f as -splitHsAppTys f as = (f,as) + go (L _ (HsTyVar _ _ ln)) = Just ln + go (L _ (HsAppTy _ l _)) = go l + go (L _ (HsAppKindTy _ t _)) = go t + go (L _ (HsOpTy _ _ (L loc n) _)) = Just (L loc n) + go (L _ (HsParTy _ t)) = go t + go (L _ (HsKindSig _ t _)) = go t + go _ = Nothing + +------------------------------------------------------------ +-- Arguments in an expression/type after splitting +data HsArg tm ty + = HsValArg tm -- Argument is an ordinary expression (f arg) + | HsTypeArg ty -- Argument is a visible type application (f @ty) + | HsArgPar SrcSpan -- See Note [HsArgPar] + +numVisibleArgs :: [HsArg tm ty] -> Arity +numVisibleArgs = count is_vis + where is_vis (HsValArg _) = True + is_vis _ = False + +-- type level equivalent +type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) + +instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where + ppr (HsValArg tm) = ppr tm + ppr (HsTypeArg ty) = char '@' <> ppr ty + ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp +{- +Note [HsArgPar] +A HsArgPar indicates that everything to the left of this in the argument list is +enclosed in parentheses together with the function itself. It is necessary so +that we can recreate the parenthesis structure in the original source after +typechecking the arguments. +The SrcSpan is the span of the original HsPar + +((f arg1) arg2 arg3) results in an input argument list of +[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2] + +-} + +splitHsAppTys :: HsType GhcRn -> (LHsType GhcRn, [LHsTypeArg GhcRn]) +splitHsAppTys e = go (noLoc e) [] + where + go :: LHsType GhcRn -> [LHsTypeArg GhcRn] + -> (LHsType GhcRn, [LHsTypeArg GhcRn]) + go (L _ (HsAppTy _ f a)) as = go f (HsValArg a : as) + go (L _ (HsAppKindTy _ ty k)) as = go ty (HsTypeArg k : as) + go (L sp (HsParTy _ f)) as = go f (HsArgPar sp : as) + go f as = (f,as) -------------------------------- splitLHsPatSynTy :: LHsType pass -> ( [LHsTyVarBndr pass] -- universals @@ -1155,7 +1197,7 @@ getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) -- Works on (HsSigType RdrName) getLHsInstDeclClass_maybe inst_ty = do { let head_ty = getLHsInstDeclHead inst_ty - ; (cls, _) <- hsTyGetAppHead_maybe head_ty + ; cls <- hsTyGetAppHead_maybe head_ty ; return cls } {- @@ -1290,9 +1332,6 @@ instance (p ~ GhcPass pass,Outputable thing) ppr (HsWC { hswc_body = ty }) = ppr ty ppr (XHsWildCardBndrs x) = ppr x -instance Outputable HsWildCardInfo where - ppr (AnonWildCard _) = char '_' - pprAnonWildCard :: SDoc pprAnonWildCard = char '_' @@ -1418,7 +1457,8 @@ ppr_mono_ty (HsStarTy _ isUni) = char (if isUni then '★' else '*') ppr_mono_ty (HsAppTy _ fun_ty arg_ty) = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty] - +ppr_mono_ty (HsAppKindTy _ ty k) + = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2) = sep [ ppr_mono_lty ty1 , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ] @@ -1475,6 +1515,7 @@ hsTypeNeedsParens p = go go (HsWildCardTy{}) = False go (HsStarTy{}) = False go (HsAppTy{}) = p >= appPrec + go (HsAppKindTy{}) = p >= appPrec go (HsOpTy{}) = p >= opPrec go (HsParTy{}) = False go (HsDocTy _ (L _ t) _) = go t @@ -1516,6 +1557,7 @@ lhsTypeHasLeadingPromotionQuote ty go (HsWildCardTy{}) = False go (HsStarTy{}) = False go (HsAppTy _ t _) = goL t + go (HsAppKindTy _ t _) = goL t go (HsParTy{}) = False go (HsDocTy _ t _) = goL t go (XHsType{}) = False diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index eb899cc2fb..8cc3fb2cea 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -55,7 +55,7 @@ module HsUtils( mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup, -- Types - mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs, + mkHsAppTy, mkHsAppKindTy, userHsTyVarBndrs, userHsLTyVarBndrs, mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv, nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp, diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index cd41da53eb..685b2d451d 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -91,7 +91,7 @@ import GhcPrelude import qualified GHC.LanguageExtensions as LangExt } -%expect 236 -- shift/reduce conflicts +%expect 237 -- shift/reduce conflicts {- Last updated: 04 June 2018 @@ -134,13 +134,13 @@ state 60 contains 1 shift/reduce conflict. ------------------------------------------------------------------------------- -state 61 contains 46 shift/reduce conflicts. +state 61 contains 47 shift/reduce conflicts. *** btype -> tyapps . tyapps -> tyapps . tyapp - Conflicts: '_' ':' '~' '!' '.' '`' '{' '[' '[:' '(' '(#' '`' SIMPLEQUOTE - VARID CONID VARSYM CONSYM QCONID QVARSYM QCONSYM + Conflicts: '_' ':' '~' '!' '.' '`' '{' '[' '[:' '(' '(#' '`' TYPEAPP + SIMPLEQUOTE VARID CONID VARSYM CONSYM QCONID QVARSYM QCONSYM STRING INTEGER TH_ID_SPLICE '$(' TH_QUASIQUOTE TH_QQUASIQUOTE and all the special ids. @@ -1990,6 +1990,7 @@ tyapps :: { [Located TyEl] } -- NB: This list is reversed tyapp :: { Located TyEl } : atype { sL1 $1 $ TyElOpd (unLoc $1) } + | TYPEAPP atype { sLL $1 $> $ (TyElKindApp (getLoc $1) $2) } | qtyconop { sL1 $1 $ TyElOpr (unLoc $1) } | tyvarop { sL1 $1 $ TyElOpr (unLoc $1) } | SIMPLEQUOTE qconop {% ams (sLL $1 $> $ TyElOpr (unLoc $2)) @@ -2554,17 +2555,16 @@ infixexp :: { LHsExpr GhcPs } -- AnnVal annotation for NPlusKPat, which discards the operator infixexp_top :: { LHsExpr GhcPs } - : exp10_top { $1 } - | infixexp_top qop exp10_top - {% do { when (srcSpanEnd (getLoc $2) - == srcSpanStart (getLoc $3) - && checkIfBang $2) $ - warnSpaceAfterBang (comb2 $2 $3); - ams (sLL $1 $> (OpApp noExt $1 $2 $3)) - [mj AnnVal $2] - } - } - + : exp10_top { $1 } + | infixexp_top qop exp10_top + {% do { when (srcSpanEnd (getLoc $2) + == srcSpanStart (getLoc $3) + && checkIfBang $2) $ + warnSpaceAfterBang (comb2 $2 $3); + ams (sLL $1 $> (OpApp noExt $1 $2 $3)) + [mj AnnVal $2] + } + } exp10_top :: { LHsExpr GhcPs } : '-' fexp {% ams (sLL $1 $> $ NegApp noExt $2 noSyntaxExpr) diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 9712034b7a..4338968ecf 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -114,7 +114,7 @@ import DynFlags ( WarningFlag(..) ) import Control.Monad import Text.ParserCombinators.ReadP as ReadP import Data.Char - +import qualified Data.Monoid as Monoid import Data.Data ( dataTypeOf, fromConstr, dataTypeConstrs ) #include "HsVersions.h" @@ -804,7 +804,7 @@ to make setRdrNameSpace partial, so we just make an Unqual name instead. It really doesn't matter! -} -checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs] +checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] -> P (LHsQTyVars GhcPs) -- Same as checkTyVars, but in the P monad checkTyVarsP pp_what equals_or_where tc tparms @@ -818,7 +818,7 @@ eitherToP :: Either (SrcSpan, SDoc) a -> P a eitherToP (Left (loc, doc)) = parseErrorSDoc loc doc eitherToP (Right thing) = return thing -checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs] +checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs] -> Either (SrcSpan, SDoc) ( LHsQTyVars GhcPs -- the synthesized type variables , P () ) -- action which adds annotations @@ -827,9 +827,17 @@ checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsType GhcPs] -- We use the Either monad because it's also called (via 'mkATDefault') from -- "Convert". checkTyVars pp_what equals_or_where tc tparms - = do { (tvs, anns) <- fmap unzip $ mapM (chkParens []) tparms + = do { (tvs, anns) <- fmap unzip $ mapM check tparms ; return (mkHsQTvs tvs, sequence_ anns) } where + check (HsTypeArg ki@(L loc _)) = Left (loc, + vcat [ text "Unexpected type application" <+> + text "@" <> ppr ki + , text "In the" <+> pp_what <+> + ptext (sLit "declaration for") <+> quotes (ppr tc)]) + check (HsValArg ty) = chkParens [] ty + check (HsArgPar sp) = Left (sp, vcat [text "Malformed" <+> pp_what + <+> text "declaration for" <+> quotes (ppr tc)]) -- Keep around an action for adjusting the annotations of extra parens chkParens :: [AddAnn] -> LHsType GhcPs -> Either (SrcSpan, SDoc) (LHsTyVarBndr GhcPs, P ()) @@ -936,7 +944,7 @@ checkTyClHdr :: Bool -- True <=> class header -- False <=> type header -> LHsType GhcPs -> P (Located RdrName, -- the head symbol (type or class name) - [LHsType GhcPs], -- parameters of head symbol + [LHsTypeArg GhcPs], -- parameters of head symbol LexicalFixity, -- the declaration is in infix format [AddAnn]) -- API Annotation for HsParTy when stripping parens -- Well-formedness check and decomposition of type and class heads. @@ -957,12 +965,12 @@ checkTyClHdr is_cls ty go l (HsTyVar _ _ (dL->L _ tc)) acc ann fix | isRdrTc tc = return (cL l tc, acc, fix, ann) go _ (HsOpTy _ t1 ltc@(dL->L _ tc) t2) acc ann _fix - | isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann) + | isRdrTc tc = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann) go l (HsParTy _ ty) acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix - go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (t2:acc) ann fix - + go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix + go _ (HsAppKindTy _ ty ki) acc ann fix = goL ty (HsTypeArg ki:acc) ann fix go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix - = return (cL l (nameRdrName tup_name), ts, fix, ann) + = return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann) where arity = length ts tup_name | is_cls = cTupleTyConName arity @@ -1029,6 +1037,7 @@ checkContext (dL->L l orig_t) checkNoDocs :: SDoc -> LHsType GhcPs -> P () checkNoDocs msg ty = go ty where + go (dL->L _ (HsAppKindTy _ ty ki)) = go ty *> go ki go (dL->L _ (HsAppTy _ t1 t2)) = go t1 *> go t2 go (dL->L l (HsDocTy _ t ds)) = parseErrorSDoc l $ hsep [ text "Unexpected haddock", quotes (ppr ds) @@ -1366,6 +1375,7 @@ isFunLhs e = go e [] [] -- | Either an operator or an operand. data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) + | TyElKindApp SrcSpan (LHsType GhcPs) | TyElTilde | TyElBang | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness) | TyElDocPrev HsDocString @@ -1373,6 +1383,7 @@ data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs) instance Outputable TyEl where ppr (TyElOpr name) = ppr name ppr (TyElOpd ty) = ppr ty + ppr (TyElKindApp _ ki) = text "@" <> ppr ki ppr TyElTilde = text "~" ppr TyElBang = text "!" ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk @@ -1449,10 +1460,12 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs -- handle (NO)UNPACK pragmas go k acc ops_acc ((dL->L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) = if not (null acc) && null xs - then do { let a = ops_acc (mergeAcc acc) + then do { (addAccAnns, acc') <- eitherToP $ mergeOpsAcc acc + ; let a = ops_acc acc' strictMark = HsSrcBang unpkSrc unpk NoSrcStrict bl = combineSrcSpans l (getLoc a) bt = HsBangTy noExt strictMark a + ; addAccAnns ; addAnnsAt bl anns ; return (cL bl bt) } else parseErrorSDoc l unpkError @@ -1479,6 +1492,7 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs , let guess [] = True guess ((dL->L _ (TyElOpd _)):_) = False guess ((dL->L _ (TyElOpr _)):_) = True + guess ((dL->L _ (TyElKindApp _ _)):_) = False guess ((dL->L _ (TyElTilde)):_) = True guess ((dL->L _ (TyElBang)):_) = True guess ((dL->L _ (TyElUnpackedness _)):_) = True @@ -1487,7 +1501,9 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs -- due to #15884 in guess xs = if not (null acc) && (k > 1 || length acc > 1) - then failOpStrictnessCompound (cL l str) (ops_acc (mergeAcc acc)) + then do { (_, a) <- eitherToP (mergeOpsAcc acc) + -- no need to add annotations since it fails anyways! + ; failOpStrictnessCompound (cL l str) (ops_acc a) } else failOpStrictnessPosition (cL l str) -- clause [opr]: @@ -1497,8 +1513,9 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs go k acc ops_acc ((dL->L l (TyElOpr op)):xs) = if null acc || null (filter isTyElOpd xs) then failOpFewArgs (cL l op) - else do { let a = mergeAcc acc - ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc a)) xs } + else do { (addAccAnns, acc') <- eitherToP (mergeOpsAcc acc) + ; addAccAnns + ; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs } where isTyElOpd (dL->L _ (TyElOpd _)) = True isTyElOpd _ = False @@ -1515,20 +1532,38 @@ mergeOps all_xs = go (0 :: Int) [] id all_xs -- clause [opd]: -- whenever an operand is encountered, it is added to the accumulator - go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (cL l a:acc) ops_acc xs + go k acc ops_acc ((dL->L l (TyElOpd a)):xs) = go k (HsValArg (cL l a):acc) ops_acc xs + + -- clause [tyapp]: + -- whenever a type application is encountered, it is added to the accumulator + go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg (l, a):acc) ops_acc xs - -- clause [end]: + -- clause [end] -- See Note [Non-empty 'acc' in mergeOps clause [end]] - go _ acc ops_acc [] = - return (ops_acc (mergeAcc acc)) + go _ acc ops_acc [] = do { (addAccAnns, acc') <- eitherToP (mergeOpsAcc acc) + ; addAccAnns + ; return (ops_acc acc') } go _ _ _ _ = panic "mergeOps.go: Impossible Match" -- due to #15884 - - mergeAcc [] = panic "mergeOps.mergeAcc: empty input" - mergeAcc (x:xs) = mkHsAppTys x xs - +mergeOpsAcc :: [HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs)] + -> Either (SrcSpan, SDoc) (P (), LHsType GhcPs) +mergeOpsAcc [] = panic "mergeOpsAcc: empty input" +mergeOpsAcc (HsTypeArg (_, L loc ki):_) + = Left (loc, text "Unexpected type application:" <+> ppr ki) +mergeOpsAcc (HsValArg ty : xs) = go1 (pure ()) ty xs + where + go1 :: P () -> LHsType GhcPs + -> [HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs)] + -> Either (SrcSpan, SDoc) (P (), LHsType GhcPs) + go1 anns lhs [] = Right (anns, lhs) + go1 anns lhs (x:xs) = case x of + HsValArg ty -> go1 anns (mkHsAppTy lhs ty) xs + HsTypeArg (loc, ki) -> let ty = mkHsAppKindTy lhs ki + in go1 (addAnnotation (getLoc ty) AnnAt loc >> anns) ty xs + HsArgPar _ -> go1 anns lhs xs +mergeOpsAcc (HsArgPar _: xs) = mergeOpsAcc xs {- Note [Impossible case in mergeOps clause [unpk]] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1586,14 +1621,25 @@ pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) pInfixSide ((dL->L l (TyElOpd t)):xs) | (True, t', addAnns, xs') <- pBangTy (cL l t) xs = Just (t', addAnns, xs') -pInfixSide ((dL->L l1 (TyElOpd t1)):xs1) = go [cL l1 t1] xs1 - where - go acc ((dL->L l (TyElOpd t)):xs) = go (cL l t:acc) xs - go acc xs = Just (mergeAcc acc, pure (), xs) - mergeAcc [] = panic "pInfixSide.mergeAcc: empty input" - mergeAcc (x:xs) = mkHsAppTys x xs +pInfixSide (el:xs1) + | Just t1 <- pLHsTypeArg el + = go [t1] xs1 + where + go :: [HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs)] + -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl]) + go acc (el:xs) + | Just t <- pLHsTypeArg el + = go (t:acc) xs + go acc xs = case mergeOpsAcc acc of + Left _ -> Nothing + Right (addAnns, acc') -> Just (acc', addAnns, xs) pInfixSide _ = Nothing +pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs)) +pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a)) +pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg (l,a)) +pLHsTypeArg _ = Nothing + pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl]) pDocPrev = go Nothing where @@ -1735,8 +1781,10 @@ mergeDataCon all_xs = goFirst ((dL->L l (TyElOpd t)):xs) | (_, t', addAnns, xs') <- pBangTy (cL l t) xs = go addAnns Nothing [mkLHsDocTyMaybe t' trailingFieldDoc] xs' - goFirst xs = - go (pure ()) mTrailingDoc [] xs + goFirst (L l (TyElKindApp _ _):_) + = goInfix Monoid.<> Left (l, kindAppErr) + goFirst xs + = go (pure ()) mTrailingDoc [] xs go addAnns mLastDoc ts [ dL->L l (TyElOpd (HsTyVar _ _ (dL->L _ tc))) ] = do { data_con <- tyConToDataCon l tc @@ -1751,6 +1799,7 @@ mergeDataCon all_xs = -- Encountered an operator: backtrack to the beginning and attempt -- to parse as an infix definition. goInfix + go _ _ _ (L l (TyElKindApp _ _):_) = goInfix Monoid.<> Left (l, kindAppErr) go _ _ _ _ = Left malformedErr where malformedErr = @@ -1782,6 +1831,11 @@ mergeDataCon all_xs = text "in a data/newtype declaration:" $$ nest 2 (hsep . reverse $ map ppr all_xs')) + kindAppErr = + text "Unexpected kind application" <+> + text "in a data/newtype declaration:" $$ + nest 2 (hsep . reverse $ map ppr all_xs') + --------------------------------------------------------------------------- -- Check for monad comprehensions -- diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs index 7183a7edd6..40ef6a4062 100644 --- a/compiler/prelude/THNames.hs +++ b/compiler/prelude/THNames.hs @@ -96,8 +96,8 @@ templateHaskellNames = [ -- PatSynArgs (for pattern synonyms) prefixPatSynName, infixPatSynName, recordPatSynName, -- Type - forallTName, varTName, conTName, appTName, equalityTName, - tupleTName, unboxedTupleTName, unboxedSumTName, + forallTName, varTName, conTName, infixTName, appTName, appKindTName, + equalityTName, tupleTName, unboxedTupleTName, unboxedSumTName, arrowTName, listTName, sigTName, litTName, promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, wildCardTName, implicitParamTName, @@ -429,9 +429,9 @@ infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey -- data Type = ... -forallTName, varTName, conTName, tupleTName, unboxedTupleTName, - unboxedSumTName, arrowTName, listTName, appTName, sigTName, - equalityTName, litTName, promotedTName, +forallTName, varTName, conTName, infixTName, tupleTName, unboxedTupleTName, + unboxedSumTName, arrowTName, listTName, appTName, appKindTName, + sigTName, equalityTName, litTName, promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, wildCardTName, implicitParamTName :: Name forallTName = libFun (fsLit "forallT") forallTIdKey @@ -443,6 +443,7 @@ unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey arrowTName = libFun (fsLit "arrowT") arrowTIdKey listTName = libFun (fsLit "listT") listTIdKey appTName = libFun (fsLit "appT") appTIdKey +appKindTName = libFun (fsLit "appKindT") appKindTIdKey sigTName = libFun (fsLit "sigT") sigTIdKey equalityTName = libFun (fsLit "equalityT") equalityTIdKey litTName = libFun (fsLit "litT") litTIdKey @@ -451,6 +452,7 @@ promotedTupleTName = libFun (fsLit "promotedTupleT") promotedTupleTIdKey promotedNilTName = libFun (fsLit "promotedNilT") promotedNilTIdKey promotedConsTName = libFun (fsLit "promotedConsT") promotedConsTIdKey wildCardTName = libFun (fsLit "wildCardT") wildCardTIdKey +infixTName = libFun (fsLit "infixT") infixTIdKey implicitParamTName = libFun (fsLit "implicitParamT") implicitParamTIdKey -- data TyLit = ... @@ -949,19 +951,20 @@ recordPatSynIdKey = mkPreludeMiscIdUnique 382 -- data Type = ... forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, - unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey, - equalityTIdKey, litTIdKey, promotedTIdKey, + unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, appKindTIdKey, + sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey, promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey, - wildCardTIdKey, implicitParamTIdKey :: Unique -forallTIdKey = mkPreludeMiscIdUnique 391 -varTIdKey = mkPreludeMiscIdUnique 392 -conTIdKey = mkPreludeMiscIdUnique 393 -tupleTIdKey = mkPreludeMiscIdUnique 394 -unboxedTupleTIdKey = mkPreludeMiscIdUnique 395 -unboxedSumTIdKey = mkPreludeMiscIdUnique 396 -arrowTIdKey = mkPreludeMiscIdUnique 397 -listTIdKey = mkPreludeMiscIdUnique 398 -appTIdKey = mkPreludeMiscIdUnique 399 + wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique +forallTIdKey = mkPreludeMiscIdUnique 390 +varTIdKey = mkPreludeMiscIdUnique 391 +conTIdKey = mkPreludeMiscIdUnique 392 +tupleTIdKey = mkPreludeMiscIdUnique 393 +unboxedTupleTIdKey = mkPreludeMiscIdUnique 394 +unboxedSumTIdKey = mkPreludeMiscIdUnique 395 +arrowTIdKey = mkPreludeMiscIdUnique 396 +listTIdKey = mkPreludeMiscIdUnique 397 +appTIdKey = mkPreludeMiscIdUnique 398 +appKindTIdKey = mkPreludeMiscIdUnique 399 sigTIdKey = mkPreludeMiscIdUnique 400 equalityTIdKey = mkPreludeMiscIdUnique 401 litTIdKey = mkPreludeMiscIdUnique 402 @@ -971,6 +974,7 @@ promotedNilTIdKey = mkPreludeMiscIdUnique 405 promotedConsTIdKey = mkPreludeMiscIdUnique 406 wildCardTIdKey = mkPreludeMiscIdUnique 407 implicitParamTIdKey = mkPreludeMiscIdUnique 408 +infixTIdKey = mkPreludeMiscIdUnique 409 -- data TyLit = ... numTyLitIdKey, strTyLitIdKey :: Unique diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index c76eb31abc..5ec4e05cd1 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -652,7 +652,7 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty' ; let cls = case hsTyGetAppHead_maybe head_ty' of Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>")) - Just (dL->L _ cls, _) -> cls + Just (dL->L _ cls) -> cls -- rnLHsInstType has added an error message -- if hsTyGetAppHead_maybe fails @@ -710,7 +710,7 @@ rnFamInstEqn doc mb_cls rhs_kvars , feqn_fixity = fixity , feqn_rhs = payload }}) rn_payload = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon - ; let pat_kity_vars_with_dups = extractHsTysRdrTyVarsDups pats + ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats -- Use the "...Dups" form because it's needed -- below to report unsed binder on the LHS ; let pat_kity_vars = rmDupsInRdrTyVars pat_kity_vars_with_dups @@ -745,7 +745,7 @@ rnFamInstEqn doc mb_cls rhs_kvars -- the user meant to bring in scope here. This is an explicit -- forall, so we want fresh names, not class variables. -- Thus: always pass Nothing - do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats + do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats ; (payload', rhs_fvs) <- rn_payload doc payload -- Report unused binders on the LHS @@ -780,16 +780,10 @@ rnFamInstEqn doc mb_cls rhs_kvars ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) } - ; let anon_wcs = concatMap collectAnonWildCards pats' - all_ibs = anon_wcs ++ all_imp_var_names - -- all_ibs: include anonymous wildcards in the implicit - -- binders In a type pattern they behave just like any - -- other type variable except for being anoymous. See - -- Note [Wildcards in family instances] - all_fvs = fvs `addOneFV` unLoc tycon' - -- type instance => use, hence addOneFV + ; let all_fvs = fvs `addOneFV` unLoc tycon' + -- type instance => use, hence addOneFV - ; return (HsIB { hsib_ext = all_ibs + ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances] , hsib_body = FamEqn { feqn_ext = noExt , feqn_tycon = tycon' @@ -915,12 +909,13 @@ is the same as type family F a b :: * type instance F Int b = Int -This is implemented as follows: during renaming anonymous wild cards -'_' are given freshly generated names. These names are collected after -renaming (rnFamInstEqn) and used to make new type variables during -type checking (tc_fam_ty_pats). One should not confuse these wild -cards with the ones from partial type signatures. The latter generate -fresh meta-variables whereas the former generate fresh skolems. +This is implemented as follows: Unnamed wildcards remain unchanged after +the renamer, and then given fresh meta-variables during typechecking, and +it is handled pretty much the same way as the ones in partial type signatures. +We however don't want to emit hole constraints on wildcards in family +instances, so we turn on PartialTypeSignatures and turn off warning flag to +let typechecker know this. +See related Note [Wildcards in visible kind application] in TcHsType.hs Note [Unused type variables in family instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index a3062f1d76..735456dfee 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -12,11 +12,11 @@ module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, - rnHsKind, rnLHsKind, + rnHsKind, rnLHsKind, rnLHsTypeArgs, rnHsSigType, rnHsWcType, HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped, rnLHsInstType, - newTyVarNameRn, collectAnonWildCards, + newTyVarNameRn, rnConDeclFields, rnLTyVar, @@ -32,7 +32,7 @@ module RnTypes ( extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars, extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars, extractRdrKindSigVars, extractDataDefnKindVars, - extractHsTvBndrs, + extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup, freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars, elemRdr ) where @@ -166,8 +166,7 @@ rnWcBody ctxt nwc_rdrs hs_ty , rtke_ctxt = ctxt } ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $ rn_lty env hs_ty - ; let awcs = collectAnonWildCards hs_ty' - ; return (nwcs ++ awcs, hs_ty', fvs) } + ; return (nwcs, hs_ty', fvs) } where rn_lty env (dL->L loc hs_ty) = setSrcSpan loc $ @@ -187,10 +186,8 @@ rnWcBody ctxt nwc_rdrs hs_ty | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt , (dL->L lx (HsWildCardTy _)) <- ignoreParens hs_ctxt_last = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1 - ; wc' <- setSrcSpan lx $ - do { checkExtraConstraintWildCard env hs_ctxt1 - ; rnAnonWildCard } - ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy wc')] + ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1 + ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExt)] ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty ; return (HsQualTy { hst_xqual = noExt , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' } @@ -490,6 +487,22 @@ rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind rnHsKind :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars) rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind +-- renaming a type only, not a kind +rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs + -> RnM (LHsTypeArg GhcRn, FreeVars) +rnLHsTypeArg ctxt (HsValArg ty) + = do { (tys_rn, fvs) <- rnLHsType ctxt ty + ; return (HsValArg tys_rn, fvs) } +rnLHsTypeArg ctxt (HsTypeArg ki) + = do { (kis_rn, fvs) <- rnLHsKind ctxt ki + ; return (HsTypeArg kis_rn, fvs) } +rnLHsTypeArg _ (HsArgPar sp) + = return (HsArgPar sp, emptyFVs) + +rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs] + -> RnM ([LHsTypeArg GhcRn], FreeVars) +rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args + -------------- rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars) @@ -630,6 +643,13 @@ rnHsTyKi env (HsAppTy _ ty1 ty2) ; (ty2', fvs2) <- rnLHsTyKi env ty2 ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) } +rnHsTyKi env (HsAppKindTy _ ty k) + = do { kind_app <- xoptM LangExt.TypeApplications + ; unless kind_app (addErr (typeAppErr k)) + ; (ty', fvs1) <- rnLHsTyKi env ty + ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k + ; return (HsAppKindTy noExt ty' k', fvs1 `plusFV` fvs2) } + rnHsTyKi env t@(HsIParamTy _ n ty) = do { notInKinds env t ; (ty', fvs) <- rnLHsTyKi env ty @@ -667,11 +687,7 @@ rnHsTyKi env ty@(HsExplicitTupleTy _ tys) rnHsTyKi env (HsWildCardTy _) = do { checkAnonWildCard env - ; wc' <- rnAnonWildCard - ; return (HsWildCardTy wc', emptyFVs) } - -- emptyFVs: this occurrence does not refer to a - -- user-written binding site, so don't treat - -- it as a free variable + ; return (HsWildCardTy noExt, emptyFVs) } -------------- rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name @@ -760,12 +776,7 @@ wildCardsAllowed env HsTypeCtx {} -> True _ -> False -rnAnonWildCard :: RnM HsWildCardInfo -rnAnonWildCard - = do { loc <- getSrcSpanM - ; uniq <- newUnique - ; let name = mkInternalName uniq (mkTyVarOcc "_") loc - ; return (AnonWildCard (cL loc name)) } + --------------- -- | Ensures either that we're in a type or that -XPolyKinds is set @@ -1051,49 +1062,6 @@ newTyVarNameRn mb_assoc (dL->L loc rdr) -- Use the same Name as the parent class decl _ -> newLocalBndrRn (cL loc rdr) } - ---------------------- -collectAnonWildCards :: LHsType GhcRn -> [Name] --- | Extract all wild cards from a type. -collectAnonWildCards lty = go lty - where - go lty = case unLoc lty of - HsWildCardTy (AnonWildCard wc) -> [unLoc wc] - HsAppTy _ ty1 ty2 -> go ty1 `mappend` go ty2 - HsFunTy _ ty1 ty2 -> go ty1 `mappend` go ty2 - HsListTy _ ty -> go ty - HsTupleTy _ _ tys -> gos tys - HsSumTy _ tys -> gos tys - HsOpTy _ ty1 _ ty2 -> go ty1 `mappend` go ty2 - HsParTy _ ty -> go ty - HsIParamTy _ _ ty -> go ty - HsKindSig _ ty kind -> go ty `mappend` go kind - HsDocTy _ ty _ -> go ty - HsBangTy _ _ ty -> go ty - HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds - HsExplicitListTy _ _ tys -> gos tys - HsExplicitTupleTy _ tys -> gos tys - HsForAllTy { hst_bndrs = bndrs - , hst_body = ty } -> collectAnonWildCardsBndrs bndrs - `mappend` go ty - HsQualTy { hst_ctxt = ctxt - , hst_body = ty } -> gos (unLoc ctxt) `mappend` go ty - HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ cL noSrcSpan ty - HsSpliceTy{} -> mempty - HsTyLit{} -> mempty - HsTyVar{} -> mempty - HsStarTy{} -> mempty - XHsType{} -> mempty - - gos = mconcat . map go - -collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name] -collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs - where - go (UserTyVar _ _) = [] - go (KindedTyVar _ _ ki) = collectAnonWildCards ki - go (XTyVarBndr{}) = [] - {- ********************************************************* * * @@ -1509,6 +1477,10 @@ opTyErr op overall_ty | otherwise = text "Use TypeOperators to allow operators in types" +typeAppErr :: LHsKind GhcPs -> SDoc +typeAppErr (L _ k) + = hang (text "Illegal visible kind application" <+> quotes (ppr k)) + 2 (text "Perhaps you intended to use TypeApplications") {- ************************************************************************ * * @@ -1667,6 +1639,19 @@ inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env -- When the same name occurs multiple times in the types, only the first -- occurrence is returned. -- See Note [Kind and type-variable binders] + + +extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups +extract_tyarg (HsValArg ty) acc = extract_lty TypeLevel ty acc +extract_tyarg (HsTypeArg ki) acc = extract_lty KindLevel ki acc +extract_tyarg (HsArgPar _) acc = acc + +extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups +extract_tyargs args acc = foldr extract_tyarg acc args + +extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups +extractHsTyArgRdrKiTyVarsDup args = extract_tyargs args emptyFKTV + extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups extractHsTyRdrTyVars ty = rmDupsInRdrTyVars (extractHsTyRdrTyVarsDups ty) @@ -1808,6 +1793,8 @@ extract_lty t_or_k (dL->L _ ty) acc flds HsAppTy _ ty1 ty2 -> extract_lty t_or_k ty1 $ extract_lty t_or_k ty2 acc + HsAppKindTy _ ty k -> extract_lty t_or_k ty $ + extract_lty KindLevel k acc HsListTy _ ty -> extract_lty t_or_k ty acc HsTupleTy _ _ tys -> extract_ltys t_or_k tys acc HsSumTy _ tys -> extract_ltys t_or_k tys acc diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 4bbb42d4b3..dd5078660d 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -717,7 +717,7 @@ tcStandaloneDerivInstType ctxt , hsib_body = deriv_ty_body })}) | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body , L _ [wc_pred] <- theta - , L _ (HsWildCardTy (AnonWildCard (L wc_span _))) <- ignoreParens wc_pred + , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred = do dfun_ty <- tcHsClsInstType ctxt $ HsIB { hsib_ext = vars , hsib_body diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 3b8d2c9a1e..63cb35194c 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -1093,24 +1093,7 @@ arithSeqEltType (Just fl) res_ty ************************************************************************ -} -data HsArg tm ty - = HsValArg tm -- Argument is an ordinary expression (f arg) - | HsTypeArg ty -- Argument is a visible type application (f @ty) - | HsArgPar SrcSpan -- See Note [HsArgPar] - -{- -Note [HsArgPar] -A HsArgPar indicates that everything to the left of this in the argument list is -enclosed in parentheses together with the function itself. It is necessary so -that we can recreate the parenthesis structure in the original source after -typechecking the arguments. - -The SrcSpan is the span of the original HsPar - -((f arg1) arg2 arg3) results in an input argument list of -[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2] - --} +-- HsArg is defined in HsTypes.hs wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn) => LHsExpr (GhcPass id) @@ -1121,11 +1104,6 @@ wrapHsArgs f (HsValArg a : args) = wrapHsArgs (mkHsApp f a) args wrapHsArgs f (HsTypeArg t : args) = wrapHsArgs (mkHsAppType f t) args wrapHsArgs f (HsArgPar sp : args) = wrapHsArgs (L sp $ HsPar noExt f) args -instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where - ppr (HsValArg tm) = text "HsValArg" <+> ppr tm - ppr (HsTypeArg ty) = text "HsTypeArg" <+> ppr ty - ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp - isHsValArg :: HsArg tm ty -> Bool isHsValArg (HsValArg {}) = True isHsValArg (HsTypeArg {}) = False @@ -1340,8 +1318,8 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald ; inner_ty <- zonkTcType inner_ty -- See Note [Visible type application zonk] - ; let in_scope = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg]) + insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty -- NB: tv and ty_arg have the same kind, so this -- substitution is kind-respecting diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index 56a0ea0c34..7f4e379fef 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -46,7 +46,7 @@ module TcHsType ( typeLevelMode, kindLevelMode, - kindGeneralize, checkExpectedKindX, + kindGeneralize, checkExpectedKind, RequireSaturation(..), reportFloatingKvs, -- Sort-checking kinds @@ -79,8 +79,9 @@ import TcHsSyn import TcErrors ( reportAllUnsolved ) import TcType import Inst ( tcInstTyBinders, tcInstTyBinder ) -import TyCoRep( TyCoBinder(..), TyBinder ) -- Used in etaExpandAlgTyCon +import TyCoRep( TyCoBinder(..), TyBinder, tyCoBinderArgFlag ) -- Used in etaExpandAlgTyCon import Type +import TysPrim import Coercion import RdrName( lookupLocalRdrOcc ) import Var @@ -104,6 +105,7 @@ import UniqSupply import Outputable import FastString import PrelNames hiding ( wildCardName ) +import DynFlags ( WarningFlag (Opt_WarnPartialTypeSignatures) ) import qualified GHC.LanguageExtensions as LangExt import Maybes @@ -362,6 +364,9 @@ tcHsTypeApp wc_ty kind = do { ty <- solveLocalEqualities "tcHsTypeApp" $ -- We are looking at a user-written type, very like a -- signature so we want to solve its equalities right now + unsetWOptM Opt_WarnPartialTypeSignatures $ + setXOptM LangExt.PartialTypeSignatures $ + -- See Note [Wildcards in visible type application] tcWildCardBinders sig_wcs $ \ _ -> tcCheckLHsType hs_ty kind -- We must promote here. Ex: @@ -373,11 +378,24 @@ tcHsTypeApp wc_ty kind ; ty <- zonkPromoteType ty ; checkValidType TypeAppCtxt ty ; return ty } - -- NB: we don't call emitWildcardHoleConstraints here, because - -- we want any holes in visible type applications to be used - -- without fuss. No errors, warnings, extensions, etc. tcHsTypeApp (XHsWildCardBndrs _) _ = panic "tcHsTypeApp" +{- Note [Wildcards in visible type application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A HsWildCardBndrs's hswc_ext now only includes named wildcards, so any unnamed +wildcards stay unchanged in hswc_body and when called in tcHsTypeApp, tcCheckLHsType +will call emitWildCardHoleConstraints on them. However, this would trigger +error/warning when an unnamed wildcard is passed in as a visible type argument, +which we do not want because users should be able to write @_ to skip a instantiating +a type variable variable without fuss. The solution is to switch the +PartialTypeSignatures flags here to let the typechecker know that it's checking +a '@_' and do not emit hole constraints on it. +See related Note [Wildcards in visible kind application] +and Note [The wildcard story for types] in HsTypes.hs + +-} + {- ************************************************************************ * * @@ -432,30 +450,39 @@ concern things that the renamer can't handle. -} +-- | Do we require type families to be saturated? +data RequireSaturation + = YesSaturation + | NoSaturation -- e.g. during a call to GHCi's :kind + -- | Info about the context in which we're checking a type. Currently, -- differentiates only between types and kinds, but this will likely -- grow, at least to include the distinction between patterns and -- not-patterns. data TcTyMode = TcTyMode { mode_level :: TypeOrKind - , mode_unsat :: Bool -- True <=> allow unsaturated type families + , mode_sat :: RequireSaturation } -- The mode_unsat field is solely so that type families/synonyms can be unsaturated -- in GHCi :kind calls typeLevelMode :: TcTyMode -typeLevelMode = TcTyMode { mode_level = TypeLevel, mode_unsat = False } +typeLevelMode = TcTyMode { mode_level = TypeLevel, mode_sat = YesSaturation } kindLevelMode :: TcTyMode -kindLevelMode = TcTyMode { mode_level = KindLevel, mode_unsat = False } +kindLevelMode = TcTyMode { mode_level = KindLevel, mode_sat = YesSaturation } allowUnsaturated :: TcTyMode -> TcTyMode -allowUnsaturated mode = mode { mode_unsat = True } +allowUnsaturated mode = mode { mode_sat = NoSaturation } -- switch to kind level kindLevel :: TcTyMode -> TcTyMode kindLevel mode = mode { mode_level = KindLevel } +instance Outputable RequireSaturation where + ppr YesSaturation = text "YesSaturation" + ppr NoSaturation = text "NoSaturation" + instance Outputable TcTyMode where ppr = ppr . mode_level @@ -553,17 +580,14 @@ tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) tc_infer_hs_type mode (HsParTy _ t) = tc_infer_lhs_type mode t tc_infer_hs_type mode (HsTyVar _ _ (L _ tv)) = tcTyVar mode tv -tc_infer_hs_type mode (HsAppTy _ ty1 ty2) - = do { let (hs_fun_ty, hs_arg_tys) = splitHsAppTys ty1 [ty2] - ; (fun_ty, fun_kind) <- tc_infer_lhs_type mode hs_fun_ty - -- NB: (IT4) of Note [The tcType invariant] ensures that fun_kind is zonked - ; tcTyApps mode hs_fun_ty fun_ty fun_kind hs_arg_tys } +tc_infer_hs_type mode e@(HsAppTy {}) = tcTyApp mode e +tc_infer_hs_type mode e@(HsAppKindTy {}) = tcTyApp mode e tc_infer_hs_type mode (HsOpTy _ lhs lhs_op@(L _ hs_op) rhs) | not (hs_op `hasKey` funTyConKey) = do { (op, op_kind) <- tcTyVar mode hs_op ; tcTyApps mode (noLoc $ HsTyVar noExt NotPromoted lhs_op) op op_kind - [lhs, rhs] } + [HsValArg lhs, HsValArg rhs] } tc_infer_hs_type mode (HsKindSig _ ty sig) = do { sig' <- tcLHsKindSig KindSigCtxt sig @@ -588,6 +612,13 @@ tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty tc_infer_hs_type _ (XHsType (NHsCoreTy ty)) = do { ty <- zonkTcType ty -- (IT3) and (IT4) of Note [The tcType invariant] ; return (ty, tcTypeKind ty) } + +tc_infer_hs_type _ (HsExplicitListTy _ _ tys) + | null tys -- this is so that we can use visible kind application with '[] + -- e.g ... '[] @Bool + = return (mkTyConTy promotedNilDataCon, + mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy) + tc_infer_hs_type mode other_ty = do { kv <- newMetaKindVar ; ty' <- tc_hs_type mode other_ty kv @@ -608,12 +639,12 @@ tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of ; res_k <- newOpenTypeKind ; ty1' <- tc_lhs_type mode ty1 arg_k ; ty2' <- tc_lhs_type mode ty2 res_k - ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2') + ; checkExpectedKindMode mode (ppr $ HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2') liftedTypeKind exp_kind } KindLevel -> -- no representation polymorphism in kinds. yet. do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind - ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2') + ; checkExpectedKindMode mode (ppr $ HsFunTy noExt ty1 ty2) (mkFunTy ty1' ty2') liftedTypeKind exp_kind } ------------------------------------------ @@ -692,7 +723,7 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind -- The body kind (result of the function) -- can be TYPE r, for any r, hence newOpenTypeKind ; ty' <- tc_lhs_type mode ty ek - ; checkExpectedKind (unLoc ty) ty' liftedTypeKind exp_kind } + ; checkExpectedKindMode mode (ppr ty) ty' liftedTypeKind exp_kind } ; return (mkPhiTy ctxt' ty') } @@ -700,7 +731,7 @@ tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = ty }) exp_kind tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind ; checkWiredInTyCon listTyCon - ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind } + ; checkExpectedKindMode mode (ppr rn_ty) (mkListTy tau_ty) liftedTypeKind exp_kind } -- See Note [Distinguishing tuple kinds] in HsTypes -- See Note [Inferring tuple kinds] @@ -726,10 +757,10 @@ tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind -- In the [] case, it's not clear what the kind is, so guess * ; tys' <- sequence [ setSrcSpan loc $ - checkExpectedKind hs_ty ty kind arg_kind + checkExpectedKindMode mode (ppr hs_ty) ty kind arg_kind | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ] - ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind } + ; finish_tuple rn_ty mode tup_sort tys' (map (const arg_kind) tys') exp_kind } tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind @@ -747,7 +778,7 @@ tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind ; tau_tys <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds ; let arg_reps = map kindRep arg_kinds arg_tys = arg_reps ++ tau_tys - ; checkExpectedKind rn_ty + ; checkExpectedKindMode mode (ppr rn_ty) (mkTyConApp (sumTyCon arity) arg_tys) (unboxedSumKind arg_reps) exp_kind @@ -758,7 +789,7 @@ tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind = do { tks <- mapM (tc_infer_lhs_type mode) tys ; (taus', kind) <- unifyKinds tys tks ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus') - ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind } + ; checkExpectedKindMode mode (ppr rn_ty) ty (mkListTy kind) exp_kind } where mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b] mk_nil k = mkTyConApp (promoteDataCon nilDataCon) [k] @@ -771,7 +802,7 @@ tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind ; let kind_con = tupleTyCon Boxed arity ty_con = promotedTupleDataCon Boxed arity tup_k = mkTyConApp kind_con ks - ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } + ; checkExpectedKindMode mode (ppr rn_ty) (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind } where arity = length tys @@ -781,51 +812,83 @@ tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind ; ty' <- tc_lhs_type mode ty liftedTypeKind ; let n' = mkStrLitTy $ hsIPNameFS n ; ipClass <- tcLookupClass ipClassName - ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty']) + ; checkExpectedKindMode mode (ppr rn_ty) (mkClassPred ipClass [n',ty']) constraintKind exp_kind } -tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind +tc_hs_type mode rn_ty@(HsStarTy _ _) exp_kind -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to -- handle it in 'coreView' and 'tcView'. - = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind + = checkExpectedKindMode mode (ppr rn_ty) liftedTypeKind liftedTypeKind exp_kind --------- Literals -tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind +tc_hs_type mode rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind = do { checkWiredInTyCon typeNatKindCon - ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind } + ; checkExpectedKindMode mode (ppr rn_ty) (mkNumLitTy n) typeNatKind exp_kind } -tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind +tc_hs_type mode rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind = do { checkWiredInTyCon typeSymbolKindCon - ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } + ; checkExpectedKindMode mode (ppr rn_ty) (mkStrLitTy s) typeSymbolKind exp_kind } --------- Potentially kind-polymorphic types: call the "up" checker -- See Note [Future-proofing the type checker] tc_hs_type mode ty@(HsTyVar {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(HsAppTy {}) ek = tc_infer_hs_type_ek mode ty ek +tc_hs_type mode ty@(HsAppKindTy{}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(HsOpTy {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(HsKindSig {}) ek = tc_infer_hs_type_ek mode ty ek tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek -tc_hs_type _ (HsWildCardTy wc) exp_kind - = do { wc_ty <- tcWildCardOcc wc exp_kind +tc_hs_type mode wc@(HsWildCardTy _) exp_kind + = do { wc_ty <- tcWildCardOcc mode wc exp_kind ; return (mkNakedCastTy wc_ty (mkTcNomReflCo exp_kind)) -- Take care here! Even though the coercion is Refl, -- we still need it to establish Note [The tcType invariant] } -tcWildCardOcc :: HsWildCardInfo -> Kind -> TcM TcType -tcWildCardOcc wc_info exp_kind - = do { wc_tv <- tcLookupTyVar (wildCardName wc_info) +tcWildCardOcc :: TcTyMode -> HsType GhcRn -> Kind -> TcM TcType +tcWildCardOcc mode wc exp_kind + = do { wc_tv <- newWildTyVar -- The wildcard's kind should be an un-filled-in meta tyvar - ; checkExpectedKind (HsWildCardTy wc_info) (mkTyVarTy wc_tv) + ; loc <- getSrcSpanM + ; uniq <- newUnique + ; let name = mkInternalName uniq (mkTyVarOcc "_") loc + ; part_tysig <- xoptM LangExt.PartialTypeSignatures + ; warning <- woptM Opt_WarnPartialTypeSignatures + -- See Note [Wildcards in visible kind application] + ; unless (part_tysig && not warning) + (emitWildCardHoleConstraints [(name,wc_tv)]) + ; checkExpectedKindMode mode (ppr wc) (mkTyVarTy wc_tv) (tyVarKind wc_tv) exp_kind } +{- Note [Wildcards in visible kind application] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There are cases where users might want to pass in a wildcard as a visible kind +argument, for instance: + +data T :: forall k1 k2. k1 → k2 → Type where + MkT :: T a b +x :: T @_ @Nat False n +x = MkT + +So we should allow '@_' without emitting any hole constraints, and +regardless of whether PartialTypeSignatures is enabled or not. But how would +the typechecker know which '_' is being used in VKA and which is not when it +calls emitWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs? +The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs, +but instead give every unnamed wildcard a fresh wild tyvar in tcWildCardOcc. +And whenever we see a '@', we automatically turn on PartialTypeSignatures and +turn off hole constraint warnings, and never call emitWildCardHoleConstraints +under these conditions. +See related Note [Wildcards in visible type application] here and +Note [The wildcard story for types] in HsTypes.hs + +-} --------------------------- -- | Call 'tc_infer_hs_type' and check its result against an expected kind. tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType tc_infer_hs_type_ek mode hs_ty ek = do { (ty, k) <- tc_infer_hs_type mode hs_ty - ; checkExpectedKind hs_ty ty k ek } + ; checkExpectedKindMode mode (ppr hs_ty) ty k ek } --------------------------- tupKindSort_maybe :: TcKind -> Maybe TupleSort @@ -843,17 +906,18 @@ tc_tuple rn_ty mode tup_sort tys exp_kind UnboxedTuple -> mapM (\_ -> newOpenTypeKind) tys ConstraintTuple -> return (nOfThem arity constraintKind) ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds - ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind } + ; finish_tuple rn_ty mode tup_sort tau_tys arg_kinds exp_kind } where arity = length tys finish_tuple :: HsType GhcRn + -> TcTyMode -> TupleSort -> [TcType] -- ^ argument types -> [TcKind] -- ^ of these kinds -> TcKind -- ^ expected kind of the whole tuple -> TcM TcType -finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind +finish_tuple rn_ty mode tup_sort tau_tys tau_kinds exp_kind = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind) ; let arg_tys = case tup_sort of -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon @@ -869,7 +933,7 @@ finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind ; checkWiredInTyCon tc ; return tc } UnboxedTuple -> return (tupleTyCon Unboxed arity) - ; checkExpectedKind rn_ty (mkTyConApp tycon arg_tys) res_kind exp_kind } + ; checkExpectedKindMode mode (ppr rn_ty) (mkTyConApp tycon arg_tys) res_kind exp_kind } where arity = length tau_tys tau_reps = map kindRep tau_kinds @@ -895,7 +959,7 @@ tcInferApps :: TcTyMode -> LHsType GhcRn -- ^ Function (for printing only) -> TcType -- ^ Function -> TcKind -- ^ Function kind (zonked) - -> [LHsType GhcRn] -- ^ Args + -> [LHsTypeArg GhcRn] -- ^ Args -> TcM (TcType, TcKind) -- ^ (f args, args, result kind) -- Precondition: tcTypeKind fun_ty = fun_ki -- Reason: we will return a type application like (fun_ty arg1 ... argn), @@ -918,7 +982,7 @@ tcInferApps mode orig_hs_ty fun_ty fun_ki orig_hs_args -> TcType -- function applied to some args -> [TyBinder] -- binders in function kind (both vis. and invis.) -> TcKind -- function kind body (not a Pi-type) - -> [LHsType GhcRn] -- un-type-checked args + -> [LHsTypeArg GhcRn] -- un-type-checked args -> TcM (TcType, TcKind) -- same as overall return type -- no user-written args left. We're done! @@ -926,53 +990,100 @@ tcInferApps mode orig_hs_ty fun_ty fun_ki orig_hs_args = return ( fun , nakedSubstTy subst $ mkPiTys ki_binders inner_ki) -- nakedSubstTy: see Note [The well-kinded type invariant] - + go n subst fun all_kindbinder inner_ki (HsArgPar _:args) + = go n subst fun all_kindbinder inner_ki args -- The function's kind has a binder. Is it visible or invisible? - go n subst fun (ki_binder:ki_binders) inner_ki + go n subst fun all_kindbinder@(ki_binder:ki_binders) inner_ki all_args@(arg:args) + | Specified <- tyCoBinderArgFlag ki_binder + , HsTypeArg ki <- arg + -- Invisible and specified binder with visible kind argument + = do { traceTc "tcInferApps (vis kind app)" (vcat [ ppr ki_binder, ppr ki + , ppr (tyBinderType ki_binder) + , ppr subst, ppr (tyCoBinderArgFlag ki_binder) ]) + ; let exp_kind = nakedSubstTy subst $ tyBinderType ki_binder + -- nakedSubstTy: see Note [The well-kinded type invariant] + ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty ki n) $ + unsetWOptM Opt_WarnPartialTypeSignatures $ + setXOptM LangExt.PartialTypeSignatures $ + -- see Note [Wildcards in visible kind application] + tc_lhs_type (kindLevel mode) ki exp_kind + ; traceTc "tcInferApps (vis kind app)" (ppr exp_kind) + ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg' + ; go (n+1) subst' + (mkNakedAppTy fun arg') + ki_binders inner_ki args } + | isInvisibleBinder ki_binder - -- It's invisible. Instantiate. - = do { traceTc "tcInferApps (invis)" (ppr ki_binder $$ ppr subst) + -- Instantiate if not specified or if there is no kind application + = do { traceTc "tcInferApps (invis normal app)" (ppr ki_binder $$ ppr subst $$ ppr (tyCoBinderArgFlag ki_binder)) ; (subst', arg') <- tcInstTyBinder Nothing subst ki_binder ; go n subst' (mkNakedAppTy fun arg') - ki_binders inner_ki all_args } - - | otherwise - -- It's visible. Check the next user-written argument - = do { traceTc "tcInferApps (vis)" (vcat [ ppr ki_binder, ppr arg - , ppr (tyBinderType ki_binder) - , ppr subst ]) - ; let exp_kind = nakedSubstTy subst $ tyBinderType ki_binder - -- nakedSubstTy: see Note [The well-kinded type invariant] - ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $ - tc_lhs_type mode arg exp_kind - ; traceTc "tcInferApps (vis 1)" (ppr exp_kind) - ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg' - ; go (n+1) subst' - (mkNakedAppTy fun arg') -- See Note [The well-kinded type invariant] - ki_binders inner_ki args } + ki_binders inner_ki all_args } + + | otherwise -- if binder is visible + = case arg of + HsValArg ty -- check the next argument + -> do { traceTc "tcInferApps (vis normal app)" + (vcat [ ppr ki_binder + , ppr ty + , ppr (tyBinderType ki_binder) + , ppr subst ]) + ; let exp_kind = nakedSubstTy subst $ tyBinderType ki_binder + -- nakedSubstTy: see Note [The well-kinded type invariant] + ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty ty n) $ + tc_lhs_type mode ty exp_kind + ; traceTc "tcInferApps (vis normal app)" (ppr exp_kind) + ; let subst' = extendTvSubstBinderAndInScope subst ki_binder arg' + ; go (n+1) subst' + (mkNakedAppTy fun arg') + ki_binders inner_ki args } + -- error if the argument is a kind application + HsTypeArg ki -> do { traceTc "tcInferApps (error)" + (vcat [ ppr ki_binder + , ppr ki + , ppr (tyBinderType ki_binder) + , ppr subst + , ppr (isInvisibleBinder ki_binder) ]) + ; ty_app_err ki $ nakedSubstTy subst $ + mkPiTys all_kindbinder inner_ki } + + HsArgPar _ -> panic "tcInferApps" -- handled in separate clause of "go" -- We've run out of known binders in the functions's kind. - go n subst fun [] inner_ki all_args + go n subst fun [] inner_ki all_args@(arg:args) | not (null new_ki_binders) -- But, after substituting, we have more binders. = go n zapped_subst fun new_ki_binders new_inner_ki all_args | otherwise + = case arg of + (HsValArg _) -- Even after substituting, still no binders. Use matchExpectedFunKind - = do { traceTc "tcInferApps (no binder)" (ppr new_inner_ki $$ ppr zapped_subst) - ; (co, arg_k, res_k) <- matchExpectedFunKind hs_ty substed_inner_ki - ; let new_in_scope = tyCoVarsOfTypes [arg_k, res_k] - subst' = zapped_subst `extendTCvInScopeSet` new_in_scope - ; go n subst' - (fun `mkNakedCastTy` co) -- See Note [The well-kinded type invariant] - [mkAnonBinder arg_k] - res_k all_args } + -> do { traceTc "tcInferApps (no binder)" (ppr new_inner_ki $$ ppr zapped_subst) + ; (co, arg_k, res_k) <- matchExpectedFunKind hs_ty substed_inner_ki + ; let new_in_scope = tyCoVarsOfTypes [arg_k, res_k] + subst' = zapped_subst `extendTCvInScopeSet` new_in_scope + ; go n subst' + (fun `mkNakedCastTy` co) -- See Note [The well-kinded type invariant] + [mkAnonBinder arg_k] + res_k all_args } + (HsTypeArg ki) -> ty_app_err ki substed_inner_ki + (HsArgPar _) -> go n subst fun [] inner_ki args where substed_inner_ki = substTy subst inner_ki (new_ki_binders, new_inner_ki) = tcSplitPiTys substed_inner_ki zapped_subst = zapTCvSubst subst - hs_ty = mkHsAppTys orig_hs_ty (take (n-1) orig_hs_args) + hs_ty = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args) + + ty_app_err arg ty = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty) + $$ text "to visible kind argument" <+> quotes (ppr arg) + +appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn +appTypeToArg f [] = f +appTypeToArg f (HsValArg arg : args) = appTypeToArg (mkHsAppTy f arg) args +appTypeToArg f (HsTypeArg arg : args) = appTypeToArg (mkHsAppKindTy f arg) args +appTypeToArg f (HsArgPar _ : arg) = appTypeToArg f arg -- | Applies a type to a list of arguments. -- Always consumes all the arguments, using 'matchExpectedFunKind' as @@ -983,7 +1094,7 @@ tcTyApps :: TcTyMode -> LHsType GhcRn -- ^ Function (for printing only) -> TcType -- ^ Function -> TcKind -- ^ Function kind (zonked) - -> [LHsType GhcRn] -- ^ Args + -> [LHsTypeArg GhcRn] -- ^ Args -> TcM (TcType, TcKind) -- ^ (f args, result kind) result kind is zonked -- Precondition: see precondition for tcInferApps tcTyApps mode orig_hs_ty fun_ty fun_ki args @@ -991,59 +1102,93 @@ tcTyApps mode orig_hs_ty fun_ty fun_ki args ; return (ty' `mkNakedCastTy` mkNomReflCo ki', ki') } -- The mkNakedCastTy is for (IT3) of Note [The tcType invariant] +tcTyApp :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind) -- only HsAppTy or HsAppKindTy +tcTyApp mode e + = do { let (hs_fun_ty, hs_args) = splitHsAppTys e + ; (fun_ty, fun_kind) <- tc_infer_lhs_type mode hs_fun_ty + -- NB: (IT4) of Note [The tcType invariant] ensures that fun_kind is zonked + ; tcTyApps mode hs_fun_ty fun_ty fun_kind hs_args } -------------------------- --- Like checkExpectedKindX, but returns only the final type; convenient wrapper +-- Internally-callable version of checkExpectedKind +checkExpectedKindMode :: HasDebugCallStack + => TcTyMode + -> SDoc -- type we're checking + -> TcType -- type we're checking + -> TcKind -- kind of that type + -> TcKind -- expected kind + -> TcM TcType +checkExpectedKindMode mode = checkExpectedKind (mode_sat mode) + +-- | This instantiates invisible arguments for the type being checked if it must +-- be saturated and is not yet saturated. It then calls and uses the result +-- from checkExpectedKindX to build the final type -- Obeys Note [The tcType invariant] checkExpectedKind :: HasDebugCallStack - => HsType GhcRn -- type we're checking (for printing) - -> TcType -- type we're checking - -> TcKind -- the known kind of that type - -> TcKind -- the expected kind + => RequireSaturation -- ^ Do we require all type families to be saturated? + -> SDoc -- ^ type we're checking (for printing) + -> TcType -- ^ type we're checking + -> TcKind -- ^ the known kind of that type + -> TcKind -- ^ the expected kind -> TcM TcType -checkExpectedKind hs_ty ty act exp = checkExpectedKindX (ppr hs_ty) ty act exp +checkExpectedKind sat hs_ty ty act exp + = do { (new_ty, new_act) <- case splitTyConApp_maybe ty of + Just (tc, args) + -- if the family tycon must be saturated and is not yet satured + -- If we don't do this, we get #11246 + | YesSaturation <- sat + , not (mightBeUnsaturatedTyCon tc) && length args < tyConArity tc + -> do { + -- we need to instantiate all invisible arguments up until saturation + (tc_args, kind) <- tcInstTyBinders (splitPiTysInvisibleN + (tyConArity tc - length args) + act) + ; let tc_ty = mkTyConApp tc $ args ++ tc_args + ; traceTc "checkExpectedKind:satTyFam" (vcat [ ppr tc <+> dcolon <+> ppr act + , ppr kind ]) + ; return (tc_ty, kind) } + _ -> return (ty, act) + ; (new_args, co_k) <- checkExpectedKindX hs_ty new_act exp + ; return (new_ty `mkNakedAppTys` new_args `mkNakedCastTy` co_k) } checkExpectedKindX :: HasDebugCallStack => SDoc -- HsType whose kind we're checking - -> TcType -- the type whose kind we're checking -> TcKind -- the known kind of that type, k -> TcKind -- the expected kind, exp_kind - -> TcM TcType + -> TcM ([TcType], TcCoercionN) -- (the new args, the coercion) -- Instantiate a kind (if necessary) and then call unifyType -- (checkExpectedKind ty act_kind exp_kind) -- checks that the actual kind act_kind is compatible -- with the expected kind exp_kind -checkExpectedKindX pp_hs_ty ty act_kind exp_kind - = do { -- We need to make sure that both kinds have the same number of implicit - -- foralls out front. If the actual kind has more, instantiate accordingly. - -- Otherwise, just pass the type & kind through: the errors are caught - -- in unifyType. - let n_exp_invis_bndrs = invisibleTyBndrCount exp_kind - n_act_invis_bndrs = invisibleTyBndrCount act_kind - n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs - ; (new_args, act_kind') <- tcInstTyBinders (splitPiTysInvisibleN n_to_inst act_kind) - - ; let origin = TypeEqOrigin { uo_actual = act_kind' - , uo_expected = exp_kind - , uo_thing = Just pp_hs_ty - , uo_visible = True } -- the hs_ty is visible - ty' = mkNakedAppTys ty new_args - - ; traceTc "checkExpectedKind" $ - vcat [ pp_hs_ty - , text "act_kind:" <+> ppr act_kind - , text "act_kind':" <+> ppr act_kind' - , text "exp_kind:" <+> ppr exp_kind ] - - ; if act_kind' `tcEqType` exp_kind - then return ty' -- This is very common - else do { co_k <- uType KindLevel origin act_kind' exp_kind - ; traceTc "checkExpectedKind" (vcat [ ppr act_kind - , ppr exp_kind - , ppr co_k ]) - ; let result_ty = ty' `mkNakedCastTy` co_k +checkExpectedKindX pp_hs_ty act_kind exp_kind + = do { -- We need to make sure that both kinds have the same number of implicit + -- foralls out front. If the actual kind has more, instantiate accordingly. + -- Otherwise, just pass the type & kind through: the errors are caught + -- in unifyType. + let n_exp_invis_bndrs = invisibleTyBndrCount exp_kind + n_act_invis_bndrs = invisibleTyBndrCount act_kind + n_to_inst = n_act_invis_bndrs - n_exp_invis_bndrs + ; (new_args, act_kind') <- tcInstTyBinders (splitPiTysInvisibleN n_to_inst act_kind) + + ; let origin = TypeEqOrigin { uo_actual = act_kind' + , uo_expected = exp_kind + , uo_thing = Just pp_hs_ty + , uo_visible = True } -- the hs_ty is visible + + ; traceTc "checkExpectedKindX" $ + vcat [ pp_hs_ty + , text "act_kind:" <+> ppr act_kind + , text "act_kind':" <+> ppr act_kind' + , text "exp_kind:" <+> ppr exp_kind ] + + ; if act_kind' `tcEqType` exp_kind + then return (new_args, mkTcNomReflCo exp_kind) -- This is very common + else do { co_k <- uType KindLevel origin act_kind' exp_kind + ; traceTc "checkExpectedKind" (vcat [ ppr act_kind + , ppr exp_kind + , ppr co_k ]) -- See Note [The tcType invariant] - ; return result_ty } } + ; return (new_args, co_k) } } --------------------------- tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType] @@ -1081,16 +1226,19 @@ tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon do { ty <- zonkTcTyVar tv ; return (ty, tcTypeKind ty) } - ATcTyCon tc_tc -> do { -- See Note [GADT kind self-reference] - unless - (isTypeLevel (mode_level mode)) - (promotionErr name TyConPE) - ; check_tc tc_tc - ; handle_tyfams tc_tc } + ATcTyCon tc_tc + -> do { -- See Note [GADT kind self-reference] + unless (isTypeLevel (mode_level mode)) + (promotionErr name TyConPE) + ; check_tc tc_tc + ; tc_kind <- zonkTcType (tyConKind tc_tc) + -- (IT6) of Note [The tcType invariant] + ; return (mkTyConTy tc_tc `mkNakedCastTy` mkNomReflCo tc_kind, tc_kind) } + -- the mkNakedCastTy ensures (IT5) of Note [The tcType invariant] AGlobal (ATyCon tc) -> do { check_tc tc - ; handle_tyfams tc } + ; return (mkTyConTy tc, tyConKind tc) } AGlobal (AConLike (RealDataCon dc)) -> do { data_kinds <- xoptM LangExt.DataKinds @@ -1118,39 +1266,6 @@ tcTyVar mode name -- Could be a tyvar, a tycon, or a datacon isKindTyCon tc) $ promotionErr name NoDataKindsTC } - -- if we are type-checking a type family tycon, we must instantiate - -- any invisible arguments right away. Otherwise, we get #11246 - handle_tyfams :: TyCon -- the tycon to instantiate - -> TcM (TcType, TcKind) - handle_tyfams tc - | mightBeUnsaturatedTyCon tc || mode_unsat mode - -- This is where mode_unsat is used - = do { tc_kind <- zonkTcType (tyConKind tc) -- (IT6) of Note [The tcType invariant] - ; traceTc "tcTyVar2a" (ppr tc $$ ppr tc_kind) - ; return (mkTyConApp tc [] `mkNakedCastTy` mkNomReflCo tc_kind, tc_kind) } - -- the mkNakedCastTy ensures (IT5) of Note [The tcType invariant] - - | otherwise - = do { let tc_arity = tyConArity tc - ; tc_kind <- zonkTcType (tyConKind tc) - ; (tc_args, kind) <- tcInstTyBinders (splitPiTysInvisibleN tc_arity tc_kind) - -- Instantiate enough invisible arguments - -- to saturate the family TyCon - - ; let is_saturated = tc_args `lengthAtLeast` tc_arity - tc_ty - | is_saturated = mkTyConApp tc tc_args `mkNakedCastTy` mkNomReflCo kind - -- mkNakedCastTy is for (IT5) of Note [The tcType invariant] - | otherwise = mkTyConApp tc tc_args - -- if the tycon isn't yet saturated, then we don't want mkNakedCastTy, - -- because that means we'll have an unsaturated type family - -- We don't need it anyway, because we can be sure that the - -- type family kind will accept further arguments (because it is - -- not yet saturated) - ; traceTc "tcTyVar2b" (vcat [ ppr tc <+> dcolon <+> ppr tc_kind - , ppr kind ]) - ; return (tc_ty, kind) } - -- We cannot promote a data constructor with a context that contains -- constraints other than equalities, so error if we find one. -- See Note [Constraints handled in types] in Inst. @@ -1306,6 +1421,7 @@ Help functions for type applications addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a -- Wrap a context around only if we want to show that contexts. -- Omit invisible ones and ones user's won't grok +addTypeCtxt (L _ (HsWildCardTy _)) thing = thing -- "In the type '_'" just isn't helpful. addTypeCtxt (L _ ty) thing = addErrCtxt doc thing where @@ -1458,18 +1574,18 @@ tcWildCardBinders :: [Name] -> ([(Name, TcTyVar)] -> TcM a) -> TcM a tcWildCardBinders wc_names thing_inside - = do { wcs <- mapM newWildTyVar wc_names + = do { wcs <- mapM (const newWildTyVar) wc_names ; let wc_prs = wc_names `zip` wcs ; tcExtendNameTyVarEnv wc_prs $ thing_inside wc_prs } -newWildTyVar :: Name -> TcM TcTyVar +newWildTyVar :: TcM TcTyVar -- ^ New unification variable for a wildcard -newWildTyVar _name +newWildTyVar = do { kind <- newMetaKindVar ; uniq <- newUnique ; details <- newMetaDetails TauTv - ; let name = mkSysTvName uniq (fsLit "w") + ; let name = mkSysTvName uniq (fsLit "_") tyvar = (mkTcTyVar name kind details) ; traceTc "newWildTyVar" (ppr tyvar) ; return tyvar } @@ -2249,8 +2365,8 @@ tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType" tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType) tcPartialContext hs_theta | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta - , L _ (HsWildCardTy wc) <- ignoreParens hs_ctxt_last - = do { wc_tv_ty <- tcWildCardOcc wc constraintKind + , L _ wc@(HsWildCardTy _) <- ignoreParens hs_ctxt_last + = do { wc_tv_ty <- tcWildCardOcc typeLevelMode wc constraintKind ; theta <- mapM tcLHsPredType hs_theta1 ; return (theta, Just wc_tv_ty) } | otherwise @@ -2263,8 +2379,7 @@ Consider f :: (_) => a -> a f x = ... -* The renamer makes a wildcard name for the "_", and puts it in - the hswc_wcs field. +* The renamer leaves '_' untouched. * Then, in tcHsPartialSigType, we make a new hole TcTyVar, in tcWildCardBinders. @@ -2480,7 +2595,7 @@ together. Hence the new_tv function in tcHsPatSigType. unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind) unifyKinds rn_tys act_kinds = do { kind <- newMetaKindVar - ; let check rn_ty (ty, act_kind) = checkExpectedKind (unLoc rn_ty) ty act_kind kind + ; let check rn_ty (ty, act_kind) = checkExpectedKind YesSaturation (ppr $ unLoc rn_ty) ty act_kind kind ; tys' <- zipWithM check rn_tys act_kinds ; return (tys', kind) } diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index c6628a5383..ba33fe205c 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -799,7 +799,7 @@ tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksi ; addConsistencyConstraints mb_clsinfo lhs_ty ; mapM_ (wrapLocM_ kcConDecl) hs_cons ; res_kind <- tc_kind_sig m_ksig - ; lhs_ty <- checkExpectedKindX pp_lhs lhs_ty lhs_kind res_kind + ; lhs_ty <- checkExpectedKind YesSaturation pp_lhs lhs_ty lhs_kind res_kind ; return (stupid_theta, lhs_ty, res_kind) } -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts] diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index 5925fc8975..65c2c60335 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -249,9 +249,53 @@ completeSigFromId ctxt id isCompleteHsSig :: LHsSigWcType GhcRn -> Bool -- ^ If there are no wildcards, return a LHsSigType -isCompleteHsSig (HsWC { hswc_ext = wcs }) = null wcs +isCompleteHsSig (HsWC { hswc_ext = wcs + , hswc_body = HsIB { hsib_body = hs_ty } }) + = null wcs && no_anon_wc hs_ty +isCompleteHsSig (HsWC _ (XHsImplicitBndrs _)) = panic "isCompleteHsSig" isCompleteHsSig (XHsWildCardBndrs _) = panic "isCompleteHsSig" +no_anon_wc :: LHsType GhcRn -> Bool +no_anon_wc lty = go lty + where + go (L _ ty) = case ty of + HsWildCardTy _ -> False + HsAppTy _ ty1 ty2 -> go ty1 && go ty2 + HsAppKindTy _ ty ki -> go ty && go ki + HsFunTy _ ty1 ty2 -> go ty1 && go ty2 + HsListTy _ ty -> go ty + HsTupleTy _ _ tys -> gos tys + HsSumTy _ tys -> gos tys + HsOpTy _ ty1 _ ty2 -> go ty1 && go ty2 + HsParTy _ ty -> go ty + HsIParamTy _ _ ty -> go ty + HsKindSig _ ty kind -> go ty && go kind + HsDocTy _ ty _ -> go ty + HsBangTy _ _ ty -> go ty + HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds + HsExplicitListTy _ _ tys -> gos tys + HsExplicitTupleTy _ tys -> gos tys + HsForAllTy { hst_bndrs = bndrs + , hst_body = ty } -> no_anon_wc_bndrs bndrs + && go ty + HsQualTy { hst_ctxt = L _ ctxt + , hst_body = ty } -> gos ctxt && go ty + HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty + HsSpliceTy{} -> True + HsTyLit{} -> True + HsTyVar{} -> True + HsStarTy{} -> True + XHsType{} -> True -- Core type, which does not have any wildcard + + gos = all go + +no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool +no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs + where + go (UserTyVar _ _) = True + go (KindedTyVar _ _ ki) = no_anon_wc ki + go (XTyVarBndr{}) = panic "no_anon_wc_bndrs" + {- Note [Fail eagerly on bad signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If a type signature is wrong, fail immediately: diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs index 4e8fe3b6e4..bda9b77a9b 100644 --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -677,8 +677,15 @@ simplifyInfer :: TcLevel -- Used when generating the constraints simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds | isEmptyWC wanteds - = do { gbl_tvs <- tcGetGlobalTyCoVars - ; dep_vars <- candidateQTyVarsOfTypes (map snd name_taus) + = do { -- When quantifying, we want to preserve any order of variables as they + -- appear in partial signatures. cf. decideQuantifiedTyVars + let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs + , (_,tv) <- sig_inst_skols sig ] + psig_theta = [ pred | sig <- partial_sigs + , pred <- sig_inst_theta sig ] + + ; gbl_tvs <- tcGetGlobalTyCoVars + ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus) ; qtkvs <- quantifyTyVars gbl_tvs dep_vars ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs) ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) } @@ -692,8 +699,7 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds , text "(unzonked) wanted =" <+> ppr wanteds ] - ; let partial_sigs = filter isPartialSig sigs - psig_theta = concatMap sig_inst_theta partial_sigs + ; let psig_theta = concatMap sig_inst_theta partial_sigs -- First do full-blown solving -- NB: we must gather up all the bindings from doing @@ -768,7 +774,8 @@ simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var , residual_wanted, definite_error ) } -- NB: bound_theta_vars must be fully zonked - + where + partial_sigs = filter isPartialSig sigs -------------------- mkResidualConstraints :: TcLevel -> Env TcGblEnv TcLclEnv -> EvBindsVar diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 7e34dae005..53df2bb03d 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1402,8 +1402,9 @@ reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs ; lhs' <- reifyTypes lhs_types_only ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs) lhs_types_only lhs' + ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs ; rhs' <- reifyType rhs - ; return (TH.TySynEqn tvs' annot_th_lhs rhs') } + ; return (TH.TySynEqn tvs' lhs_type rhs') } where fam_tvs = tyConVisibleTyVars fam_tc @@ -1617,7 +1618,8 @@ reifyClass cls reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec reifyDefImpl n args ty = - TH.TySynInstD n . TH.TySynEqn Nothing (map TH.VarT args) <$> reifyType ty + TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args)) + <$> reifyType ty tfNames :: TH.Dec -> (TH.Name, [TH.Name]) tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _)) @@ -1708,9 +1710,9 @@ reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor ; th_lhs <- reifyTypes lhs_types_only ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only th_lhs + ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs ; th_rhs <- reifyType rhs - ; return (TH.TySynInstD (reifyName fam) - (TH.TySynEqn th_tvs annot_th_lhs th_rhs)) } + ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) } DataFamilyInst rep_tc -> do { let -- eta-expand lhs types, because sometimes data/newtype @@ -1725,10 +1727,11 @@ reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs ; th_tys <- reifyTypes types_only ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys + ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys ; return $ if isNewTyCon rep_tc - then TH.NewtypeInstD [] fam' th_tvs annot_th_tys Nothing (head cons) [] - else TH.DataInstD [] fam' th_tvs annot_th_tys Nothing cons [] + then TH.NewtypeInstD [] th_tvs lhs_type Nothing (head cons) [] + else TH.DataInstD [] th_tvs lhs_type Nothing cons [] } ------------------------------ diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index f4ca9932a1..a3b7975b8e 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -1428,7 +1428,7 @@ tcDefaultAssocDecl fam_tc [dL->L loc (FamEqn { feqn_tycon = L _ tc_name (wrongNumberOfParmsErr fam_arity) -- Typecheck RHS - ; let hs_pats = map hsLTyVarBndrToType exp_vars + ; let hs_pats = map (HsValArg . hsLTyVarBndrToType) exp_vars -- NB: Use tcFamTyPats, not bindTyClTyVars. The latter expects to get -- the LHsQTyVars used for declaring a tycon, but the names here @@ -1734,7 +1734,8 @@ kcTyFamInstEqn tc_fam_tc , text "feqn_bndrs =" <+> ppr mb_expl_bndrs , text "feqn_pats =" <+> ppr hs_pats ]) -- this check reports an arity error instead of a kind error; easier for user - ; checkTc (hs_pats `lengthIs` vis_arity) $ + ; let vis_pats = numVisibleArgs hs_pats + ; checkTc (vis_pats == vis_arity) $ wrongNumberOfParmsErr vis_arity ; discardResult $ bindImplicitTKBndrs_Q_Tv imp_vars $ @@ -1774,7 +1775,8 @@ tcTyFamInstEqn fam_tc mb_clsinfo -- If we wait until validity checking, we'll get kind errors -- below when an arity error will be much easier to understand. ; let vis_arity = length (tyConVisibleTyVars fam_tc) - ; checkTc (hs_pats `lengthIs` vis_arity) $ + vis_pats = numVisibleArgs hs_pats + ; checkTc (vis_pats == vis_arity) $ wrongNumberOfParmsErr vis_arity ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo @@ -1944,7 +1946,11 @@ tcFamTyPats fam_tc hs_pats ; let fun_ty = mkTyConApp fam_tc [] - ; (fam_app, res_kind) <- tcInferApps typeLevelMode lhs_fun fun_ty + ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $ + setXOptM LangExt.PartialTypeSignatures $ + -- See Note [Wildcards in family instances] in + -- RnSource.hs + tcInferApps typeLevelMode lhs_fun fun_ty fam_kind hs_pats ; traceTc "End tcFamTyPats }" $ diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index c7592c5ffd..fb05ec0094 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -58,6 +58,7 @@ module TyCoRep ( isInvisibleArgFlag, isVisibleArgFlag, isInvisibleBinder, isVisibleBinder, isTyBinder, isNamedBinder, + tyCoBinderArgFlag, -- * Functions over coercions pickLR, @@ -554,6 +555,12 @@ isTyBinder :: TyCoBinder -> Bool isTyBinder (Named bnd) = isTyVarBinder bnd isTyBinder _ = True +tyCoBinderArgFlag :: TyCoBinder -> ArgFlag +tyCoBinderArgFlag (Named (Bndr _ flag)) = flag +tyCoBinderArgFlag (Anon ty) + | isPredTy ty = Inferred + | otherwise = Required + {- Note [TyCoBinders] ~~~~~~~~~~~~~~~~~~~ A ForAllTy contains a TyCoVarBinder. But a type can be decomposed diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 0ef0d053af..b1e9bc6722 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -10686,7 +10686,7 @@ Visible type application ======================== .. extension:: TypeApplications - :shortdesc: Enable type application syntax. + :shortdesc: Enable type application syntax in terms and types. :since: 8.0.1 @@ -10707,6 +10707,10 @@ is an identifier (the common case), its type is considered known only when the identifier has been given a type signature. If the identifier does not have a type signature, visible type application cannot be used. +GHC also permits visible kind application, where users can declare the kind +arguments to be instantiated in kind-polymorphic cases. Its usage parallels +visible type application in the term level, as specified above. + .. _inferred-vs-specified: Inferred vs. specified type variables @@ -10864,8 +10868,8 @@ the rules in the subtler cases: application. If you want to specify only the second type argument to ``wurble``, then you can say ``wurble @_ @Int``. The first argument is a wildcard, just like in a partial type signature. - However, if used in a visible type application, it is *not* - necessary to specify :extension:`PartialTypeSignatures` and your + However, if used in a visible type application/visible kind application, + it is *not* necessary to specify :extension:`PartialTypeSignatures` and your code will not generate a warning informing you of the omitted type. The section in this manual on kind polymorphism describes how variables @@ -12251,10 +12255,10 @@ Anonymous and named wildcards *can* occur on the left hand side of a type or data instance declaration; see :ref:`type-wildcards-lhs`. -Anonymous wildcards are also allowed in visible type applications -(:ref:`visible-type-application`). If you want to specify only the second type -argument to ``wurble``, then you can say ``wurble @_ @Int`` where the first -argument is a wildcard. +Anonymous wildcards are also allowed in visible type applications/ visible kind +applications (:ref:`visible-type-application`). If you want to specify only the +second type argument to ``wurble``, then you can say ``wurble @_ @Int`` where +the first argument is a wildcard. Standalone ``deriving`` declarations permit the use of a single, extra-constraints wildcard, like so: :: diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 67a8773ecc..60527b6c82 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -52,9 +52,10 @@ module Language.Haskell.TH.Lib ( bindS, letS, noBindS, parS, recS, -- *** Types - forallT, varT, conT, appT, arrowT, infixT, uInfixT, parensT, equalityT, - listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT, wildCardT, - promotedT, promotedTupleT, promotedNilT, promotedConsT, implicitParamT, + forallT, varT, conT, appT, appKindT, arrowT, infixT, uInfixT, parensT, + equalityT, listT, tupleT, unboxedTupleT, unboxedSumT, sigT, litT, + wildCardT, promotedT, promotedTupleT, promotedNilT, promotedConsT, + implicitParamT, -- **** Type literals numTyLit, strTyLit, -- **** Strictness @@ -207,20 +208,20 @@ dataInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> [ConQ] -> [DerivClauseQ] dataInstD ctxt tc tys ksig cons derivs = do ctxt1 <- ctxt - tys1 <- sequence tys + ty1 <- foldl appT (conT tc) tys cons1 <- sequence cons derivs1 <- sequence derivs - return (DataInstD ctxt1 tc Nothing tys1 ksig cons1 derivs1) + return (DataInstD ctxt1 Nothing ty1 ksig cons1 derivs1) newtypeInstD :: CxtQ -> Name -> [TypeQ] -> Maybe Kind -> ConQ -> [DerivClauseQ] -> DecQ newtypeInstD ctxt tc tys ksig con derivs = do ctxt1 <- ctxt - tys1 <- sequence tys + ty1 <- foldl appT (conT tc) tys con1 <- con derivs1 <- sequence derivs - return (NewtypeInstD ctxt1 tc Nothing tys1 ksig con1 derivs1) + return (NewtypeInstD ctxt1 Nothing ty1 ksig con1 derivs1) dataFamilyD :: Name -> [TyVarBndr] -> Maybe Kind -> DecQ dataFamilyD tc tvs kind @@ -237,12 +238,12 @@ closedTypeFamilyD tc tvs result injectivity eqns = do eqns1 <- sequence eqns return (ClosedTypeFamilyD (TypeFamilyHead tc tvs result injectivity) eqns1) -tySynEqn :: [TypeQ] -> TypeQ -> TySynEqnQ -tySynEqn lhs rhs = +tySynEqn :: (Maybe [TyVarBndr]) -> TypeQ -> TypeQ -> TySynEqnQ +tySynEqn tvs lhs rhs = do - lhs1 <- sequence lhs + lhs1 <- lhs rhs1 <- rhs - return (TySynEqn Nothing lhs1 rhs1) + return (TySynEqn tvs lhs1 rhs1) forallC :: [TyVarBndr] -> CxtQ -> ConQ -> ConQ forallC ns ctxt con = liftM2 (ForallC ns) ctxt con diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index 11391da95f..ec9ca4fafb 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -491,35 +491,35 @@ pragLineD line file = return $ PragmaD $ LineP line file pragCompleteD :: [Name] -> Maybe Name -> DecQ pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty -dataInstD :: CxtQ -> Name -> (Maybe [TyVarBndrQ]) -> [TypeQ] -> Maybe KindQ - -> [ConQ] -> [DerivClauseQ] -> DecQ -dataInstD ctxt tc mb_bndrs tys ksig cons derivs = +dataInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> [ConQ] + -> [DerivClauseQ] -> DecQ +dataInstD ctxt mb_bndrs ty ksig cons derivs = do - ctxt1 <- ctxt + ctxt1 <- ctxt mb_bndrs1 <- traverse sequence mb_bndrs - tys1 <- sequenceA tys - ksig1 <- sequenceA ksig - cons1 <- sequenceA cons - derivs1 <- sequenceA derivs - return (DataInstD ctxt1 tc mb_bndrs1 tys1 ksig1 cons1 derivs1) - -newtypeInstD :: CxtQ -> Name -> (Maybe [TyVarBndrQ]) -> [TypeQ] -> Maybe KindQ - -> ConQ -> [DerivClauseQ] -> DecQ -newtypeInstD ctxt tc mb_bndrs tys ksig con derivs = + ty1 <- ty + ksig1 <- sequenceA ksig + cons1 <- sequenceA cons + derivs1 <- sequenceA derivs + return (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1) + +newtypeInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> ConQ + -> [DerivClauseQ] -> DecQ +newtypeInstD ctxt mb_bndrs ty ksig con derivs = do - ctxt1 <- ctxt + ctxt1 <- ctxt mb_bndrs1 <- traverse sequence mb_bndrs - tys1 <- sequenceA tys - ksig1 <- sequenceA ksig - con1 <- con - derivs1 <- sequence derivs - return (NewtypeInstD ctxt1 tc mb_bndrs1 tys1 ksig1 con1 derivs1) - -tySynInstD :: Name -> TySynEqnQ -> DecQ -tySynInstD tc eqn = + ty1 <- ty + ksig1 <- sequenceA ksig + con1 <- con + derivs1 <- sequence derivs + return (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1) + +tySynInstD :: TySynEqnQ -> DecQ +tySynInstD eqn = do eqn1 <- eqn - return (TySynInstD tc eqn1) + return (TySynInstD eqn1) dataFamilyD :: Name -> [TyVarBndrQ] -> Maybe KindQ -> DecQ dataFamilyD tc tvs kind = @@ -584,11 +584,11 @@ implicitParamBindD n e = e' <- e return $ ImplicitParamBindD n e' -tySynEqn :: (Maybe [TyVarBndrQ]) -> [TypeQ] -> TypeQ -> TySynEqnQ +tySynEqn :: (Maybe [TyVarBndrQ]) -> TypeQ -> TypeQ -> TySynEqnQ tySynEqn mb_bndrs lhs rhs = do mb_bndrs1 <- traverse sequence mb_bndrs - lhs1 <- sequence lhs + lhs1 <- lhs rhs1 <- rhs return (TySynEqn mb_bndrs1 lhs1 rhs1) @@ -672,6 +672,12 @@ appT t1 t2 = do t2' <- t2 return $ AppT t1' t2' +appKindT :: TypeQ -> KindQ -> TypeQ +appKindT ty ki = do + ty' <- ty + ki' <- ki + return $ AppKindT ty' ki' + arrowT :: TypeQ arrowT = return ArrowT diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 621c0f5fcc..c25b2fb702 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -325,11 +325,11 @@ ppr_dec _ (FunD f cs) = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r $$ where_clause ds ppr_dec _ (TySynD t xs rhs) - = ppr_tySyn empty t (hsep (map ppr xs)) rhs + = ppr_tySyn empty (Just t) (hsep (map ppr xs)) rhs ppr_dec _ (DataD ctxt t xs ksig cs decs) - = ppr_data empty ctxt t (hsep (map ppr xs)) ksig cs decs + = ppr_data empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs ppr_dec _ (NewtypeD ctxt t xs ksig c decs) - = ppr_newtype empty ctxt t (sep (map ppr xs)) ksig c decs + = ppr_newtype empty ctxt (Just t) (sep (map ppr xs)) ksig c decs ppr_dec _ (ClassD ctxt c xs fds ds) = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds $$ where_clause ds @@ -347,21 +347,21 @@ ppr_dec isTop (DataFamilyD tc tvs kind) | otherwise = empty maybeKind | (Just k') <- kind = dcolon <+> ppr k' | otherwise = empty -ppr_dec isTop (DataInstD ctxt tc bndrs tys ksig cs decs) - = ppr_data (maybeInst <+> ppr_bndrs bndrs) ctxt tc - (sep (map pprParendType tys)) ksig cs decs +ppr_dec isTop (DataInstD ctxt bndrs ty ksig cs decs) + = ppr_data (maybeInst <+> ppr_bndrs bndrs) + ctxt Nothing (ppr ty) ksig cs decs where maybeInst | isTop = text "instance" | otherwise = empty -ppr_dec isTop (NewtypeInstD ctxt tc bndrs tys ksig c decs) - = ppr_newtype (maybeInst <+> ppr_bndrs bndrs) ctxt tc - (sep (map pprParendType tys)) ksig c decs +ppr_dec isTop (NewtypeInstD ctxt bndrs ty ksig c decs) + = ppr_newtype (maybeInst <+> ppr_bndrs bndrs) + ctxt Nothing (ppr ty) ksig c decs where maybeInst | isTop = text "instance" | otherwise = empty -ppr_dec isTop (TySynInstD tc (TySynEqn mb_bndrs tys rhs)) - = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs) tc - (sep (map pprParendType tys)) rhs +ppr_dec isTop (TySynInstD (TySynEqn mb_bndrs ty rhs)) + = ppr_tySyn (maybeInst <+> ppr_bndrs mb_bndrs) + Nothing (ppr ty) rhs where maybeInst | isTop = text "instance" | otherwise = empty @@ -370,13 +370,12 @@ ppr_dec isTop (OpenTypeFamilyD tfhead) where maybeFamily | isTop = text "family" | otherwise = empty -ppr_dec _ (ClosedTypeFamilyD tfhead@(TypeFamilyHead tc _ _ _) eqns) +ppr_dec _ (ClosedTypeFamilyD tfhead eqns) = hang (text "type family" <+> ppr_tf_head tfhead <+> text "where") nestDepth (vcat (map ppr_eqn eqns)) where ppr_eqn (TySynEqn mb_bndrs lhs rhs) - = ppr_bndrs mb_bndrs <+> ppr tc <+> sep (map pprParendType lhs) - <+> text "=" <+> ppr rhs + = ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs ppr_dec _ (RoleAnnotD name roles) = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles) ppr_dec _ (StandaloneDerivD ds cxt ty) @@ -416,12 +415,15 @@ ppr_overlap o = text $ Overlapping -> "{-# OVERLAPPING #-}" Incoherent -> "{-# INCOHERENT #-}" -ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] +ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc ppr_data maybeInst ctxt t argsDoc ksig cs decs = sep [text "data" <+> maybeInst <+> pprCxt ctxt - <+> pprName' Applied t <+> argsDoc <+> ksigDoc <+> maybeWhere, + <+> case t of + Just n -> pprName' Applied n <+> argsDoc + Nothing -> argsDoc + <+> ksigDoc <+> maybeWhere, nest nestDepth (sep (pref $ map ppr cs)), if null decs then empty @@ -448,12 +450,15 @@ ppr_data maybeInst ctxt t argsDoc ksig cs decs Nothing -> empty Just k -> dcolon <+> ppr k -ppr_newtype :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> Con -> [DerivClause] +ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause] -> Doc ppr_newtype maybeInst ctxt t argsDoc ksig c decs = sep [text "newtype" <+> maybeInst <+> pprCxt ctxt - <+> ppr t <+> argsDoc <+> ksigDoc, + <+> case t of + Just n -> ppr n <+> argsDoc + Nothing -> argsDoc + <+> ksigDoc, nest 2 (char '=' <+> ppr c), if null decs then empty @@ -477,9 +482,13 @@ ppr_deriv_clause (DerivClause ds ctxt) Just (via@ViaStrategy{}) -> (empty, ppr_deriv_strategy via) _ -> (maybe empty ppr_deriv_strategy ds, empty) -ppr_tySyn :: Doc -> Name -> Doc -> Type -> Doc +ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc ppr_tySyn maybeInst t argsDoc rhs - = text "type" <+> maybeInst <+> ppr t <+> argsDoc <+> text "=" <+> ppr rhs + = text "type" <+> maybeInst + <+> case t of + Just n -> ppr n <+> argsDoc + Nothing -> argsDoc + <+> text "=" <+> ppr rhs ppr_tf_head :: TypeFamilyHead -> Doc ppr_tf_head (TypeFamilyHead tc tvs res inj) @@ -742,6 +751,7 @@ pprParendType (ImplicitParamT n t)= text ('?':n) <+> text "::" <+> ppr t pprParendType EqualityT = text "(~)" pprParendType t@(ForallT {}) = parens (ppr t) pprParendType t@(AppT {}) = parens (ppr t) +pprParendType t@(AppKindT {}) = parens (ppr t) pprUInfixT :: Type -> Doc pprUInfixT (UInfixT x n y) = pprUInfixT x <+> pprName' Infix n <+> pprUInfixT y @@ -752,7 +762,13 @@ instance Ppr Type where ppr ty = pprTyApp (split ty) -- Works, in a degnerate way, for SigT, and puts parens round (ty :: kind) -- See Note [Pretty-printing kind signatures] +instance Ppr TypeArg where + ppr (TANormal ty) = ppr ty + ppr (TyArg ki) = char '@' <> ppr ki +pprParendTypeArg :: TypeArg -> Doc +pprParendTypeArg (TANormal ty) = pprParendType ty +pprParendTypeArg (TyArg ki) = char '@' <> pprParendType ki {- Note [Pretty-printing kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC's parser only recognises a kind signature in a type when there are @@ -761,16 +777,16 @@ parens around it. E.g. the parens are required here: type instance F Int = (Bool :: *) So we always print a SigT with parens (see Trac #10050). -} -pprTyApp :: (Type, [Type]) -> Doc -pprTyApp (ArrowT, [arg1,arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2] -pprTyApp (EqualityT, [arg1, arg2]) = +pprTyApp :: (Type, [TypeArg]) -> Doc +pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2] +pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "~", ppr arg2] -pprTyApp (ListT, [arg]) = brackets (ppr arg) +pprTyApp (ListT, [TANormal arg]) = brackets (ppr arg) pprTyApp (TupleT n, args) | length args == n = parens (commaSep args) pprTyApp (PromotedTupleT n, args) | length args == n = quoteParens (commaSep args) -pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendType args) +pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendTypeArg args) pprFunArgType :: Type -> Doc -- Should really use a precedence argument -- Everything except forall and (->) binds more tightly than (->) @@ -779,9 +795,13 @@ pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty) pprFunArgType ty@(SigT _ _) = parens (ppr ty) pprFunArgType ty = ppr ty -split :: Type -> (Type, [Type]) -- Split into function and args +data TypeArg = TANormal Type + | TyArg Kind + +split :: Type -> (Type, [TypeArg]) -- Split into function and args split t = go t [] - where go (AppT t1 t2) args = go t1 (t2:args) + where go (AppT t1 t2) args = go t1 (TANormal t2:args) + go (AppKindT ty ki) args = go ty (TyArg ki:args) go ty args = (ty, args) pprTyLit :: TyLit -> Doc diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index ef44a5cbf3..770fac7580 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1727,24 +1727,20 @@ data Dec (Maybe Kind) -- ^ @{ data family T a b c :: * }@ - | DataInstD Cxt Name - (Maybe [TyVarBndr]) -- Quantified type vars - [Type] + | DataInstD Cxt (Maybe [TyVarBndr]) Type (Maybe Kind) -- Kind signature [Con] [DerivClause] -- ^ @{ data instance Cxt x => T [x] -- = A x | B (T x) -- deriving (Z,W) -- deriving stock Eq }@ - | NewtypeInstD Cxt Name - (Maybe [TyVarBndr]) -- Quantified type vars - [Type] + | NewtypeInstD Cxt (Maybe [TyVarBndr]) Type -- Quantified type vars (Maybe Kind) -- Kind signature Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x] -- = A (B x) -- deriving (Z,W) -- deriving stock Eq }@ - | TySynInstD Name TySynEqn -- ^ @{ type instance ... }@ + | TySynInstD TySynEqn -- ^ @{ type instance ... }@ -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD') | OpenTypeFamilyD TypeFamilyHead @@ -1855,9 +1851,23 @@ data TypeFamilyHead = deriving( Show, Eq, Ord, Data, Generic ) -- | One equation of a type family instance or closed type family. The --- arguments are the left-hand-side type patterns and the right-hand-side --- result. -data TySynEqn = TySynEqn (Maybe [TyVarBndr]) [Type] Type +-- arguments are the left-hand-side type and the right-hand-side result. +-- +-- For instance, if you had the following type family: +-- +-- @ +-- type family Foo (a :: k) :: k where +-- forall k (a :: k). Foo \@k a = a +-- @ +-- +-- The @Foo \@k a = a@ equation would be represented as follows: +-- +-- @ +-- 'TySynEqn' ('Just' ['PlainTV' k, 'KindedTV' a ('VarT' k)]) +-- ('AppT' ('AppKindT' ('ConT' ''Foo) ('VarT' k)) ('VarT' a)) +-- ('VarT' a) +-- @ +data TySynEqn = TySynEqn (Maybe [TyVarBndr]) Type Type deriving( Show, Eq, Ord, Data, Generic ) data FunDep = FunDep [Name] [Name] @@ -2037,6 +2047,7 @@ data PatSynArgs data Type = ForallT [TyVarBndr] Cxt Type -- ^ @forall \<vars\>. \<ctxt\> => \<type\>@ | AppT Type Type -- ^ @T a b@ + | AppKindT Type Kind -- ^ @T \@k t@ | SigT Type Kind -- ^ @t :: k@ | VarT Name -- ^ @a@ | ConT Name -- ^ @T@ diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 5dca9832c5..b1444341d8 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -5,12 +5,18 @@ * In `Language.Haskell.TH.Syntax`, `DataInstD`, `NewTypeInstD`, `TySynEqn`, and `RuleP` now all have a `Maybe [TyVarBndr]` argument, which contains a list of quantified type variables if an explicit `forall` is present, and - `Nothing` otherwise. + `Nothing` otherwise. `DataInstD`, `NewTypeInstD`, `TySynEqn` also now use + a single `Type` argument to represent the left-hand-side to avoid + malformed type family equations and allow visible kind application. Correspondingly, in `Language.Haskell.TH.Lib.Internal`, `pragRuleD`, `dataInstD`, `newtypeInstD`, and `tySynEqn` now all have a `Maybe [TyVarBndrQ]` argument. Non-API-breaking versions of these - functions can be found in `Language.Haskell.TH.Lib`. + functions can be found in `Language.Haskell.TH.Lib`. The type signature + of `tySynEqn` has also changed from `[TypeQ] -> TypeQ -> TySynEqnQ` to + `(Maybe [TyVarBndrQ]) -> TypeQ -> TypeQ -> TySynEqnQ`, for the same reason + as in `Language.Haskell.TH.Syntax` above. Consequently, `tySynInstD` also + changes from `Name -> TySynEqnQ -> DecQ` to `TySynEqnQ -> DecQ`. * Add `Lift` instances for `NonEmpty` and `Void` diff --git a/testsuite/tests/dependent/should_compile/T11241.stderr b/testsuite/tests/dependent/should_compile/T11241.stderr index 97b2a33cf2..adb78694ba 100644 --- a/testsuite/tests/dependent/should_compile/T11241.stderr +++ b/testsuite/tests/dependent/should_compile/T11241.stderr @@ -1,4 +1,5 @@ T11241.hs:5:21: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘*’ - • In the type signature: foo :: forall (a :: _). a -> a + • In the kind ‘_’ + In the type signature: foo :: forall (a :: _). a -> a diff --git a/testsuite/tests/deriving/should_compile/T14579a.hs b/testsuite/tests/deriving/should_compile/T14579a.hs new file mode 100644 index 0000000000..ac7ba6cca8 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/T14579a.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Bug where + +import Data.Coerce +import Data.Kind +import Data.Proxy + +newtype Wat (x :: Proxy (a :: Type)) = MkWat (Maybe a) + deriving Eq + +newtype Glurp a = MkGlurp (Wat ('Proxy :: Proxy a)) + +instance Eq a => Eq (Glurp a) where + (==) = coerce @(Wat ('Proxy @a) -> Wat ('Proxy @a) -> Bool) + @(Glurp a -> Glurp a -> Bool) + (==) diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index c49b808860..8c84bcc31a 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -105,6 +105,7 @@ test('T14339', normal, compile, ['']) test('T14331', normal, compile, ['']) test('T14578', normal, compile, ['-ddump-deriv -dsuppress-uniques']) test('T14579', normal, compile, ['']) +test('T14579a', normal, compile, ['']) test('T14682', normal, compile, ['-ddump-deriv -dsuppress-uniques']) test('T14883', normal, compile, ['']) test('T14932', normal, compile, ['']) diff --git a/testsuite/tests/ghci/scripts/T12447.stdout b/testsuite/tests/ghci/scripts/T12447.stdout index 6c469eeef3..7a64e1546d 100644 --- a/testsuite/tests/ghci/scripts/T12447.stdout +++ b/testsuite/tests/ghci/scripts/T12447.stdout @@ -1,3 +1,3 @@ deferEither @(_ ~ _) - :: (Typeable w1, Typeable w2) => - proxy (w1 ~ w2) -> ((w1 ~ w2) => r) -> Either String r + :: (Typeable _1, Typeable _2) => + proxy (_1 ~ _2) -> ((_1 ~ _2) => r) -> Either String r diff --git a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr index e7065cf3b4..ca0e33c5ff 100644 --- a/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr +++ b/testsuite/tests/indexed-types/should_fail/ExplicitForAllFams4b.stderr @@ -57,18 +57,6 @@ ExplicitForAllFams4b.hs:23:17: error: • In the type instance declaration for ‘CT’ In the instance declaration for ‘C Int’ -ExplicitForAllFams4b.hs:23:20: error: - Conflicting family instance declarations: - CT [a] (a, a) = Float -- Defined at ExplicitForAllFams4b.hs:23:20 - CT _ _ = Maybe b -- Defined at ExplicitForAllFams4b.hs:24:20 - -ExplicitForAllFams4b.hs:24:3: error: - • Type indexes must match class instance head - Expected: CT Int _ - Actual: CT _ _ - • In the type instance declaration for ‘CT’ - In the instance declaration for ‘C Int’ - ExplicitForAllFams4b.hs:24:15: error: • Type variable ‘b’ is mentioned in the RHS, but not bound on the LHS of the family instance @@ -88,18 +76,6 @@ ExplicitForAllFams4b.hs:26:17: error: • In the data instance declaration for ‘CD’ In the instance declaration for ‘C Int’ -ExplicitForAllFams4b.hs:26:20: error: - Conflicting family instance declarations: - CD [a] (a, a) -- Defined at ExplicitForAllFams4b.hs:26:20 - CD _ _ -- Defined at ExplicitForAllFams4b.hs:27:20 - -ExplicitForAllFams4b.hs:27:3: error: - • Type indexes must match class instance head - Expected: CD Int _ - Actual: CD _ _ - • In the data instance declaration for ‘CD’ - In the instance declaration for ‘C Int’ - ExplicitForAllFams4b.hs:27:15: error: • Type variable ‘b’ is mentioned in the RHS, but not bound on the LHS of the family instance diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.hs b/testsuite/tests/parser/should_compile/DumpParsedAst.hs index 0f83b12f65..f2bf433324 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.hs +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies + , TypeApplications, TypeInType #-} module DumpParsedAst where +import Data.Kind data Peano = Zero | Succ Peano @@ -8,4 +10,10 @@ type family Length (as :: [k]) :: Peano where Length (a : as) = Succ (Length as) Length '[] = Zero +-- vis kind app +data T f (a :: k) = MkT (f a) + +type family F1 (a :: k) (f :: k -> Type) :: Type where + F1 @Peano a f = T @Peano f a + main = putStrLn "hello" diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 408f28b4f7..81607d729e 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -4,16 +4,28 @@ ({ DumpParsedAst.hs:1:1 } (HsModule (Just - ({ DumpParsedAst.hs:3:8-20 } + ({ DumpParsedAst.hs:4:8-20 } {ModuleName: DumpParsedAst})) (Nothing) - [] - [({ DumpParsedAst.hs:5:1-30 } + [({ DumpParsedAst.hs:5:1-16 } + (ImportDecl + (NoExt) + (NoSourceText) + ({ DumpParsedAst.hs:5:8-16 } + {ModuleName: Data.Kind}) + (Nothing) + (False) + (False) + (False) + (False) + (Nothing) + (Nothing)))] + [({ DumpParsedAst.hs:7:1-30 } (TyClD (NoExt) (DataDecl (NoExt) - ({ DumpParsedAst.hs:5:6-10 } + ({ DumpParsedAst.hs:7:6-10 } (Unqual {OccName: Peano})) (HsQTvs @@ -27,10 +39,10 @@ []) (Nothing) (Nothing) - [({ DumpParsedAst.hs:5:14-17 } + [({ DumpParsedAst.hs:7:14-17 } (ConDeclH98 (NoExt) - ({ DumpParsedAst.hs:5:14-17 } + ({ DumpParsedAst.hs:7:14-17 } (Unqual {OccName: Zero})) ({ <no location info> } @@ -40,10 +52,10 @@ (PrefixCon []) (Nothing))) - ,({ DumpParsedAst.hs:5:21-30 } + ,({ DumpParsedAst.hs:7:21-30 } (ConDeclH98 (NoExt) - ({ DumpParsedAst.hs:5:21-24 } + ({ DumpParsedAst.hs:7:21-24 } (Unqual {OccName: Succ})) ({ <no location info> } @@ -51,17 +63,17 @@ [] (Nothing) (PrefixCon - [({ DumpParsedAst.hs:5:26-30 } + [({ DumpParsedAst.hs:7:26-30 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpParsedAst.hs:5:26-30 } + ({ DumpParsedAst.hs:7:26-30 } (Unqual {OccName: Peano}))))]) (Nothing)))] ({ <no location info> } []))))) - ,({ DumpParsedAst.hs:7:1-39 } + ,({ DumpParsedAst.hs:9:1-39 } (TyClD (NoExt) (FamDecl @@ -70,140 +82,346 @@ (NoExt) (ClosedTypeFamily (Just - [({ DumpParsedAst.hs:8:3-36 } + [({ DumpParsedAst.hs:10:3-36 } (HsIB (NoExt) (FamEqn (NoExt) - ({ DumpParsedAst.hs:8:3-8 } + ({ DumpParsedAst.hs:10:3-8 } (Unqual {OccName: Length})) (Nothing) - [({ DumpParsedAst.hs:8:10-17 } - (HsParTy - (NoExt) - ({ DumpParsedAst.hs:8:11-16 } - (HsOpTy - (NoExt) - ({ DumpParsedAst.hs:8:11 } - (HsTyVar - (NoExt) - (NotPromoted) - ({ DumpParsedAst.hs:8:11 } - (Unqual - {OccName: a})))) - ({ DumpParsedAst.hs:8:13 } - (Exact - {Name: :})) - ({ DumpParsedAst.hs:8:15-16 } - (HsTyVar - (NoExt) - (NotPromoted) - ({ DumpParsedAst.hs:8:15-16 } - (Unqual - {OccName: as}))))))))] + [(HsValArg + ({ DumpParsedAst.hs:10:10-17 } + (HsParTy + (NoExt) + ({ DumpParsedAst.hs:10:11-16 } + (HsOpTy + (NoExt) + ({ DumpParsedAst.hs:10:11 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:10:11 } + (Unqual + {OccName: a})))) + ({ DumpParsedAst.hs:10:13 } + (Exact + {Name: :})) + ({ DumpParsedAst.hs:10:15-16 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:10:15-16 } + (Unqual + {OccName: as})))))))))] (Prefix) - ({ DumpParsedAst.hs:8:21-36 } + ({ DumpParsedAst.hs:10:21-36 } (HsAppTy (NoExt) - ({ DumpParsedAst.hs:8:21-24 } + ({ DumpParsedAst.hs:10:21-24 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpParsedAst.hs:8:21-24 } + ({ DumpParsedAst.hs:10:21-24 } (Unqual {OccName: Succ})))) - ({ DumpParsedAst.hs:8:26-36 } + ({ DumpParsedAst.hs:10:26-36 } (HsParTy (NoExt) - ({ DumpParsedAst.hs:8:27-35 } + ({ DumpParsedAst.hs:10:27-35 } (HsAppTy (NoExt) - ({ DumpParsedAst.hs:8:27-32 } + ({ DumpParsedAst.hs:10:27-32 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpParsedAst.hs:8:27-32 } + ({ DumpParsedAst.hs:10:27-32 } (Unqual {OccName: Length})))) - ({ DumpParsedAst.hs:8:34-35 } + ({ DumpParsedAst.hs:10:34-35 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpParsedAst.hs:8:34-35 } + ({ DumpParsedAst.hs:10:34-35 } (Unqual {OccName: as}))))))))))))) - ,({ DumpParsedAst.hs:9:3-24 } + ,({ DumpParsedAst.hs:11:3-24 } (HsIB (NoExt) (FamEqn (NoExt) - ({ DumpParsedAst.hs:9:3-8 } + ({ DumpParsedAst.hs:11:3-8 } (Unqual {OccName: Length})) (Nothing) - [({ DumpParsedAst.hs:9:10-12 } - (HsExplicitListTy - (NoExt) - (IsPromoted) - []))] + [(HsValArg + ({ DumpParsedAst.hs:11:10-12 } + (HsExplicitListTy + (NoExt) + (IsPromoted) + [])))] (Prefix) - ({ DumpParsedAst.hs:9:21-24 } + ({ DumpParsedAst.hs:11:21-24 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpParsedAst.hs:9:21-24 } + ({ DumpParsedAst.hs:11:21-24 } (Unqual {OccName: Zero})))))))])) - ({ DumpParsedAst.hs:7:13-18 } + ({ DumpParsedAst.hs:9:13-18 } (Unqual {OccName: Length})) (HsQTvs (NoExt) - [({ DumpParsedAst.hs:7:21-29 } + [({ DumpParsedAst.hs:9:21-29 } (KindedTyVar (NoExt) - ({ DumpParsedAst.hs:7:21-22 } + ({ DumpParsedAst.hs:9:21-22 } (Unqual {OccName: as})) - ({ DumpParsedAst.hs:7:27-29 } + ({ DumpParsedAst.hs:9:27-29 } (HsListTy (NoExt) - ({ DumpParsedAst.hs:7:28 } + ({ DumpParsedAst.hs:9:28 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpParsedAst.hs:7:28 } + ({ DumpParsedAst.hs:9:28 } (Unqual {OccName: k}))))))))]) (Prefix) - ({ DumpParsedAst.hs:7:32-39 } + ({ DumpParsedAst.hs:9:32-39 } (KindSig (NoExt) - ({ DumpParsedAst.hs:7:35-39 } + ({ DumpParsedAst.hs:9:35-39 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpParsedAst.hs:7:35-39 } + ({ DumpParsedAst.hs:9:35-39 } (Unqual {OccName: Peano})))))) (Nothing))))) - ,({ DumpParsedAst.hs:11:1-23 } + ,({ DumpParsedAst.hs:14:1-29 } + (TyClD + (NoExt) + (DataDecl + (NoExt) + ({ DumpParsedAst.hs:14:6 } + (Unqual + {OccName: T})) + (HsQTvs + (NoExt) + [({ DumpParsedAst.hs:14:8 } + (UserTyVar + (NoExt) + ({ DumpParsedAst.hs:14:8 } + (Unqual + {OccName: f})))) + ,({ DumpParsedAst.hs:14:11-16 } + (KindedTyVar + (NoExt) + ({ DumpParsedAst.hs:14:11 } + (Unqual + {OccName: a})) + ({ DumpParsedAst.hs:14:16 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:14:16 } + (Unqual + {OccName: k}))))))]) + (Prefix) + (HsDataDefn + (NoExt) + (DataType) + ({ <no location info> } + []) + (Nothing) + (Nothing) + [({ DumpParsedAst.hs:14:21-29 } + (ConDeclH98 + (NoExt) + ({ DumpParsedAst.hs:14:21-23 } + (Unqual + {OccName: MkT})) + ({ <no location info> } + (False)) + [] + (Nothing) + (PrefixCon + [({ DumpParsedAst.hs:14:25-29 } + (HsParTy + (NoExt) + ({ DumpParsedAst.hs:14:26-28 } + (HsAppTy + (NoExt) + ({ DumpParsedAst.hs:14:26 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:14:26 } + (Unqual + {OccName: f})))) + ({ DumpParsedAst.hs:14:28 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:14:28 } + (Unqual + {OccName: a}))))))))]) + (Nothing)))] + ({ <no location info> } + []))))) + ,({ DumpParsedAst.hs:16:1-48 } + (TyClD + (NoExt) + (FamDecl + (NoExt) + (FamilyDecl + (NoExt) + (ClosedTypeFamily + (Just + [({ DumpParsedAst.hs:17:3-30 } + (HsIB + (NoExt) + (FamEqn + (NoExt) + ({ DumpParsedAst.hs:17:3-4 } + (Unqual + {OccName: F1})) + (Nothing) + [(HsTypeArg + ({ DumpParsedAst.hs:17:7-11 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:17:7-11 } + (Unqual + {OccName: Peano}))))) + ,(HsValArg + ({ DumpParsedAst.hs:17:13 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:17:13 } + (Unqual + {OccName: a}))))) + ,(HsValArg + ({ DumpParsedAst.hs:17:15 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:17:15 } + (Unqual + {OccName: f})))))] + (Prefix) + ({ DumpParsedAst.hs:17:19-30 } + (HsAppTy + (NoExt) + ({ DumpParsedAst.hs:17:19-28 } + (HsAppTy + (NoExt) + ({ DumpParsedAst.hs:17:19-26 } + (HsAppKindTy + (NoExt) + ({ DumpParsedAst.hs:17:19 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:17:19 } + (Unqual + {OccName: T})))) + ({ DumpParsedAst.hs:17:22-26 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:17:22-26 } + (Unqual + {OccName: Peano})))))) + ({ DumpParsedAst.hs:17:28 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:17:28 } + (Unqual + {OccName: f})))))) + ({ DumpParsedAst.hs:17:30 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:17:30 } + (Unqual + {OccName: a})))))))))])) + ({ DumpParsedAst.hs:16:13-14 } + (Unqual + {OccName: F1})) + (HsQTvs + (NoExt) + [({ DumpParsedAst.hs:16:17-22 } + (KindedTyVar + (NoExt) + ({ DumpParsedAst.hs:16:17 } + (Unqual + {OccName: a})) + ({ DumpParsedAst.hs:16:22 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:16:22 } + (Unqual + {OccName: k})))))) + ,({ DumpParsedAst.hs:16:26-39 } + (KindedTyVar + (NoExt) + ({ DumpParsedAst.hs:16:26 } + (Unqual + {OccName: f})) + ({ DumpParsedAst.hs:16:31-39 } + (HsFunTy + (NoExt) + ({ DumpParsedAst.hs:16:31 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:16:31 } + (Unqual + {OccName: k})))) + ({ DumpParsedAst.hs:16:36-39 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:16:36-39 } + (Unqual + {OccName: Type}))))))))]) + (Prefix) + ({ DumpParsedAst.hs:16:42-48 } + (KindSig + (NoExt) + ({ DumpParsedAst.hs:16:45-48 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpParsedAst.hs:16:45-48 } + (Unqual + {OccName: Type})))))) + (Nothing))))) + ,({ DumpParsedAst.hs:19:1-23 } (ValD (NoExt) (FunBind (NoExt) - ({ DumpParsedAst.hs:11:1-4 } + ({ DumpParsedAst.hs:19:1-4 } (Unqual {OccName: main})) (MG (NoExt) - ({ DumpParsedAst.hs:11:1-23 } - [({ DumpParsedAst.hs:11:1-23 } + ({ DumpParsedAst.hs:19:1-23 } + [({ DumpParsedAst.hs:19:1-23 } (Match (NoExt) (FunRhs - ({ DumpParsedAst.hs:11:1-4 } + ({ DumpParsedAst.hs:19:1-4 } (Unqual {OccName: main})) (Prefix) @@ -211,20 +429,20 @@ [] (GRHSs (NoExt) - [({ DumpParsedAst.hs:11:6-23 } + [({ DumpParsedAst.hs:19:6-23 } (GRHS (NoExt) [] - ({ DumpParsedAst.hs:11:8-23 } + ({ DumpParsedAst.hs:19:8-23 } (HsApp (NoExt) - ({ DumpParsedAst.hs:11:8-15 } + ({ DumpParsedAst.hs:19:8-15 } (HsVar (NoExt) - ({ DumpParsedAst.hs:11:8-15 } + ({ DumpParsedAst.hs:19:8-15 } (Unqual {OccName: putStrLn})))) - ({ DumpParsedAst.hs:11:17-23 } + ({ DumpParsedAst.hs:19:17-23 } (HsLit (NoExt) (HsString diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.hs b/testsuite/tests/parser/should_compile/DumpRenamedAst.hs index c617febd40..d5be8627be 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.hs +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DataKinds, GADTs, PolyKinds, RankNTypes, TypeOperators, - TypeFamilies #-} + TypeFamilies, StarIsType, TypeApplications #-} module DumpRenamedAst where +import Data.Kind import Data.Kind (Type) @@ -17,4 +18,9 @@ data family Nat :: k -> k -> Type newtype instance Nat (a :: k -> Type) :: (k -> Type) -> Type where Nat :: (forall xx. f xx -> g xx) -> Nat f g +data T f (a :: k) = MkT (f a) + +type family F1 (a :: k) (f :: k -> Type) :: Type where + F1 @Peano a f = T @Peano f a + main = putStrLn "hello" diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index 5a35b0037c..8df66c806f 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -10,39 +10,39 @@ [((,) (NonRecursive) {Bag(Located (HsBind Name)): - [({ DumpRenamedAst.hs:20:1-23 } + [({ DumpRenamedAst.hs:26:1-23 } (FunBind {NameSet: []} - ({ DumpRenamedAst.hs:20:1-4 } + ({ DumpRenamedAst.hs:26:1-4 } {Name: DumpRenamedAst.main}) (MG (NoExt) - ({ DumpRenamedAst.hs:20:1-23 } - [({ DumpRenamedAst.hs:20:1-23 } + ({ DumpRenamedAst.hs:26:1-23 } + [({ DumpRenamedAst.hs:26:1-23 } (Match (NoExt) (FunRhs - ({ DumpRenamedAst.hs:20:1-4 } + ({ DumpRenamedAst.hs:26:1-4 } {Name: DumpRenamedAst.main}) (Prefix) (NoSrcStrict)) [] (GRHSs (NoExt) - [({ DumpRenamedAst.hs:20:6-23 } + [({ DumpRenamedAst.hs:26:6-23 } (GRHS (NoExt) [] - ({ DumpRenamedAst.hs:20:8-23 } + ({ DumpRenamedAst.hs:26:8-23 } (HsApp (NoExt) - ({ DumpRenamedAst.hs:20:8-15 } + ({ DumpRenamedAst.hs:26:8-15 } (HsVar (NoExt) - ({ DumpRenamedAst.hs:20:8-15 } + ({ DumpRenamedAst.hs:26:8-15 } {Name: System.IO.putStrLn}))) - ({ DumpRenamedAst.hs:20:17-23 } + ({ DumpRenamedAst.hs:26:17-23 } (HsLit (NoExt) (HsString @@ -59,13 +59,13 @@ [] [(TyClGroup (NoExt) - [({ DumpRenamedAst.hs:8:1-30 } + [({ DumpRenamedAst.hs:9:1-30 } (DataDecl (DataDeclRn (True) {NameSet: [{Name: DumpRenamedAst.Peano}]}) - ({ DumpRenamedAst.hs:8:6-10 } + ({ DumpRenamedAst.hs:9:6-10 } {Name: DumpRenamedAst.Peano}) (HsQTvs (HsQTvsRn @@ -81,10 +81,10 @@ []) (Nothing) (Nothing) - [({ DumpRenamedAst.hs:8:14-17 } + [({ DumpRenamedAst.hs:9:14-17 } (ConDeclH98 (NoExt) - ({ DumpRenamedAst.hs:8:14-17 } + ({ DumpRenamedAst.hs:9:14-17 } {Name: DumpRenamedAst.Zero}) ({ <no location info> } (False)) @@ -93,21 +93,21 @@ (PrefixCon []) (Nothing))) - ,({ DumpRenamedAst.hs:8:21-30 } + ,({ DumpRenamedAst.hs:9:21-30 } (ConDeclH98 (NoExt) - ({ DumpRenamedAst.hs:8:21-24 } + ({ DumpRenamedAst.hs:9:21-24 } {Name: DumpRenamedAst.Succ}) ({ <no location info> } (False)) [] (Nothing) (PrefixCon - [({ DumpRenamedAst.hs:8:26-30 } + [({ DumpRenamedAst.hs:9:26-30 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:8:26-30 } + ({ DumpRenamedAst.hs:9:26-30 } {Name: DumpRenamedAst.Peano})))]) (Nothing)))] ({ <no location info> } @@ -116,133 +116,135 @@ []) ,(TyClGroup (NoExt) - [({ DumpRenamedAst.hs:10:1-39 } + [({ DumpRenamedAst.hs:11:1-39 } (FamDecl (NoExt) (FamilyDecl (NoExt) (ClosedTypeFamily (Just - [({ DumpRenamedAst.hs:11:3-36 } + [({ DumpRenamedAst.hs:12:3-36 } (HsIB [{Name: a} ,{Name: as}] (FamEqn (NoExt) - ({ DumpRenamedAst.hs:11:3-8 } + ({ DumpRenamedAst.hs:12:3-8 } {Name: DumpRenamedAst.Length}) (Nothing) - [({ DumpRenamedAst.hs:11:10-17 } - (HsParTy - (NoExt) - ({ DumpRenamedAst.hs:11:11-16 } - (HsOpTy - (NoExt) - ({ DumpRenamedAst.hs:11:11 } - (HsTyVar - (NoExt) - (NotPromoted) - ({ DumpRenamedAst.hs:11:11 } - {Name: a}))) - ({ DumpRenamedAst.hs:11:13 } - {Name: :}) - ({ DumpRenamedAst.hs:11:15-16 } - (HsTyVar - (NoExt) - (NotPromoted) - ({ DumpRenamedAst.hs:11:15-16 } - {Name: as})))))))] + [(HsValArg + ({ DumpRenamedAst.hs:12:10-17 } + (HsParTy + (NoExt) + ({ DumpRenamedAst.hs:12:11-16 } + (HsOpTy + (NoExt) + ({ DumpRenamedAst.hs:12:11 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:12:11 } + {Name: a}))) + ({ DumpRenamedAst.hs:12:13 } + {Name: :}) + ({ DumpRenamedAst.hs:12:15-16 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:12:15-16 } + {Name: as}))))))))] (Prefix) - ({ DumpRenamedAst.hs:11:21-36 } + ({ DumpRenamedAst.hs:12:21-36 } (HsAppTy (NoExt) - ({ DumpRenamedAst.hs:11:21-24 } + ({ DumpRenamedAst.hs:12:21-24 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:11:21-24 } + ({ DumpRenamedAst.hs:12:21-24 } {Name: DumpRenamedAst.Succ}))) - ({ DumpRenamedAst.hs:11:26-36 } + ({ DumpRenamedAst.hs:12:26-36 } (HsParTy (NoExt) - ({ DumpRenamedAst.hs:11:27-35 } + ({ DumpRenamedAst.hs:12:27-35 } (HsAppTy (NoExt) - ({ DumpRenamedAst.hs:11:27-32 } + ({ DumpRenamedAst.hs:12:27-32 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:11:27-32 } + ({ DumpRenamedAst.hs:12:27-32 } {Name: DumpRenamedAst.Length}))) - ({ DumpRenamedAst.hs:11:34-35 } + ({ DumpRenamedAst.hs:12:34-35 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:11:34-35 } + ({ DumpRenamedAst.hs:12:34-35 } {Name: as})))))))))))) - ,({ DumpRenamedAst.hs:12:3-24 } + ,({ DumpRenamedAst.hs:13:3-24 } (HsIB [] (FamEqn (NoExt) - ({ DumpRenamedAst.hs:12:3-8 } + ({ DumpRenamedAst.hs:13:3-8 } {Name: DumpRenamedAst.Length}) (Nothing) - [({ DumpRenamedAst.hs:12:10-12 } - (HsExplicitListTy - (NoExt) - (IsPromoted) - []))] + [(HsValArg + ({ DumpRenamedAst.hs:13:10-12 } + (HsExplicitListTy + (NoExt) + (IsPromoted) + [])))] (Prefix) - ({ DumpRenamedAst.hs:12:21-24 } + ({ DumpRenamedAst.hs:13:21-24 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:12:21-24 } + ({ DumpRenamedAst.hs:13:21-24 } {Name: DumpRenamedAst.Zero}))))))])) - ({ DumpRenamedAst.hs:10:13-18 } + ({ DumpRenamedAst.hs:11:13-18 } {Name: DumpRenamedAst.Length}) (HsQTvs (HsQTvsRn [{Name: k}] {NameSet: []}) - [({ DumpRenamedAst.hs:10:21-29 } + [({ DumpRenamedAst.hs:11:21-29 } (KindedTyVar (NoExt) - ({ DumpRenamedAst.hs:10:21-22 } + ({ DumpRenamedAst.hs:11:21-22 } {Name: as}) - ({ DumpRenamedAst.hs:10:27-29 } + ({ DumpRenamedAst.hs:11:27-29 } (HsListTy (NoExt) - ({ DumpRenamedAst.hs:10:28 } + ({ DumpRenamedAst.hs:11:28 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:10:28 } + ({ DumpRenamedAst.hs:11:28 } {Name: k})))))))]) (Prefix) - ({ DumpRenamedAst.hs:10:32-39 } + ({ DumpRenamedAst.hs:11:32-39 } (KindSig (NoExt) - ({ DumpRenamedAst.hs:10:35-39 } + ({ DumpRenamedAst.hs:11:35-39 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:10:35-39 } + ({ DumpRenamedAst.hs:11:35-39 } {Name: DumpRenamedAst.Peano}))))) (Nothing))))] [] []) ,(TyClGroup (NoExt) - [({ DumpRenamedAst.hs:14:1-33 } + [({ DumpRenamedAst.hs:15:1-33 } (FamDecl (NoExt) (FamilyDecl (NoExt) (DataFamily) - ({ DumpRenamedAst.hs:14:13-15 } + ({ DumpRenamedAst.hs:15:13-15 } {Name: DumpRenamedAst.Nat}) (HsQTvs (HsQTvsRn @@ -251,36 +253,36 @@ []}) []) (Prefix) - ({ DumpRenamedAst.hs:14:17-33 } + ({ DumpRenamedAst.hs:15:17-33 } (KindSig (NoExt) - ({ DumpRenamedAst.hs:14:20-33 } + ({ DumpRenamedAst.hs:15:20-33 } (HsFunTy (NoExt) - ({ DumpRenamedAst.hs:14:20 } + ({ DumpRenamedAst.hs:15:20 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:14:20 } + ({ DumpRenamedAst.hs:15:20 } {Name: k}))) - ({ DumpRenamedAst.hs:14:25-33 } + ({ DumpRenamedAst.hs:15:25-33 } (HsFunTy (NoExt) - ({ DumpRenamedAst.hs:14:25 } + ({ DumpRenamedAst.hs:15:25 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:14:25 } + ({ DumpRenamedAst.hs:15:25 } {Name: k}))) - ({ DumpRenamedAst.hs:14:30-33 } + ({ DumpRenamedAst.hs:15:30-33 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:14:30-33 } + ({ DumpRenamedAst.hs:15:30-33 } {Name: GHC.Types.Type}))))))))) (Nothing))))] [] - [({ DumpRenamedAst.hs:(17,1)-(18,45) } + [({ DumpRenamedAst.hs:(18,1)-(19,45) } (DataFamInstD (NoExt) (DataFamInstDecl @@ -289,36 +291,37 @@ ,{Name: a}] (FamEqn (NoExt) - ({ DumpRenamedAst.hs:17:18-20 } + ({ DumpRenamedAst.hs:18:18-20 } {Name: DumpRenamedAst.Nat}) (Nothing) - [({ DumpRenamedAst.hs:17:22-37 } - (HsParTy - (NoExt) - ({ DumpRenamedAst.hs:17:23-36 } - (HsKindSig - (NoExt) - ({ DumpRenamedAst.hs:17:23 } - (HsTyVar - (NoExt) - (NotPromoted) - ({ DumpRenamedAst.hs:17:23 } - {Name: a}))) - ({ DumpRenamedAst.hs:17:28-36 } - (HsFunTy - (NoExt) - ({ DumpRenamedAst.hs:17:28 } - (HsTyVar - (NoExt) - (NotPromoted) - ({ DumpRenamedAst.hs:17:28 } - {Name: k}))) - ({ DumpRenamedAst.hs:17:33-36 } - (HsTyVar - (NoExt) - (NotPromoted) - ({ DumpRenamedAst.hs:17:33-36 } - {Name: GHC.Types.Type})))))))))] + [(HsValArg + ({ DumpRenamedAst.hs:18:22-37 } + (HsParTy + (NoExt) + ({ DumpRenamedAst.hs:18:23-36 } + (HsKindSig + (NoExt) + ({ DumpRenamedAst.hs:18:23 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:18:23 } + {Name: a}))) + ({ DumpRenamedAst.hs:18:28-36 } + (HsFunTy + (NoExt) + ({ DumpRenamedAst.hs:18:28 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:18:28 } + {Name: k}))) + ({ DumpRenamedAst.hs:18:33-36 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:18:33-36 } + {Name: GHC.Types.Type}))))))))))] (Prefix) (HsDataDefn (NoExt) @@ -327,39 +330,39 @@ []) (Nothing) (Just - ({ DumpRenamedAst.hs:17:42-60 } + ({ DumpRenamedAst.hs:18:42-60 } (HsFunTy (NoExt) - ({ DumpRenamedAst.hs:17:42-52 } + ({ DumpRenamedAst.hs:18:42-52 } (HsParTy (NoExt) - ({ DumpRenamedAst.hs:17:43-51 } + ({ DumpRenamedAst.hs:18:43-51 } (HsFunTy (NoExt) - ({ DumpRenamedAst.hs:17:43 } + ({ DumpRenamedAst.hs:18:43 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:17:43 } + ({ DumpRenamedAst.hs:18:43 } {Name: k}))) - ({ DumpRenamedAst.hs:17:48-51 } + ({ DumpRenamedAst.hs:18:48-51 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:17:48-51 } + ({ DumpRenamedAst.hs:18:48-51 } {Name: GHC.Types.Type}))))))) - ({ DumpRenamedAst.hs:17:57-60 } + ({ DumpRenamedAst.hs:18:57-60 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:17:57-60 } + ({ DumpRenamedAst.hs:18:57-60 } {Name: GHC.Types.Type})))))) - [({ DumpRenamedAst.hs:18:3-45 } + [({ DumpRenamedAst.hs:19:3-45 } (ConDeclGADT (NoExt) - [({ DumpRenamedAst.hs:18:3-5 } + [({ DumpRenamedAst.hs:19:3-5 } {Name: DumpRenamedAst.Nat})] - ({ DumpRenamedAst.hs:18:10-45 } + ({ DumpRenamedAst.hs:19:10-45 } (False)) (HsQTvs (HsQTvsRn @@ -370,77 +373,274 @@ []) (Nothing) (PrefixCon - [({ DumpRenamedAst.hs:18:10-34 } + [({ DumpRenamedAst.hs:19:10-34 } (HsParTy (NoExt) - ({ DumpRenamedAst.hs:18:11-33 } + ({ DumpRenamedAst.hs:19:11-33 } (HsForAllTy (NoExt) - [({ DumpRenamedAst.hs:18:18-19 } + [({ DumpRenamedAst.hs:19:18-19 } (UserTyVar (NoExt) - ({ DumpRenamedAst.hs:18:18-19 } + ({ DumpRenamedAst.hs:19:18-19 } {Name: xx})))] - ({ DumpRenamedAst.hs:18:22-33 } + ({ DumpRenamedAst.hs:19:22-33 } (HsFunTy (NoExt) - ({ DumpRenamedAst.hs:18:22-25 } + ({ DumpRenamedAst.hs:19:22-25 } (HsAppTy (NoExt) - ({ DumpRenamedAst.hs:18:22 } + ({ DumpRenamedAst.hs:19:22 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:18:22 } + ({ DumpRenamedAst.hs:19:22 } {Name: f}))) - ({ DumpRenamedAst.hs:18:24-25 } + ({ DumpRenamedAst.hs:19:24-25 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:18:24-25 } + ({ DumpRenamedAst.hs:19:24-25 } {Name: xx}))))) - ({ DumpRenamedAst.hs:18:30-33 } + ({ DumpRenamedAst.hs:19:30-33 } (HsAppTy (NoExt) - ({ DumpRenamedAst.hs:18:30 } + ({ DumpRenamedAst.hs:19:30 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:18:30 } + ({ DumpRenamedAst.hs:19:30 } {Name: g}))) - ({ DumpRenamedAst.hs:18:32-33 } + ({ DumpRenamedAst.hs:19:32-33 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:18:32-33 } + ({ DumpRenamedAst.hs:19:32-33 } {Name: xx})))))))))))]) - ({ DumpRenamedAst.hs:18:39-45 } + ({ DumpRenamedAst.hs:19:39-45 } (HsAppTy (NoExt) - ({ DumpRenamedAst.hs:18:39-43 } + ({ DumpRenamedAst.hs:19:39-43 } (HsAppTy (NoExt) - ({ DumpRenamedAst.hs:18:39-41 } + ({ DumpRenamedAst.hs:19:39-41 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:18:39-41 } + ({ DumpRenamedAst.hs:19:39-41 } {Name: DumpRenamedAst.Nat}))) - ({ DumpRenamedAst.hs:18:43 } + ({ DumpRenamedAst.hs:19:43 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:18:43 } + ({ DumpRenamedAst.hs:19:43 } {Name: f}))))) - ({ DumpRenamedAst.hs:18:45 } + ({ DumpRenamedAst.hs:19:45 } (HsTyVar (NoExt) (NotPromoted) - ({ DumpRenamedAst.hs:18:45 } + ({ DumpRenamedAst.hs:19:45 } {Name: g}))))) (Nothing)))] ({ <no location info> } - [])))))))])] + [])))))))]) + ,(TyClGroup + (NoExt) + [({ DumpRenamedAst.hs:21:1-29 } + (DataDecl + (DataDeclRn + (False) + {NameSet: + [{Name: a} + ,{Name: f}]}) + ({ DumpRenamedAst.hs:21:6 } + {Name: DumpRenamedAst.T}) + (HsQTvs + (HsQTvsRn + [{Name: k}] + {NameSet: + []}) + [({ DumpRenamedAst.hs:21:8 } + (UserTyVar + (NoExt) + ({ DumpRenamedAst.hs:21:8 } + {Name: f}))) + ,({ DumpRenamedAst.hs:21:11-16 } + (KindedTyVar + (NoExt) + ({ DumpRenamedAst.hs:21:11 } + {Name: a}) + ({ DumpRenamedAst.hs:21:16 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:21:16 } + {Name: k})))))]) + (Prefix) + (HsDataDefn + (NoExt) + (DataType) + ({ <no location info> } + []) + (Nothing) + (Nothing) + [({ DumpRenamedAst.hs:21:21-29 } + (ConDeclH98 + (NoExt) + ({ DumpRenamedAst.hs:21:21-23 } + {Name: DumpRenamedAst.MkT}) + ({ <no location info> } + (False)) + [] + (Nothing) + (PrefixCon + [({ DumpRenamedAst.hs:21:25-29 } + (HsParTy + (NoExt) + ({ DumpRenamedAst.hs:21:26-28 } + (HsAppTy + (NoExt) + ({ DumpRenamedAst.hs:21:26 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:21:26 } + {Name: f}))) + ({ DumpRenamedAst.hs:21:28 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:21:28 } + {Name: a})))))))]) + (Nothing)))] + ({ <no location info> } + []))))] + [] + []) + ,(TyClGroup + (NoExt) + [({ DumpRenamedAst.hs:23:1-48 } + (FamDecl + (NoExt) + (FamilyDecl + (NoExt) + (ClosedTypeFamily + (Just + [({ DumpRenamedAst.hs:24:3-30 } + (HsIB + [{Name: a} + ,{Name: f}] + (FamEqn + (NoExt) + ({ DumpRenamedAst.hs:24:3-4 } + {Name: DumpRenamedAst.F1}) + (Nothing) + [(HsTypeArg + ({ DumpRenamedAst.hs:24:7-11 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:24:7-11 } + {Name: DumpRenamedAst.Peano})))) + ,(HsValArg + ({ DumpRenamedAst.hs:24:13 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:24:13 } + {Name: a})))) + ,(HsValArg + ({ DumpRenamedAst.hs:24:15 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:24:15 } + {Name: f}))))] + (Prefix) + ({ DumpRenamedAst.hs:24:19-30 } + (HsAppTy + (NoExt) + ({ DumpRenamedAst.hs:24:19-28 } + (HsAppTy + (NoExt) + ({ DumpRenamedAst.hs:24:19-26 } + (HsAppKindTy + (NoExt) + ({ DumpRenamedAst.hs:24:19 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:24:19 } + {Name: DumpRenamedAst.T}))) + ({ DumpRenamedAst.hs:24:22-26 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:24:22-26 } + {Name: DumpRenamedAst.Peano}))))) + ({ DumpRenamedAst.hs:24:28 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:24:28 } + {Name: f}))))) + ({ DumpRenamedAst.hs:24:30 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:24:30 } + {Name: a}))))))))])) + ({ DumpRenamedAst.hs:23:13-14 } + {Name: DumpRenamedAst.F1}) + (HsQTvs + (HsQTvsRn + [{Name: k}] + {NameSet: + []}) + [({ DumpRenamedAst.hs:23:17-22 } + (KindedTyVar + (NoExt) + ({ DumpRenamedAst.hs:23:17 } + {Name: a}) + ({ DumpRenamedAst.hs:23:22 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:23:22 } + {Name: k}))))) + ,({ DumpRenamedAst.hs:23:26-39 } + (KindedTyVar + (NoExt) + ({ DumpRenamedAst.hs:23:26 } + {Name: f}) + ({ DumpRenamedAst.hs:23:31-39 } + (HsFunTy + (NoExt) + ({ DumpRenamedAst.hs:23:31 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:23:31 } + {Name: k}))) + ({ DumpRenamedAst.hs:23:36-39 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:23:36-39 } + {Name: GHC.Types.Type})))))))]) + (Prefix) + ({ DumpRenamedAst.hs:23:42-48 } + (KindSig + (NoExt) + ({ DumpRenamedAst.hs:23:45-48 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ DumpRenamedAst.hs:23:45-48 } + {Name: GHC.Types.Type}))))) + (Nothing))))] + [] + [])] [] [] [] @@ -462,11 +662,24 @@ (True) (Nothing) (Nothing))) - ,({ DumpRenamedAst.hs:6:1-23 } + ,({ DumpRenamedAst.hs:5:1-16 } + (ImportDecl + (NoExt) + (NoSourceText) + ({ DumpRenamedAst.hs:5:8-16 } + {ModuleName: Data.Kind}) + (Nothing) + (False) + (False) + (False) + (False) + (Nothing) + (Nothing))) + ,({ DumpRenamedAst.hs:7:1-23 } (ImportDecl (NoExt) (NoSourceText) - ({ DumpRenamedAst.hs:6:8-16 } + ({ DumpRenamedAst.hs:7:8-16 } {ModuleName: Data.Kind}) (Nothing) (False) @@ -477,13 +690,13 @@ (Just ((,) (False) - ({ DumpRenamedAst.hs:6:18-23 } - [({ DumpRenamedAst.hs:6:19-22 } + ({ DumpRenamedAst.hs:7:18-23 } + [({ DumpRenamedAst.hs:7:19-22 } (IEThingAbs (NoExt) - ({ DumpRenamedAst.hs:6:19-22 } + ({ DumpRenamedAst.hs:7:19-22 } (IEName - ({ DumpRenamedAst.hs:6:19-22 } + ({ DumpRenamedAst.hs:7:19-22 } {Name: GHC.Types.Type})))))])))))] (Nothing) (Nothing))) diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.hs b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.hs index 35887649a7..82cf107e5d 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.hs +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-} +{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies + , TypeApplications #-} module DumpTypecheckedAst where +import Data.Kind data Peano = Zero | Succ Peano @@ -8,4 +10,9 @@ type family Length (as :: [k]) :: Peano where Length (a : as) = Succ (Length as) Length '[] = Zero +data T f (a :: k) = MkT (f a) + +type family F (a :: k) (f :: k -> Type) :: Type where + F @Peano a f = T @Peano f a + main = putStrLn "hello" diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index 8e3e868fb9..7c6bfd72d0 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -5,6 +5,138 @@ [({ <no location info> } (VarBind (NoExt) + {Var: DumpTypecheckedAst.$tcT} + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsConLikeOut + (NoExt) + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (NoExt) + {HsWord{64}Prim (1374752024144278257) (NoSourceText)})))) + ({ <no location info> } + (HsLit + (NoExt) + {HsWord{64}Prim (13654949607623281177) (NoSourceText)})))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: DumpTypecheckedAst.$trModule}))))) + ({ <no location info> } + (HsPar + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsConLikeOut + (NoExt) + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (NoExt) + (HsStringPrim + (NoSourceText) + "T"))))))))) + ({ <no location info> } + (HsLit + (NoExt) + {HsInt{64}Prim (1) (SourceText + "1")})))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: $krep}))))) + (False))) + ,({ <no location info> } + (VarBind + (NoExt) + {Var: DumpTypecheckedAst.$tc'MkT} + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsConLikeOut + (NoExt) + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (NoExt) + {HsWord{64}Prim (10715337633704422415) (NoSourceText)})))) + ({ <no location info> } + (HsLit + (NoExt) + {HsWord{64}Prim (12411373583424111944) (NoSourceText)})))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: DumpTypecheckedAst.$trModule}))))) + ({ <no location info> } + (HsPar + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsConLikeOut + (NoExt) + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (NoExt) + (HsStringPrim + (NoSourceText) + "'MkT"))))))))) + ({ <no location info> } + (HsLit + (NoExt) + {HsInt{64}Prim (3) (SourceText + "3")})))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: $krep}))))) + (False))) + ,({ <no location info> } + (VarBind + (NoExt) {Var: DumpTypecheckedAst.$tcPeano} ({ <no location info> } (HsApp @@ -208,6 +340,147 @@ (HsApp (NoExt) ({ <no location info> } + (HsConLikeOut + (NoExt) + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (NoExt) + (HsInt + (NoExt) + (IL + (SourceText + "2") + (False) + (2))))))) + (False))) + ,({ <no location info> } + (VarBind + (NoExt) + {Var: $krep} + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsConLikeOut + (NoExt) + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (NoExt) + (HsInt + (NoExt) + (IL + (SourceText + "1") + (False) + (1))))))) + (False))) + ,({ <no location info> } + (VarBind + (NoExt) + {Var: $krep} + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsConLikeOut + (NoExt) + ({abstract:ConLike}))) + ({ <no location info> } + (HsLit + (NoExt) + (HsInt + (NoExt) + (IL + (SourceText + "0") + (False) + (0))))))) + (False))) + ,({ <no location info> } + (VarBind + (NoExt) + {Var: $krep} + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsConLikeOut + (NoExt) + ({abstract:ConLike}))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: $krep}))))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: $krep}))))) + (False))) + ,({ <no location info> } + (VarBind + (NoExt) + {Var: $krep} + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsConLikeOut + (NoExt) + ({abstract:ConLike}))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: $krep}))))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: GHC.Types.krep$*}))))) + (False))) + ,({ <no location info> } + (VarBind + (NoExt) + {Var: $krep} + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsConLikeOut + (NoExt) + ({abstract:ConLike}))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: $krep}))))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: $krep}))))) + (False))) + ,({ <no location info> } + (VarBind + (NoExt) + {Var: $krep} + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } (HsApp (NoExt) ({ <no location info> } @@ -243,6 +516,133 @@ (HsVar (NoExt) ({ <no location info> } + {Var: $krep}))))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: $krep}))))) + (False))) + ,({ <no location info> } + (VarBind + (NoExt) + {Var: $krep} + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsConLikeOut + (NoExt) + ({abstract:ConLike}))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: DumpTypecheckedAst.$tcT}))))) + ({ <no location info> } + (HsPar + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsWrap + (NoExt) + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExt) + ({abstract:ConLike})))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: $krep}))))) + ({ <no location info> } + (HsPar + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsWrap + (NoExt) + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExt) + ({abstract:ConLike})))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: $krep}))))) + ({ <no location info> } + (HsPar + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsWrap + (NoExt) + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExt) + ({abstract:ConLike})))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } + {Var: $krep}))))) + ({ <no location info> } + (HsWrap + (NoExt) + (WpTyApp + (TyConApp + ({abstract:TyCon}) + [])) + (HsConLikeOut + (NoExt) + ({abstract:ConLike})))))))))))))))))) + (False))) + ,({ <no location info> } + (VarBind + (NoExt) + {Var: $krep} + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsApp + (NoExt) + ({ <no location info> } + (HsConLikeOut + (NoExt) + ({abstract:ConLike}))) + ({ <no location info> } + (HsVar + (NoExt) + ({ <no location info> } {Var: DumpTypecheckedAst.$tcPeano}))))) ({ <no location info> } (HsWrap @@ -302,7 +702,7 @@ (NoSourceText) "DumpTypecheckedAst"))))))))) (False))) - ,({ DumpTypecheckedAst.hs:11:1-23 } + ,({ DumpTypecheckedAst.hs:18:1-23 } (AbsBinds (NoExt) [] @@ -316,11 +716,11 @@ []))] [({abstract:TcEvBinds})] {Bag(Located (HsBind Var)): - [({ DumpTypecheckedAst.hs:11:1-23 } + [({ DumpTypecheckedAst.hs:18:1-23 } (FunBind {NameSet: []} - ({ DumpTypecheckedAst.hs:11:1-4 } + ({ DumpTypecheckedAst.hs:18:1-4 } {Var: main}) (MG (MatchGroupTc @@ -330,31 +730,31 @@ [(TyConApp ({abstract:TyCon}) [])])) - ({ DumpTypecheckedAst.hs:11:1-23 } - [({ DumpTypecheckedAst.hs:11:1-23 } + ({ DumpTypecheckedAst.hs:18:1-23 } + [({ DumpTypecheckedAst.hs:18:1-23 } (Match (NoExt) (FunRhs - ({ DumpTypecheckedAst.hs:11:1-4 } + ({ DumpTypecheckedAst.hs:18:1-4 } {Name: main}) (Prefix) (NoSrcStrict)) [] (GRHSs (NoExt) - [({ DumpTypecheckedAst.hs:11:6-23 } + [({ DumpTypecheckedAst.hs:18:6-23 } (GRHS (NoExt) [] - ({ DumpTypecheckedAst.hs:11:8-23 } + ({ DumpTypecheckedAst.hs:18:8-23 } (HsApp (NoExt) - ({ DumpTypecheckedAst.hs:11:8-15 } + ({ DumpTypecheckedAst.hs:18:8-15 } (HsVar (NoExt) ({ <no location info> } {Var: putStrLn}))) - ({ DumpTypecheckedAst.hs:11:17-23 } + ({ DumpTypecheckedAst.hs:18:17-23 } (HsLit (NoExt) (HsString diff --git a/testsuite/tests/parser/should_compile/KindSigs.stderr b/testsuite/tests/parser/should_compile/KindSigs.stderr index 125e88084a..8ea6ec5322 100644 --- a/testsuite/tests/parser/should_compile/KindSigs.stderr +++ b/testsuite/tests/parser/should_compile/KindSigs.stderr @@ -38,13 +38,14 @@ (Unqual {OccName: Foo})) (Nothing) - [({ KindSigs.hs:12:7 } - (HsTyVar - (NoExt) - (NotPromoted) - ({ KindSigs.hs:12:7 } - (Unqual - {OccName: a}))))] + [(HsValArg + ({ KindSigs.hs:12:7 } + (HsTyVar + (NoExt) + (NotPromoted) + ({ KindSigs.hs:12:7 } + (Unqual + {OccName: a})))))] (Prefix) ({ KindSigs.hs:12:11-21 } (HsKindSig diff --git a/testsuite/tests/parser/should_compile/T12045e.hs b/testsuite/tests/parser/should_compile/T12045e.hs new file mode 100644 index 0000000000..1be903adfb --- /dev/null +++ b/testsuite/tests/parser/should_compile/T12045e.hs @@ -0,0 +1,13 @@ +{-# Language DataKinds #-} +{-# Language TypeApplications #-} +{-# Language PolyKinds #-} + +module T12045e where + +import Data.Kind + +data Nat = Zero | Succ Nat +data T (n :: k) = MkT +data D1 n = T @Nat n :! () +data D2 n = () :!! T @Nat n +data D3 n = T @Nat n :!!! T @Nat n diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T index a85b09cbb7..b3f693d783 100644 --- a/testsuite/tests/parser/should_compile/all.T +++ b/testsuite/tests/parser/should_compile/all.T @@ -113,6 +113,7 @@ test('T11622', normal, compile, ['']) test('DumpParsedAst', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast']) test('DumpRenamedAst', normal, compile, ['-dsuppress-uniques -ddump-rn-ast']) test('DumpTypecheckedAst', normal, compile, ['-dsuppress-uniques -ddump-tc-ast']) +test('T12045e', normal, compile, ['']) test('T13087', normal, compile, ['']) test('T13747', normal, compile, ['']) test('T14189', normal, compile, ['-dsuppress-uniques -ddump-rn-ast']) diff --git a/testsuite/tests/parser/should_fail/T12045d.hs b/testsuite/tests/parser/should_fail/T12045d.hs new file mode 100644 index 0000000000..3c4b2a6c10 --- /dev/null +++ b/testsuite/tests/parser/should_fail/T12045d.hs @@ -0,0 +1,11 @@ +{-# Language DataKinds #-} +{-# Language TypeApplications #-} +{-# Language PolyKinds #-} + +module Bug where + +import Data.Kind + +data Nat = Zero | Succ Nat + +data D n = MkD @Nat Bool diff --git a/testsuite/tests/parser/should_fail/T12045d.stderr b/testsuite/tests/parser/should_fail/T12045d.stderr new file mode 100644 index 0000000000..128cf58d86 --- /dev/null +++ b/testsuite/tests/parser/should_fail/T12045d.stderr @@ -0,0 +1,4 @@ + +T12045d.hs:11:16: error: + Unexpected kind application in a data/newtype declaration: + MkD @Nat Bool diff --git a/testsuite/tests/parser/should_fail/all.T b/testsuite/tests/parser/should_fail/all.T index f1f5122c5a..2d7c241ed0 100644 --- a/testsuite/tests/parser/should_fail/all.T +++ b/testsuite/tests/parser/should_fail/all.T @@ -110,6 +110,7 @@ test('T13414', literate, compile_fail, ['']) test('T8501a', normal, compile_fail, ['']) test('T8501b', normal, compile_fail, ['']) test('T8501c', normal, compile_fail, ['']) +test('T12045d', normal, compile_fail, ['']) test('T12610', normal, compile_fail, ['']) test('T13450', normal, compile_fail, ['']) test('T13450TH', normal, compile_fail, ['']) diff --git a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr index 008a1fc5c5..beb850c5fe 100644 --- a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr +++ b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROff.stderr @@ -1,5 +1,5 @@ TYPE SIGNATURES - bravo :: forall w. Num w => w + bravo :: forall _. Num _ => _ Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr index 008a1fc5c5..beb850c5fe 100644 --- a/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr +++ b/testsuite/tests/partial-sigs/should_compile/Defaulting2MROn.stderr @@ -1,5 +1,5 @@ TYPE SIGNATURES - bravo :: forall w. Num w => w + bravo :: forall _. Num _ => _ Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/partial-sigs/should_compile/Either.stderr b/testsuite/tests/partial-sigs/should_compile/Either.stderr index 86fe4a03b4..9769909910 100644 --- a/testsuite/tests/partial-sigs/should_compile/Either.stderr +++ b/testsuite/tests/partial-sigs/should_compile/Either.stderr @@ -1,5 +1,5 @@ TYPE SIGNATURES - barry :: forall w. w -> (Either [Char] w, Either [Char] w) + barry :: forall _. _ -> (Either [Char] _, Either [Char] _) Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr b/testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr index e6f8a9042c..59e2054c8c 100644 --- a/testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr +++ b/testsuite/tests/partial-sigs/should_compile/EveryNamed.stderr @@ -1,5 +1,5 @@ TYPE SIGNATURES - every :: forall w. (w -> Bool) -> [w] -> Bool + every :: forall _. (_ -> Bool) -> [_] -> Bool Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/partial-sigs/should_compile/ExprSigLocal.stderr b/testsuite/tests/partial-sigs/should_compile/ExprSigLocal.stderr index cfe5aeb6d0..a6dbd5a143 100644 --- a/testsuite/tests/partial-sigs/should_compile/ExprSigLocal.stderr +++ b/testsuite/tests/partial-sigs/should_compile/ExprSigLocal.stderr @@ -4,14 +4,16 @@ ExprSigLocal.hs:9:35: warning: [-Wpartial-type-signatures (in -Wdefault)] Where: ‘a’ is a rigid type variable bound by the inferred type of <expression> :: a -> a at ExprSigLocal.hs:9:20-35 - • In an expression type signature: forall a. a -> _ + • In the type ‘a -> _’ + In an expression type signature: forall a. a -> _ In the expression: ((\ x -> x) :: forall a. a -> _) - In an equation for ‘y’: y = ((\ x -> x) :: forall a. a -> _) • Relevant bindings include y :: b -> b (bound at ExprSigLocal.hs:9:1) ExprSigLocal.hs:11:21: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘a’ Where: ‘a’ is a rigid type variable bound by - the inferred type of g :: a -> a at ExprSigLocal.hs:12:1-7 - • In the type signature: g :: forall a. a -> _ + the inferred type of g :: a -> a + at ExprSigLocal.hs:12:1-7 + • In the type ‘a -> _’ + In the type signature: g :: forall a. a -> _ diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr index c49b1a025b..8bd167fdb7 100644 --- a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr +++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr @@ -125,12 +125,12 @@ TYPE SIGNATURES (P.Foldable t, Monad m) => (a -> m b) -> t a -> m () max :: forall a. Ord a => a -> a -> a - maxBound :: forall w. Bounded w => w + maxBound :: forall _. Bounded _ => _ maximum :: forall (t :: * -> *) a. (P.Foldable t, Ord a) => t a -> a maybe :: forall b a. b -> (a -> b) -> Maybe a -> b min :: forall a. Ord a => a -> a -> a - minBound :: forall w. Bounded w => w + minBound :: forall _. Bounded _ => _ minimum :: forall (t :: * -> *) a. (P.Foldable t, Ord a) => t a -> a mod :: forall a. Integral a => a -> a -> a @@ -142,7 +142,7 @@ TYPE SIGNATURES odd :: forall a. Integral a => a -> Bool or :: forall (t :: * -> *). P.Foldable t => t Bool -> Bool otherwise :: Bool - pi :: forall w. Floating w => w + pi :: forall _. Floating _ => _ pred :: forall a. Enum a => a -> a print :: forall a. Show a => a -> IO () product :: @@ -212,7 +212,7 @@ TYPE SIGNATURES toRational :: forall a. Real a => a -> Rational truncate :: forall a b. (RealFrac a, Integral b) => a -> b uncurry :: forall a b c. (a -> b -> c) -> (a, b) -> c - undefined :: forall w. w + undefined :: forall _. _ unlines :: [String] -> String until :: forall a. (a -> Bool) -> (a -> a) -> a -> a unwords :: [String] -> String diff --git a/testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr b/testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr index bae5060aab..9d10860ff9 100644 --- a/testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SimpleGen.stderr @@ -1,5 +1,5 @@ TYPE SIGNATURES - bar :: forall w. w -> Bool + bar :: forall _. _ -> Bool Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr index ea974895e2..88fc8d50b9 100644 --- a/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SplicesUsed.stderr @@ -3,12 +3,13 @@ SplicesUsed.hs:7:16: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Maybe Bool’ - • In the type signature: maybeBool :: (_) + • In the type ‘_’ + In the type signature: maybeBool :: (_) SplicesUsed.hs:8:15: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_a’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of <expression> :: w -> w + • Found type wildcard ‘_a’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of <expression> :: _ -> _ at SplicesUsed.hs:8:15-22 • In an expression type signature: _a -> _a In the expression: id :: _a -> _a @@ -18,10 +19,9 @@ SplicesUsed.hs:8:15: warning: [-Wpartial-type-signatures (in -Wdefault)] SplicesUsed.hs:8:27: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Bool’ - • In an expression type signature: Maybe _ - In the first argument of ‘id :: _a -> _a’, namely - ‘(Just True :: Maybe _)’ - In the expression: (id :: _a -> _a) (Just True :: Maybe _) + • In the first argument of ‘Maybe’, namely ‘_’ + In the type ‘Maybe _’ + In an expression type signature: Maybe _ • Relevant bindings include maybeBool :: Maybe Bool (bound at SplicesUsed.hs:8:1) @@ -30,28 +30,32 @@ SplicesUsed.hs:10:17: warning: [-Wpartial-type-signatures (in -Wdefault)] Where: ‘a’ is a rigid type variable bound by the inferred type of charA :: a -> (Char, a) at SplicesUsed.hs:11:1-18 - • In the type signature: charA :: a -> (_) + • In the type ‘a -> (_)’ + In the type signature: charA :: a -> (_) SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘a -> Bool’ Where: ‘a’ is a rigid type variable bound by the inferred type of filter' :: (a -> Bool) -> [a] -> [a] at SplicesUsed.hs:14:1-16 - • In the type signature: filter' :: (_ -> _ -> _) + • In the type ‘_ -> _ -> _’ + In the type signature: filter' :: (_ -> _ -> _) SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘[a]’ Where: ‘a’ is a rigid type variable bound by the inferred type of filter' :: (a -> Bool) -> [a] -> [a] at SplicesUsed.hs:14:1-16 - • In the type signature: filter' :: (_ -> _ -> _) + • In the type ‘_ -> _ -> _’ + In the type signature: filter' :: (_ -> _ -> _) SplicesUsed.hs:13:14: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘[a]’ Where: ‘a’ is a rigid type variable bound by the inferred type of filter' :: (a -> Bool) -> [a] -> [a] at SplicesUsed.hs:14:1-16 - • In the type signature: filter' :: (_ -> _ -> _) + • In the type ‘_ -> _ -> _’ + In the type signature: filter' :: (_ -> _ -> _) SplicesUsed.hs:16:3: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Eq a’ @@ -72,8 +76,8 @@ SplicesUsed.hs:18:3: warning: [-Wpartial-type-signatures (in -Wdefault)] • In the type signature: bar :: _a -> _b -> (_a, _b) SplicesUsed.hs:18:3: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_b’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of bar :: Bool -> w -> (Bool, w) + • Found type wildcard ‘_b’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of bar :: Bool -> _ -> (Bool, _) at SplicesUsed.hs:18:3-10 • In the type signature: bar :: _a -> _b -> (_a, _b) diff --git a/testsuite/tests/partial-sigs/should_compile/SuperCls.stderr b/testsuite/tests/partial-sigs/should_compile/SuperCls.stderr index a11164482c..a24928a70b 100644 --- a/testsuite/tests/partial-sigs/should_compile/SuperCls.stderr +++ b/testsuite/tests/partial-sigs/should_compile/SuperCls.stderr @@ -1,4 +1,4 @@ -SuperCls.hs:4:14: warning: [-Wpartial-type-signatures (in -Wdefault)] +SuperCls.hs:4:6: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘()’ • In the type signature: f :: (Ord a, _) => a -> Bool diff --git a/testsuite/tests/partial-sigs/should_compile/T10403.stderr b/testsuite/tests/partial-sigs/should_compile/T10403.stderr index 229b9e1df1..870a72ed5a 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10403.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10403.stderr @@ -1,25 +1,23 @@ T10403.hs:15:7: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Functor f’ - Where: ‘f’ is a rigid type variable - bound by the inferred type of - h1 :: Functor f => (a -> b) -> f a -> H f + Where: ‘f’ is a rigid type variable bound by + the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f at T10403.hs:17:1-41 • In the type signature: h1 :: _ => _ T10403.hs:15:12: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘(a -> b) -> f a -> H f’ - Where: ‘b’, ‘a’, ‘f’ are rigid type variables - bound by the inferred type of - h1 :: Functor f => (a -> b) -> f a -> H f + Where: ‘b’, ‘a’, ‘f’ are rigid type variables bound by + the inferred type of h1 :: Functor f => (a -> b) -> f a -> H f at T10403.hs:17:1-41 • In the type signature: h1 :: _ => _ T10403.hs:19:7: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘(a -> b) -> f0 a -> H f0’ Where: ‘f0’ is an ambiguous type variable - ‘b’, ‘a’ are rigid type variables - bound by the inferred type of h2 :: (a -> b) -> f0 a -> H f0 + ‘b’, ‘a’ are rigid type variables bound by + the inferred type of h2 :: (a -> b) -> f0 a -> H f0 at T10403.hs:22:1-41 • In the type signature: h2 :: _ diff --git a/testsuite/tests/partial-sigs/should_compile/T10438.stderr b/testsuite/tests/partial-sigs/should_compile/T10438.stderr index 5acc3fa15b..164007679c 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10438.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10438.stderr @@ -2,7 +2,8 @@ T10438.hs:7:22: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘p2’ Where: ‘p2’ is a rigid type variable bound by - the inferred type of g :: p2 -> p2 at T10438.hs:(6,9)-(8,21) + the inferred type of g :: p2 -> p2 + at T10438.hs:(6,9)-(8,21) • In the type signature: x :: _ In an equation for ‘g’: g r diff --git a/testsuite/tests/partial-sigs/should_compile/T10519.stderr b/testsuite/tests/partial-sigs/should_compile/T10519.stderr index f57144dcd1..31d525cda0 100644 --- a/testsuite/tests/partial-sigs/should_compile/T10519.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T10519.stderr @@ -1,5 +1,5 @@ -T10519.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)] +T10519.hs:5:8: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Eq a’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: Eq a => a -> a -> Bool diff --git a/testsuite/tests/partial-sigs/should_compile/T11016.stderr b/testsuite/tests/partial-sigs/should_compile/T11016.stderr index 49363fb24c..01e8b1ae4b 100644 --- a/testsuite/tests/partial-sigs/should_compile/T11016.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T11016.stderr @@ -1,5 +1,5 @@ -T11016.hs:5:19: warning: [-Wpartial-type-signatures (in -Wdefault)] +T11016.hs:5:7: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘()’ • In the type signature: f1 :: (?x :: Int, _) => Int diff --git a/testsuite/tests/partial-sigs/should_compile/T11339a.stderr b/testsuite/tests/partial-sigs/should_compile/T11339a.stderr index af8d47d4b6..c5c5e6f312 100644 --- a/testsuite/tests/partial-sigs/should_compile/T11339a.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T11339a.stderr @@ -2,5 +2,6 @@ T11339a.hs:5:8: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘a -> a’ Where: ‘a’ is a rigid type variable bound by - the inferred type of bar :: a -> a at T11339a.hs:6:1-10 + the inferred type of bar :: a -> a + at T11339a.hs:6:1-10 • In the type signature: bar :: _ diff --git a/testsuite/tests/partial-sigs/should_compile/T11670.stderr b/testsuite/tests/partial-sigs/should_compile/T11670.stderr index 04d6af5450..1a0e7df6ef 100644 --- a/testsuite/tests/partial-sigs/should_compile/T11670.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T11670.stderr @@ -1,18 +1,17 @@ T11670.hs:10:42: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘CLong’ - • In an expression type signature: IO _ - In the expression: peekElemOff undefined 0 :: IO _ - In an equation for ‘T11670.peek’: - T11670.peek ptr = peekElemOff undefined 0 :: IO _ + • In the first argument of ‘IO’, namely ‘_’ + In the type ‘IO _’ + In an expression type signature: IO _ • Relevant bindings include ptr :: Ptr a (bound at T11670.hs:10:6) peek :: Ptr a -> IO CLong (bound at T11670.hs:10:1) T11670.hs:13:40: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Storable w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of <expression> :: Storable w => IO w + • Found type wildcard ‘_’ standing for ‘Storable _’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of <expression> :: Storable _ => IO _ at T11670.hs:13:40-48 • In an expression type signature: _ => IO _ In the expression: peekElemOff undefined 0 :: _ => IO _ @@ -23,14 +22,13 @@ T11670.hs:13:40: warning: [-Wpartial-type-signatures (in -Wdefault)] peek2 :: Ptr a -> IO CLong (bound at T11670.hs:13:1) T11670.hs:13:48: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of <expression> :: Storable w => IO w + • Found type wildcard ‘_’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of <expression> :: Storable _ => IO _ at T11670.hs:13:40-48 - • In an expression type signature: _ => IO _ - In the expression: peekElemOff undefined 0 :: _ => IO _ - In an equation for ‘peek2’: - peek2 ptr = peekElemOff undefined 0 :: _ => IO _ + • In the first argument of ‘IO’, namely ‘_’ + In the type ‘IO _’ + In an expression type signature: _ => IO _ • Relevant bindings include ptr :: Ptr a (bound at T11670.hs:13:7) peek2 :: Ptr a -> IO CLong (bound at T11670.hs:13:1) diff --git a/testsuite/tests/partial-sigs/should_compile/T12844.stderr b/testsuite/tests/partial-sigs/should_compile/T12844.stderr index 0e01cd30f3..b8cdba7968 100644 --- a/testsuite/tests/partial-sigs/should_compile/T12844.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T12844.stderr @@ -1,5 +1,5 @@ -T12844.hs:12:9: warning: [-Wpartial-type-signatures (in -Wdefault)] +T12844.hs:12:8: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘(Foo rngs, Head rngs ~ '(r, r'))’ Where: ‘rngs’, ‘k’, ‘r’, ‘k1’, ‘r'’ diff --git a/testsuite/tests/partial-sigs/should_compile/T12845.stderr b/testsuite/tests/partial-sigs/should_compile/T12845.stderr index a483c84231..0c01a80fc0 100644 --- a/testsuite/tests/partial-sigs/should_compile/T12845.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T12845.stderr @@ -1,5 +1,5 @@ -T12845.hs:18:70: warning: [-Wpartial-type-signatures (in -Wdefault)] +T12845.hs:18:11: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘()’ • In the type signature: broken :: forall r r' rngs. diff --git a/testsuite/tests/partial-sigs/should_compile/T13482.stderr b/testsuite/tests/partial-sigs/should_compile/T13482.stderr index a21b7dcac4..017cc1535c 100644 --- a/testsuite/tests/partial-sigs/should_compile/T13482.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T13482.stderr @@ -1,5 +1,5 @@ -T13482.hs:10:32: warning: [-Wpartial-type-signatures (in -Wdefault)] +T13482.hs:10:20: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘(Eq m, Monoid m)’ Where: ‘m’ is a rigid type variable bound by the inferred type of @@ -8,21 +8,21 @@ T13482.hs:10:32: warning: [-Wpartial-type-signatures (in -Wdefault)] • In the type signature: minimal1_noksig :: forall m. _ => Int -> Bool -T13482.hs:13:33: warning: [-Wpartial-type-signatures (in -Wdefault)] +T13482.hs:13:13: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘(Eq m, Monoid m)’ Where: ‘m’ is a rigid type variable bound by the inferred type of minimal1 :: (Eq m, Monoid m) => Bool at T13482.hs:14:1-41 • In the type signature: minimal1 :: forall (m :: Type). _ => Bool -T13482.hs:16:30: warning: [-Wpartial-type-signatures (in -Wdefault)] +T13482.hs:16:13: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Monoid m’ Where: ‘m’ is a rigid type variable bound by the inferred type of minimal2 :: (Eq m, Monoid m) => Bool at T13482.hs:17:1-41 • In the type signature: minimal2 :: forall m. (Eq m, _) => Bool -T13482.hs:19:34: warning: [-Wpartial-type-signatures (in -Wdefault)] +T13482.hs:19:13: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Eq m’ Where: ‘m’ is a rigid type variable bound by the inferred type of minimal3 :: (Monoid m, Eq m) => Bool diff --git a/testsuite/tests/partial-sigs/should_compile/T14217.stderr b/testsuite/tests/partial-sigs/should_compile/T14217.stderr index ebecbb9d5c..e4b9598d9e 100644 --- a/testsuite/tests/partial-sigs/should_compile/T14217.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T14217.stderr @@ -1,5 +1,5 @@ -T14217.hs:32:11: error: +T14217.hs:32:10: error: • Found type wildcard ‘_’ standing for ‘(Eq a1, Eq a2, Eq a3, Eq a4, Eq a5, Eq a6, Eq a7, Eq a8, Eq a9, Eq a10, Eq a11, Eq a12, Eq a13, Eq a14, Eq a15, diff --git a/testsuite/tests/partial-sigs/should_compile/T14643.stderr b/testsuite/tests/partial-sigs/should_compile/T14643.stderr index c5f204e799..5f1762743a 100644 --- a/testsuite/tests/partial-sigs/should_compile/T14643.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T14643.stderr @@ -1,8 +1,8 @@ -T14643.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)] +T14643.hs:5:11: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘()’ • In the type signature: af :: (Num a, _) => a -> a -T14643.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)] +T14643.hs:5:11: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘()’ • In the type signature: ag :: (Num a, _) => a -> a diff --git a/testsuite/tests/partial-sigs/should_compile/T14643a.stderr b/testsuite/tests/partial-sigs/should_compile/T14643a.stderr index 1514ac92ed..11eab72ebb 100644 --- a/testsuite/tests/partial-sigs/should_compile/T14643a.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T14643a.stderr @@ -1,8 +1,8 @@ -T14643a.hs:5:14: warning: [-Wpartial-type-signatures (in -Wdefault)] +T14643a.hs:5:7: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘()’ • In the type signature: af :: (Num a, _) => a -> a -T14643a.hs:8:14: warning: [-Wpartial-type-signatures (in -Wdefault)] +T14643a.hs:8:7: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘()’ • In the type signature: ag :: (Num a, _) => a -> a diff --git a/testsuite/tests/partial-sigs/should_compile/T14715.stderr b/testsuite/tests/partial-sigs/should_compile/T14715.stderr index c846b47dd2..b34c4a5b72 100644 --- a/testsuite/tests/partial-sigs/should_compile/T14715.stderr +++ b/testsuite/tests/partial-sigs/should_compile/T14715.stderr @@ -1,10 +1,11 @@ -T14715.hs:13:53: warning: [-Wpartial-type-signatures (in -Wdefault)] - Found type wildcard ‘_’ standing for ‘Reduce (LiftOf zq) zq’ - Where: ‘zq’ is a rigid type variable bound by - the inferred type of - bench_mulPublic :: (z ~ LiftOf zq, Reduce (LiftOf zq) zq) => - Cyc zp -> Cyc z -> IO (zp, zq) - at T14715.hs:(14,1)-(16,14) - In the type signature: - bench_mulPublic :: forall z zp zq. - (z ~ LiftOf zq, _) => Cyc zp -> Cyc z -> IO (zp, zq) + +T14715.hs:13:20: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘Reduce (LiftOf zq) zq’ + Where: ‘zq’ is a rigid type variable bound by + the inferred type of + bench_mulPublic :: (z ~ LiftOf zq, Reduce (LiftOf zq) zq) => + Cyc zp -> Cyc z -> IO (zp, zq) + at T14715.hs:(14,1)-(16,14) + • In the type signature: + bench_mulPublic :: forall z zp zq. + (z ~ LiftOf zq, _) => Cyc zp -> Cyc z -> IO (zp, zq) diff --git a/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr b/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr index a132b725e8..49ecb6c911 100644 --- a/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr +++ b/testsuite/tests/partial-sigs/should_compile/TypedSplice.stderr @@ -1,9 +1,9 @@ TypedSplice.hs:9:22: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Bool’ - • In an expression type signature: _ -> _b + • In the type ‘_ -> _b’ + In an expression type signature: _ -> _b In the Template Haskell quotation [|| not :: _ -> _b ||] - In the expression: [|| not :: _ -> _b ||] • Relevant bindings include metaExp :: Q (TExp (Bool -> Bool)) (bound at TypedSplice.hs:9:1) diff --git a/testsuite/tests/partial-sigs/should_compile/Uncurry.stderr b/testsuite/tests/partial-sigs/should_compile/Uncurry.stderr index b9816b9339..e9931d23dd 100644 --- a/testsuite/tests/partial-sigs/should_compile/Uncurry.stderr +++ b/testsuite/tests/partial-sigs/should_compile/Uncurry.stderr @@ -1,5 +1,5 @@ TYPE SIGNATURES - unc :: forall w1 w2 w3. (w1 -> w2 -> w3) -> (w1, w2) -> w3 + unc :: forall _1 _2 _3. (_1 -> _2 -> _3) -> (_1, _2) -> _3 Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr b/testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr index f04dfbb0e9..666fb23620 100644 --- a/testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr +++ b/testsuite/tests/partial-sigs/should_compile/UncurryNamed.stderr @@ -1,5 +1,5 @@ TYPE SIGNATURES - unc :: forall a b w. (a -> b -> w) -> (a, b) -> w + unc :: forall a b _. (a -> b -> _) -> (a, b) -> _ Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] diff --git a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr index 2c891dc69d..cef1dedf6d 100644 --- a/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr +++ b/testsuite/tests/partial-sigs/should_compile/WarningWildcardInstantiations.stderr @@ -1,19 +1,19 @@ TYPE SIGNATURES - bar :: forall t w. t -> (t -> w) -> w + bar :: forall t _. t -> (t -> _) -> _ foo :: forall a. (Show a, Enum a) => a -> String Dependent modules: [] Dependent packages: [base-4.12.0.0, ghc-prim-0.5.3, integer-gmp-1.0.2.0] -WarningWildcardInstantiations.hs:5:14: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_a’ standing for ‘a’ +WarningWildcardInstantiations.hs:5:8: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_’ standing for ‘Enum a’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: (Show a, Enum a) => a -> String at WarningWildcardInstantiations.hs:6:1-21 • In the type signature: foo :: (Show _a, _) => _a -> _ -WarningWildcardInstantiations.hs:5:18: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘Enum a’ +WarningWildcardInstantiations.hs:5:14: warning: [-Wpartial-type-signatures (in -Wdefault)] + • Found type wildcard ‘_a’ standing for ‘a’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: (Show a, Enum a) => a -> String at WarningWildcardInstantiations.hs:6:1-21 @@ -21,25 +21,29 @@ WarningWildcardInstantiations.hs:5:18: warning: [-Wpartial-type-signatures (in - WarningWildcardInstantiations.hs:5:30: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘String’ - • In the type signature: foo :: (Show _a, _) => _a -> _ + • In the type ‘_a -> _’ + In the type signature: foo :: (Show _a, _) => _a -> _ WarningWildcardInstantiations.hs:8:8: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘t’ Where: ‘t’ is a rigid type variable bound by - the inferred type of bar :: t -> (t -> w) -> w + the inferred type of bar :: t -> (t -> _) -> _ at WarningWildcardInstantiations.hs:9:1-13 - • In the type signature: bar :: _ -> _ -> _ + • In the type ‘_ -> _ -> _’ + In the type signature: bar :: _ -> _ -> _ WarningWildcardInstantiations.hs:8:13: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘t -> w’ - Where: ‘t’, ‘w’ are rigid type variables bound by - the inferred type of bar :: t -> (t -> w) -> w + • Found type wildcard ‘_’ standing for ‘t -> _’ + Where: ‘t’, ‘_’ are rigid type variables bound by + the inferred type of bar :: t -> (t -> _) -> _ at WarningWildcardInstantiations.hs:9:1-13 - • In the type signature: bar :: _ -> _ -> _ + • In the type ‘_ -> _ -> _’ + In the type signature: bar :: _ -> _ -> _ WarningWildcardInstantiations.hs:8:18: warning: [-Wpartial-type-signatures (in -Wdefault)] - • Found type wildcard ‘_’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of bar :: t -> (t -> w) -> w + • Found type wildcard ‘_’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> _) -> _ at WarningWildcardInstantiations.hs:9:1-13 - • In the type signature: bar :: _ -> _ -> _ + • In the type ‘_ -> _ -> _’ + In the type signature: bar :: _ -> _ -> _ diff --git a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr index d1f5270d64..2426e4cd27 100644 --- a/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr +++ b/testsuite/tests/partial-sigs/should_fail/ExtraConstraintsWildcardInPatternSplice.stderr @@ -1,13 +1,13 @@ ExtraConstraintsWildcardInPatternSplice.hs:5:8: error: - • Found type wildcard ‘_’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of foo :: w -> () + • Found type wildcard ‘_’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of foo :: _ -> () at ExtraConstraintsWildcardInPatternSplice.hs:5:1-29 To use the inferred type, enable PartialTypeSignatures • In a pattern type signature: _ In the pattern: _ :: _ In an equation for ‘foo’: foo (_ :: _) = () • Relevant bindings include - foo :: w -> () + foo :: _ -> () (bound at ExtraConstraintsWildcardInPatternSplice.hs:5:1) diff --git a/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr b/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr index 69207b1af1..4837168487 100644 --- a/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr +++ b/testsuite/tests/partial-sigs/should_fail/InstantiatedNamedWildcardsInConstraints.stderr @@ -1,14 +1,14 @@ -InstantiatedNamedWildcardsInConstraints.hs:4:14: error: - • Found type wildcard ‘_a’ standing for ‘b’ +InstantiatedNamedWildcardsInConstraints.hs:4:8: error: + • Found type wildcard ‘_’ standing for ‘Show b’ Where: ‘b’ is a rigid type variable bound by the inferred type of foo :: (Enum b, Show b) => b -> (String, b) at InstantiatedNamedWildcardsInConstraints.hs:5:1-26 To use the inferred type, enable PartialTypeSignatures • In the type signature: foo :: (Enum _a, _) => _a -> (String, b) -InstantiatedNamedWildcardsInConstraints.hs:4:18: error: - • Found type wildcard ‘_’ standing for ‘Show b’ +InstantiatedNamedWildcardsInConstraints.hs:4:14: error: + • Found type wildcard ‘_a’ standing for ‘b’ Where: ‘b’ is a rigid type variable bound by the inferred type of foo :: (Enum b, Show b) => b -> (String, b) at InstantiatedNamedWildcardsInConstraints.hs:5:1-26 diff --git a/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr b/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr index c1a7d84896..c573747c02 100644 --- a/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr +++ b/testsuite/tests/partial-sigs/should_fail/NamedExtraConstraintsWildcard.stderr @@ -1,11 +1,11 @@ NamedExtraConstraintsWildcard.hs:5:1: error: - • Could not deduce: w0 - from the context: (Eq a, w) + • Could not deduce: _0 + from the context: (Eq a, _) bound by the inferred type for ‘foo’: - forall a (w :: Constraint). (Eq a, w) => a -> a + forall a (_ :: Constraint). (Eq a, _) => a -> a at NamedExtraConstraintsWildcard.hs:5:1-15 • In the ambiguity check for the inferred type for ‘foo’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes When checking the inferred type - foo :: forall a (w :: Constraint). (Eq a, w) => a -> a + foo :: forall a (_ :: Constraint). (Eq a, _) => a -> a diff --git a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr index 7d7320f0fb..89b71e5959 100644 --- a/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr +++ b/testsuite/tests/partial-sigs/should_fail/NamedWildcardsNotInMonotype.stderr @@ -1,12 +1,12 @@ NamedWildcardsNotInMonotype.hs:5:1: error: - • Could not deduce (Eq w0) - from the context: (Show a, Eq w, Eq a) + • Could not deduce (Eq _0) + from the context: (Show a, Eq _, Eq a) bound by the inferred type for ‘foo’: - forall a w. (Show a, Eq w, Eq a) => a -> a -> String + forall a _. (Show a, Eq _, Eq a) => a -> a -> String at NamedWildcardsNotInMonotype.hs:5:1-33 - The type variable ‘w0’ is ambiguous + The type variable ‘_0’ is ambiguous • In the ambiguity check for the inferred type for ‘foo’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes When checking the inferred type - foo :: forall a w. (Show a, Eq w, Eq a) => a -> a -> String + foo :: forall a _. (Show a, Eq _, Eq a) => a -> a -> String diff --git a/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr b/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr index 8e20d3fe98..be6ea0ae80 100644 --- a/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr +++ b/testsuite/tests/partial-sigs/should_fail/PartialTypeSignaturesDisabled.stderr @@ -2,9 +2,11 @@ PartialTypeSignaturesDisabled.hs:4:8: error: • Found type wildcard ‘_’ standing for ‘Bool’ To use the inferred type, enable PartialTypeSignatures - • In the type signature: foo :: _ -> _ + • In the type ‘_ -> _’ + In the type signature: foo :: _ -> _ PartialTypeSignaturesDisabled.hs:4:13: error: • Found type wildcard ‘_’ standing for ‘Bool’ To use the inferred type, enable PartialTypeSignatures - • In the type signature: foo :: _ -> _ + • In the type ‘_ -> _’ + In the type signature: foo :: _ -> _ diff --git a/testsuite/tests/partial-sigs/should_fail/PatBind3.stderr b/testsuite/tests/partial-sigs/should_fail/PatBind3.stderr index f20ae3c563..8ca3dcd540 100644 --- a/testsuite/tests/partial-sigs/should_fail/PatBind3.stderr +++ b/testsuite/tests/partial-sigs/should_fail/PatBind3.stderr @@ -1,9 +1,9 @@ PatBind3.hs:6:12: error: - • Couldn't match type ‘(Bool, w)’ with ‘Char’ - Expected type: Maybe ((Bool, w) -> Char) - Actual type: Maybe ((Bool, w) -> (Bool, w)) + • Couldn't match type ‘(Bool, _)’ with ‘Char’ + Expected type: Maybe ((Bool, _) -> Char) + Actual type: Maybe ((Bool, _) -> (Bool, _)) • In the expression: Just id In a pattern binding: Just foo = Just id • Relevant bindings include - foo :: (Bool, w) -> Char (bound at PatBind3.hs:6:6) + foo :: (Bool, _) -> Char (bound at PatBind3.hs:6:6) diff --git a/testsuite/tests/partial-sigs/should_fail/T10615.stderr b/testsuite/tests/partial-sigs/should_fail/T10615.stderr index 0b9bcb811c..f95df86dad 100644 --- a/testsuite/tests/partial-sigs/should_fail/T10615.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T10615.stderr @@ -3,7 +3,8 @@ T10615.hs:4:7: error: • Found type wildcard ‘_’ standing for ‘a1’ Where: ‘a1’ is an ambiguous type variable To use the inferred type, enable PartialTypeSignatures - • In the type signature: f1 :: _ -> f + • In the type ‘_ -> f’ + In the type signature: f1 :: _ -> f T10615.hs:5:6: error: • Couldn't match type ‘f’ with ‘b1 -> a1’ @@ -20,7 +21,8 @@ T10615.hs:7:7: error: • Found type wildcard ‘_’ standing for ‘a0’ Where: ‘a0’ is an ambiguous type variable To use the inferred type, enable PartialTypeSignatures - • In the type signature: f2 :: _ -> _f + • In the type ‘_ -> _f’ + In the type signature: f2 :: _ -> _f T10615.hs:8:6: error: • Couldn't match type ‘_f’ with ‘b0 -> a0’ diff --git a/testsuite/tests/partial-sigs/should_fail/T10999.stderr b/testsuite/tests/partial-sigs/should_fail/T10999.stderr index 5da96928c4..6352548bd8 100644 --- a/testsuite/tests/partial-sigs/should_fail/T10999.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T10999.stderr @@ -13,7 +13,8 @@ T10999.hs:5:17: error: the inferred type of f :: Ord a => () -> Set.Set a at T10999.hs:6:1-28 To use the inferred type, enable PartialTypeSignatures - • In the type signature: f :: _ => () -> _ + • In the type ‘() -> _’ + In the type signature: f :: _ => () -> _ T10999.hs:8:28: error: • Ambiguous type variable ‘b0’ arising from a use of ‘f’ diff --git a/testsuite/tests/partial-sigs/should_fail/T11122.stderr b/testsuite/tests/partial-sigs/should_fail/T11122.stderr index d308c4771d..a6b4c618ec 100644 --- a/testsuite/tests/partial-sigs/should_fail/T11122.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T11122.stderr @@ -1,4 +1,6 @@ T11122.hs:19:18: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘Int’ - • In the type signature: parser :: Parser _ + • In the first argument of ‘Parser’, namely ‘_’ + In the type ‘Parser _’ + In the type signature: parser :: Parser _ diff --git a/testsuite/tests/partial-sigs/should_fail/T11515.stderr b/testsuite/tests/partial-sigs/should_fail/T11515.stderr index 2870457500..0c8ff61cff 100644 --- a/testsuite/tests/partial-sigs/should_fail/T11515.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T11515.stderr @@ -1,5 +1,5 @@ -T11515.hs:7:20: error: +T11515.hs:7:8: error: • Found type wildcard ‘_’ standing for ‘()’ To use the inferred type, enable PartialTypeSignatures • In the type signature: foo :: (ShowSyn a, _) => a -> String diff --git a/testsuite/tests/partial-sigs/should_fail/T11976.stderr b/testsuite/tests/partial-sigs/should_fail/T11976.stderr index 28104625e1..c4c3d50e59 100644 --- a/testsuite/tests/partial-sigs/should_fail/T11976.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T11976.stderr @@ -1,12 +1,12 @@ T11976.hs:7:7: error: • Cannot instantiate unification variable ‘a0’ - with a type involving foralls: Lens w3 w4 w5 + with a type involving foralls: Lens _3 _4 _5 GHC doesn't yet support impredicative polymorphism • In the expression: undefined :: Lens _ _ _ In an equation for ‘foo’: foo = undefined :: Lens _ _ _ • Relevant bindings include - foo :: Lens w w1 w2 (bound at T11976.hs:7:1) + foo :: Lens _ _1 _2 (bound at T11976.hs:7:1) T11976.hs:7:20: error: • Expected kind ‘k0 -> *’, but ‘Lens _ _’ has kind ‘*’ @@ -14,4 +14,4 @@ T11976.hs:7:20: error: In an expression type signature: Lens _ _ _ In the expression: undefined :: Lens _ _ _ • Relevant bindings include - foo :: Lens w w1 w2 (bound at T11976.hs:7:1) + foo :: Lens _ _1 _2 (bound at T11976.hs:7:1) diff --git a/testsuite/tests/partial-sigs/should_fail/T12634.stderr b/testsuite/tests/partial-sigs/should_fail/T12634.stderr index 316f7eb2c5..7aab25f5f8 100644 --- a/testsuite/tests/partial-sigs/should_fail/T12634.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T12634.stderr @@ -1,5 +1,5 @@ -T12634.hs:14:37: error: +T12634.hs:14:19: error: • Found type wildcard ‘_’ standing for ‘()’ To use the inferred type, enable PartialTypeSignatures • In the type signature: diff --git a/testsuite/tests/partial-sigs/should_fail/T14040a.stderr b/testsuite/tests/partial-sigs/should_fail/T14040a.stderr index 67fae7b31e..0a07f0590d 100644 --- a/testsuite/tests/partial-sigs/should_fail/T14040a.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T14040a.stderr @@ -1,10 +1,10 @@ T14040a.hs:34:8: error: • Cannot apply expression of type ‘Sing wl0 - -> (forall y. p0 w0 'WeirdNil) + -> (forall y. p0 _0 'WeirdNil) -> (forall z1 (x :: z1) (xs :: WeirdList (WeirdList z1)). - Sing x -> Sing xs -> p0 w1 xs -> p0 w2 ('WeirdCons x xs)) - -> p0 w3 wl0’ + Sing x -> Sing xs -> p0 _1 xs -> p0 _2 ('WeirdCons x xs)) + -> p0 _3 wl0’ to a visible type argument ‘(WeirdList z)’ • In the sixth argument of ‘pWeirdCons’, namely ‘(elimWeirdList @(WeirdList z) @xs @p xs pWeirdNil pWeirdCons)’ diff --git a/testsuite/tests/partial-sigs/should_fail/T14584.stderr b/testsuite/tests/partial-sigs/should_fail/T14584.stderr index f22178774e..80c8ce2683 100644 --- a/testsuite/tests/partial-sigs/should_fail/T14584.stderr +++ b/testsuite/tests/partial-sigs/should_fail/T14584.stderr @@ -55,10 +55,8 @@ T14584.hs:56:60: warning: [-Wpartial-type-signatures (in -Wdefault)] ‘m’ is a rigid type variable bound by the instance declaration at T14584.hs:54:10-89 - • In an expression type signature: Sing _ - In the second argument of ‘fromSing’, namely - ‘(sing @m @a :: Sing _)’ - In the fourth argument of ‘act’, namely - ‘(fromSing @m (sing @m @a :: Sing _))’ + • In the first argument of ‘Sing’, namely ‘_’ + In the type ‘Sing _’ + In an expression type signature: Sing _ • Relevant bindings include monHom :: a -> a (bound at T14584.hs:56:3) diff --git a/testsuite/tests/partial-sigs/should_fail/TidyClash.stderr b/testsuite/tests/partial-sigs/should_fail/TidyClash.stderr index 15282550b5..6ec4c440cc 100644 --- a/testsuite/tests/partial-sigs/should_fail/TidyClash.stderr +++ b/testsuite/tests/partial-sigs/should_fail/TidyClash.stderr @@ -1,16 +1,18 @@ TidyClash.hs:8:19: error: - • Found type wildcard ‘_’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of bar :: w_ -> (w_, w -> w1) + • Found type wildcard ‘_’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of bar :: w_ -> (w_, _ -> _1) at TidyClash.hs:9:1-28 To use the inferred type, enable PartialTypeSignatures - • In the type signature: bar :: w_ -> (w_, _ -> _) + • In the type ‘w_ -> (w_, _ -> _)’ + In the type signature: bar :: w_ -> (w_, _ -> _) TidyClash.hs:8:24: error: - • Found type wildcard ‘_’ standing for ‘w1’ - Where: ‘w1’ is a rigid type variable bound by - the inferred type of bar :: w_ -> (w_, w -> w1) + • Found type wildcard ‘_’ standing for ‘_1’ + Where: ‘_1’ is a rigid type variable bound by + the inferred type of bar :: w_ -> (w_, _ -> _1) at TidyClash.hs:9:1-28 To use the inferred type, enable PartialTypeSignatures - • In the type signature: bar :: w_ -> (w_, _ -> _) + • In the type ‘w_ -> (w_, _ -> _)’ + In the type signature: bar :: w_ -> (w_, _ -> _) diff --git a/testsuite/tests/partial-sigs/should_fail/TidyClash2.stderr b/testsuite/tests/partial-sigs/should_fail/TidyClash2.stderr index 42a98ad8ef..a2c63ecbbc 100644 --- a/testsuite/tests/partial-sigs/should_fail/TidyClash2.stderr +++ b/testsuite/tests/partial-sigs/should_fail/TidyClash2.stderr @@ -1,53 +1,60 @@ TidyClash2.hs:13:20: error: - • Found type wildcard ‘_’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of barry :: w -> w1 -> t at TidyClash2.hs:14:1-40 + • Found type wildcard ‘_’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of barry :: _ -> _1 -> t + at TidyClash2.hs:14:1-40 To use the inferred type, enable PartialTypeSignatures - • In the type signature: barry :: forall t. _ -> _ -> t + • In the type ‘_ -> _ -> t’ + In the type signature: barry :: forall t. _ -> _ -> t TidyClash2.hs:13:25: error: - • Found type wildcard ‘_’ standing for ‘w1’ - Where: ‘w1’ is a rigid type variable bound by - the inferred type of barry :: w -> w1 -> t at TidyClash2.hs:14:1-40 + • Found type wildcard ‘_’ standing for ‘_1’ + Where: ‘_1’ is a rigid type variable bound by + the inferred type of barry :: _ -> _1 -> t + at TidyClash2.hs:14:1-40 To use the inferred type, enable PartialTypeSignatures - • In the type signature: barry :: forall t. _ -> _ -> t + • In the type ‘_ -> _ -> t’ + In the type signature: barry :: forall t. _ -> _ -> t TidyClash2.hs:14:13: error: - • Found type wildcard ‘_’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of barry :: w -> w1 -> t at TidyClash2.hs:14:1-40 + • Found type wildcard ‘_’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of barry :: _ -> _1 -> t + at TidyClash2.hs:14:1-40 To use the inferred type, enable PartialTypeSignatures • In a pattern type signature: _ In the pattern: x :: _ In an equation for ‘barry’: barry (x :: _) (y :: _) = undefined :: _ • Relevant bindings include - barry :: w -> w1 -> t (bound at TidyClash2.hs:14:1) + barry :: _ -> _1 -> t (bound at TidyClash2.hs:14:1) TidyClash2.hs:14:22: error: - • Found type wildcard ‘_’ standing for ‘w1’ - Where: ‘w1’ is a rigid type variable bound by - the inferred type of barry :: w -> w1 -> t at TidyClash2.hs:14:1-40 + • Found type wildcard ‘_’ standing for ‘_1’ + Where: ‘_1’ is a rigid type variable bound by + the inferred type of barry :: _ -> _1 -> t + at TidyClash2.hs:14:1-40 To use the inferred type, enable PartialTypeSignatures • In a pattern type signature: _ In the pattern: y :: _ In an equation for ‘barry’: barry (x :: _) (y :: _) = undefined :: _ • Relevant bindings include - x :: w (bound at TidyClash2.hs:14:8) - barry :: w -> w1 -> t (bound at TidyClash2.hs:14:1) + x :: _ (bound at TidyClash2.hs:14:8) + barry :: _ -> _1 -> t (bound at TidyClash2.hs:14:1) TidyClash2.hs:14:40: error: - • Found type wildcard ‘_’ standing for ‘w2’ - Where: ‘w2’ is a rigid type variable bound by - the inferred type of <expression> :: w2 at TidyClash2.hs:14:40 + • Found type wildcard ‘_’ standing for ‘_2’ + Where: ‘_2’ is a rigid type variable bound by + the inferred type of <expression> :: _2 + at TidyClash2.hs:14:40 To use the inferred type, enable PartialTypeSignatures • In an expression type signature: _ In the expression: undefined :: _ In an equation for ‘barry’: barry (x :: _) (y :: _) = undefined :: _ • Relevant bindings include - y :: w1 (bound at TidyClash2.hs:14:17) - x :: w (bound at TidyClash2.hs:14:8) - barry :: w -> w1 -> t (bound at TidyClash2.hs:14:1) + y :: _1 (bound at TidyClash2.hs:14:17) + x :: _ (bound at TidyClash2.hs:14:8) + barry :: _ -> _1 -> t (bound at TidyClash2.hs:14:1) diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr index aa5e8247f3..02e9c970ed 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardInstantiations.stderr @@ -1,14 +1,14 @@ -WildcardInstantiations.hs:5:14: error: - • Found type wildcard ‘_a’ standing for ‘a’ +WildcardInstantiations.hs:5:8: error: + • Found type wildcard ‘_’ standing for ‘Enum a’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: (Show a, Enum a) => a -> String at WildcardInstantiations.hs:6:1-21 To use the inferred type, enable PartialTypeSignatures • In the type signature: foo :: (Show _a, _) => _a -> _ -WildcardInstantiations.hs:5:18: error: - • Found type wildcard ‘_’ standing for ‘Enum a’ +WildcardInstantiations.hs:5:14: error: + • Found type wildcard ‘_a’ standing for ‘a’ Where: ‘a’ is a rigid type variable bound by the inferred type of foo :: (Show a, Enum a) => a -> String at WildcardInstantiations.hs:6:1-21 @@ -18,28 +18,32 @@ WildcardInstantiations.hs:5:18: error: WildcardInstantiations.hs:5:30: error: • Found type wildcard ‘_’ standing for ‘String’ To use the inferred type, enable PartialTypeSignatures - • In the type signature: foo :: (Show _a, _) => _a -> _ + • In the type ‘_a -> _’ + In the type signature: foo :: (Show _a, _) => _a -> _ WildcardInstantiations.hs:8:8: error: • Found type wildcard ‘_’ standing for ‘t’ Where: ‘t’ is a rigid type variable bound by - the inferred type of bar :: t -> (t -> w) -> w + the inferred type of bar :: t -> (t -> _) -> _ at WildcardInstantiations.hs:9:1-13 To use the inferred type, enable PartialTypeSignatures - • In the type signature: bar :: _ -> _ -> _ + • In the type ‘_ -> _ -> _’ + In the type signature: bar :: _ -> _ -> _ WildcardInstantiations.hs:8:13: error: - • Found type wildcard ‘_’ standing for ‘t -> w’ - Where: ‘t’, ‘w’ are rigid type variables bound by - the inferred type of bar :: t -> (t -> w) -> w + • Found type wildcard ‘_’ standing for ‘t -> _’ + Where: ‘t’, ‘_’ are rigid type variables bound by + the inferred type of bar :: t -> (t -> _) -> _ at WildcardInstantiations.hs:9:1-13 To use the inferred type, enable PartialTypeSignatures - • In the type signature: bar :: _ -> _ -> _ + • In the type ‘_ -> _ -> _’ + In the type signature: bar :: _ -> _ -> _ WildcardInstantiations.hs:8:18: error: - • Found type wildcard ‘_’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of bar :: t -> (t -> w) -> w + • Found type wildcard ‘_’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of bar :: t -> (t -> _) -> _ at WildcardInstantiations.hs:9:1-13 To use the inferred type, enable PartialTypeSignatures - • In the type signature: bar :: _ -> _ -> _ + • In the type ‘_ -> _ -> _’ + In the type signature: bar :: _ -> _ -> _ diff --git a/testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.stderr b/testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.stderr index 726b43898e..d75a630d04 100644 --- a/testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.stderr +++ b/testsuite/tests/partial-sigs/should_fail/WildcardsInPatternAndExprSig.stderr @@ -1,34 +1,34 @@ WildcardsInPatternAndExprSig.hs:4:18: error: - • Found type wildcard ‘_a’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of bar :: Maybe [w] -> w -> [w] + • Found type wildcard ‘_a’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of bar :: Maybe [_] -> _ -> [_] at WildcardsInPatternAndExprSig.hs:4:1-68 To use the inferred type, enable PartialTypeSignatures • In a pattern type signature: _a In the pattern: x :: _a In the pattern: [x :: _a] • Relevant bindings include - bar :: Maybe [w] -> w -> [w] + bar :: Maybe [_] -> _ -> [_] (bound at WildcardsInPatternAndExprSig.hs:4:1) WildcardsInPatternAndExprSig.hs:4:25: error: - • Found type wildcard ‘_’ standing for ‘[w]’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of bar :: Maybe [w] -> w -> [w] + • Found type wildcard ‘_’ standing for ‘[_]’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of bar :: Maybe [_] -> _ -> [_] at WildcardsInPatternAndExprSig.hs:4:1-68 To use the inferred type, enable PartialTypeSignatures • In a pattern type signature: _ In the pattern: [x :: _a] :: _ In the pattern: Just ([x :: _a] :: _) • Relevant bindings include - bar :: Maybe [w] -> w -> [w] + bar :: Maybe [_] -> _ -> [_] (bound at WildcardsInPatternAndExprSig.hs:4:1) WildcardsInPatternAndExprSig.hs:4:38: error: - • Found type wildcard ‘_b’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of bar :: Maybe [w] -> w -> [w] + • Found type wildcard ‘_b’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of bar :: Maybe [_] -> _ -> [_] at WildcardsInPatternAndExprSig.hs:4:1-68 To use the inferred type, enable PartialTypeSignatures • In a pattern type signature: Maybe [_b] @@ -37,13 +37,13 @@ WildcardsInPatternAndExprSig.hs:4:38: error: bar (Just ([x :: _a] :: _) :: Maybe [_b]) (z :: _c) = [x, z] :: [_d] • Relevant bindings include - bar :: Maybe [w] -> w -> [w] + bar :: Maybe [_] -> _ -> [_] (bound at WildcardsInPatternAndExprSig.hs:4:1) WildcardsInPatternAndExprSig.hs:4:49: error: - • Found type wildcard ‘_c’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of bar :: Maybe [w] -> w -> [w] + • Found type wildcard ‘_c’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of bar :: Maybe [_] -> _ -> [_] at WildcardsInPatternAndExprSig.hs:4:1-68 To use the inferred type, enable PartialTypeSignatures • In a pattern type signature: _c @@ -52,14 +52,14 @@ WildcardsInPatternAndExprSig.hs:4:49: error: bar (Just ([x :: _a] :: _) :: Maybe [_b]) (z :: _c) = [x, z] :: [_d] • Relevant bindings include - x :: w (bound at WildcardsInPatternAndExprSig.hs:4:13) - bar :: Maybe [w] -> w -> [w] + x :: _ (bound at WildcardsInPatternAndExprSig.hs:4:13) + bar :: Maybe [_] -> _ -> [_] (bound at WildcardsInPatternAndExprSig.hs:4:1) WildcardsInPatternAndExprSig.hs:4:66: error: - • Found type wildcard ‘_d’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of bar :: Maybe [w] -> w -> [w] + • Found type wildcard ‘_d’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of bar :: Maybe [_] -> _ -> [_] at WildcardsInPatternAndExprSig.hs:4:1-68 To use the inferred type, enable PartialTypeSignatures • In an expression type signature: [_d] @@ -68,7 +68,7 @@ WildcardsInPatternAndExprSig.hs:4:66: error: bar (Just ([x :: _a] :: _) :: Maybe [_b]) (z :: _c) = [x, z] :: [_d] • Relevant bindings include - z :: w (bound at WildcardsInPatternAndExprSig.hs:4:44) - x :: w (bound at WildcardsInPatternAndExprSig.hs:4:13) - bar :: Maybe [w] -> w -> [w] + z :: _ (bound at WildcardsInPatternAndExprSig.hs:4:44) + x :: _ (bound at WildcardsInPatternAndExprSig.hs:4:13) + bar :: Maybe [_] -> _ -> [_] (bound at WildcardsInPatternAndExprSig.hs:4:1) diff --git a/testsuite/tests/partial-sigs/should_run/T15415.stderr b/testsuite/tests/partial-sigs/should_run/T15415.stderr index daa791ffa4..a43f80e6bd 100644 --- a/testsuite/tests/partial-sigs/should_run/T15415.stderr +++ b/testsuite/tests/partial-sigs/should_run/T15415.stderr @@ -1,27 +1,41 @@ <interactive>:1:7: error: - Found type wildcard ‘_’ standing for ‘w0 :: k0’ - Where: ‘k0’ is an ambiguous type variable - ‘w0’ is an ambiguous type variable - To use the inferred type, enable PartialTypeSignatures + • Found type wildcard ‘_’ standing for ‘_0 :: k0’ + Where: ‘k0’ is an ambiguous type variable + ‘_0’ is an ambiguous type variable + To use the inferred type, enable PartialTypeSignatures + • In the first argument of ‘Proxy’, namely ‘_’ + In the type ‘Proxy _’ <interactive>:1:17: error: - Found type wildcard ‘_’ standing for ‘* -> *’ - To use the inferred type, enable PartialTypeSignatures + • Found type wildcard ‘_’ standing for ‘* -> *’ + To use the inferred type, enable PartialTypeSignatures + • In the kind ‘_’ + In the first argument of ‘Proxy’, namely ‘(Maybe :: _)’ + In the type ‘Proxy (Maybe :: _)’ <interactive>:1:11: error: - Found type wildcard ‘_’ standing for ‘w0’ - Where: ‘w0’ is an ambiguous type variable - To use the inferred type, enable PartialTypeSignatures + • Found type wildcard ‘_’ standing for ‘_0’ + Where: ‘_0’ is an ambiguous type variable + To use the inferred type, enable PartialTypeSignatures + • In the first argument of ‘Dependent’, namely ‘_’ + In the type ‘Dependent _’ <interactive>:1:7: warning: [-Wpartial-type-signatures (in -Wdefault)] - Found type wildcard ‘_’ standing for ‘w0 :: k0’ - Where: ‘k0’ is an ambiguous type variable - ‘w0’ is an ambiguous type variable + • Found type wildcard ‘_’ standing for ‘_0 :: k0’ + Where: ‘k0’ is an ambiguous type variable + ‘_0’ is an ambiguous type variable + • In the first argument of ‘Proxy’, namely ‘_’ + In the type ‘Proxy _’ <interactive>:1:17: warning: [-Wpartial-type-signatures (in -Wdefault)] - Found type wildcard ‘_’ standing for ‘* -> *’ + • Found type wildcard ‘_’ standing for ‘* -> *’ + • In the kind ‘_’ + In the first argument of ‘Proxy’, namely ‘(Maybe :: _)’ + In the type ‘Proxy (Maybe :: _)’ <interactive>:1:11: warning: [-Wpartial-type-signatures (in -Wdefault)] - Found type wildcard ‘_’ standing for ‘w0’ - Where: ‘w0’ is an ambiguous type variable + • Found type wildcard ‘_’ standing for ‘_0’ + Where: ‘_0’ is an ambiguous type variable + • In the first argument of ‘Dependent’, namely ‘_’ + In the type ‘Dependent _’ diff --git a/testsuite/tests/partial-sigs/should_run/T15415.stdout b/testsuite/tests/partial-sigs/should_run/T15415.stdout index 709da2f17c..17af08faea 100644 --- a/testsuite/tests/partial-sigs/should_run/T15415.stdout +++ b/testsuite/tests/partial-sigs/should_run/T15415.stdout @@ -1,6 +1,6 @@ Proxy _ :: * Proxy (Maybe :: _) :: * -Dependent _ :: w -> * +Dependent _ :: _ -> * Proxy _ :: * Proxy (Maybe :: _) :: * -Dependent _ :: w -> * +Dependent _ :: _ -> * diff --git a/testsuite/tests/perf/compiler/T13035.stderr b/testsuite/tests/perf/compiler/T13035.stderr index 3dca3d71f2..50ee3a64aa 100644 --- a/testsuite/tests/perf/compiler/T13035.stderr +++ b/testsuite/tests/perf/compiler/T13035.stderr @@ -1,4 +1,6 @@ T13035.hs:144:28: warning: [-Wpartial-type-signatures (in -Wdefault)] • Found type wildcard ‘_’ standing for ‘'[ 'Author] :: [Fields]’ - • In the type signature: g :: MyRec RecipeFormatter _ + • In the second argument of ‘MyRec’, namely ‘_’ + In the type ‘MyRec RecipeFormatter _’ + In the type signature: g :: MyRec RecipeFormatter _ diff --git a/testsuite/tests/polykinds/T14172.stderr b/testsuite/tests/polykinds/T14172.stderr index 487b006ec1..f85cf66d79 100644 --- a/testsuite/tests/polykinds/T14172.stderr +++ b/testsuite/tests/polykinds/T14172.stderr @@ -6,8 +6,9 @@ T14172.hs:6:46: error: traverseCompose :: (a -> f b) -> g a -> f (h a') at T14172.hs:7:1-46 To use the inferred type, enable PartialTypeSignatures - • In the type signature: - traverseCompose :: (a -> f b) -> g a -> f (h _) + • In the first argument of ‘h’, namely ‘_’ + In the first argument of ‘f’, namely ‘(h _)’ + In the type ‘(a -> f b) -> g a -> f (h _)’ T14172.hs:7:19: error: • Occurs check: cannot construct the infinite type: a ~ g'1 a diff --git a/testsuite/tests/polykinds/T14265.stderr b/testsuite/tests/polykinds/T14265.stderr index 43366fccb7..fa951ad920 100644 --- a/testsuite/tests/polykinds/T14265.stderr +++ b/testsuite/tests/polykinds/T14265.stderr @@ -1,24 +1,30 @@ T14265.hs:7:12: error: - • Found type wildcard ‘_’ standing for ‘w :: k’ - Where: ‘k’, ‘w’ are rigid type variables bound by - the inferred type of f :: proxy w -> () + • Found type wildcard ‘_’ standing for ‘_ :: k’ + Where: ‘k’, ‘_’ are rigid type variables bound by + the inferred type of f :: proxy _ -> () at T14265.hs:8:1-8 To use the inferred type, enable PartialTypeSignatures - • In the type signature: f :: proxy _ -> () + • In the first argument of ‘proxy’, namely ‘_’ + In the type ‘proxy _ -> ()’ + In the type signature: f :: proxy _ -> () T14265.hs:10:15: error: - • Found type wildcard ‘_’ standing for ‘w’ - Where: ‘w’ is a rigid type variable bound by - the inferred type of foo :: StateT w w1 () + • Found type wildcard ‘_’ standing for ‘_’ + Where: ‘_’ is a rigid type variable bound by + the inferred type of foo :: StateT _ _1 () at T14265.hs:11:1-15 To use the inferred type, enable PartialTypeSignatures - • In the type signature: foo :: StateT _ _ () + • In the first argument of ‘StateT’, namely ‘_’ + In the type ‘StateT _ _ ()’ + In the type signature: foo :: StateT _ _ () T14265.hs:10:17: error: - • Found type wildcard ‘_’ standing for ‘w1 :: * -> *’ - Where: ‘w1’ is a rigid type variable bound by - the inferred type of foo :: StateT w w1 () + • Found type wildcard ‘_’ standing for ‘_1 :: * -> *’ + Where: ‘_1’ is a rigid type variable bound by + the inferred type of foo :: StateT _ _1 () at T14265.hs:11:1-15 To use the inferred type, enable PartialTypeSignatures - • In the type signature: foo :: StateT _ _ () + • In the second argument of ‘StateT’, namely ‘_’ + In the type ‘StateT _ _ ()’ + In the type signature: foo :: StateT _ _ () diff --git a/testsuite/tests/th/ClosedFam2TH.hs b/testsuite/tests/th/ClosedFam2TH.hs index 2a8b3b4ab6..2237aba651 100644 --- a/testsuite/tests/th/ClosedFam2TH.hs +++ b/testsuite/tests/th/ClosedFam2TH.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, TypeFamilies, PolyKinds #-} +{-# LANGUAGE TemplateHaskell, TypeFamilies, PolyKinds, TypeApplications #-} module ClosedFam2 where @@ -12,12 +12,12 @@ $( return [ ClosedTypeFamilyD ( TyVarSig (KindedTV (mkName "r") (VarT (mkName "k")))) Nothing) [ TySynEqn Nothing - [ (VarT (mkName "a")) - , (VarT (mkName "a")) ] + (AppT (AppT (ConT (mkName "Equals")) (VarT (mkName "a"))) + (VarT (mkName "a"))) (ConT (mkName "Int")) , TySynEqn Nothing - [ (VarT (mkName "a")) - , (VarT (mkName "b")) ] + (AppT (AppT (ConT (mkName "Equals")) (VarT (mkName "a"))) + (VarT (mkName "b"))) (ConT (mkName "Bool")) ] ]) a :: Equals b b @@ -25,3 +25,25 @@ a = (5 :: Int) b :: Equals Int Bool b = False + +$( return [ ClosedTypeFamilyD + (TypeFamilyHead + (mkName "Foo") + [ KindedTV (mkName "a") (VarT (mkName "k"))] + (KindSig StarT ) Nothing ) + [ TySynEqn Nothing + (AppT (AppKindT (ConT (mkName "Foo")) StarT) + (VarT (mkName "a"))) + (ConT (mkName "Int")) + , TySynEqn Nothing + (AppT (AppKindT (ConT (mkName "Foo")) (AppT (AppT ArrowT StarT) (StarT))) + (VarT (mkName "a"))) + (ConT (mkName "Bool")) ] ]) +c :: Foo Int +c = 5 + +d :: Foo Bool +d = 6 + +e :: Foo Maybe +e = False diff --git a/testsuite/tests/th/T12045TH1.hs b/testsuite/tests/th/T12045TH1.hs new file mode 100644 index 0000000000..c16bab29f9 --- /dev/null +++ b/testsuite/tests/th/T12045TH1.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds + , TypeInType, TypeApplications, TypeFamilies #-} + +module T12045TH1 where +import Data.Kind +import Language.Haskell.TH hiding (Type) + +$([d| type family F (a :: k) :: Type where + F @Type Int = Bool + F @(Type->Type) Maybe = Char |]) + + +$([d| data family D (a :: k) |]) + +$([d| data instance D @Type a = DBool |]) + +$([d| data instance D @(Type -> Type) b = DChar |]) diff --git a/testsuite/tests/th/T12045TH1.stderr b/testsuite/tests/th/T12045TH1.stderr new file mode 100644 index 0000000000..fb4bf1a302 --- /dev/null +++ b/testsuite/tests/th/T12045TH1.stderr @@ -0,0 +1,18 @@ +T12045TH1.hs:(8,3)-(10,52): Splicing declarations + [d| type family F (a :: k) :: Type where + F @Type Int = Bool + F @(Type -> Type) Maybe = Char |] + ======> + type family F (a :: k) :: Type where + F @Type Int = Bool + F @Type -> Type Maybe = Char +T12045TH1.hs:13:3-31: Splicing declarations + [d| data family D (a :: k) |] ======> data family D (a :: k) +T12045TH1.hs:15:3-40: Splicing declarations + [d| data instance D @Type a = DBool |] + ======> + data instance D @Type a = DBool +T12045TH1.hs:17:3-50: Splicing declarations + [d| data instance D @(Type -> Type) b = DChar |] + ======> + data instance D @Type -> Type b = DChar diff --git a/testsuite/tests/th/T12045TH2.hs b/testsuite/tests/th/T12045TH2.hs new file mode 100644 index 0000000000..21d04cb826 --- /dev/null +++ b/testsuite/tests/th/T12045TH2.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE TemplateHaskell, TypeApplications, PolyKinds + , TypeFamilies, DataKinds #-} + +module T12045TH2 where + +import Data.Kind +import Language.Haskell.TH hiding (Type) +import System.IO + +type family Foo (a :: k) :: Type where + Foo @Type a = Bool + +type family Baz (a :: k) +type instance Baz @(Type->Type->Type) a = Char + +$( do FamilyI foo@(ClosedTypeFamilyD (TypeFamilyHead _ tvbs1 res1 m_kind1) + [TySynEqn (Just bndrs1) (AppT _ lhs1) rhs1]) + [] <- reify ''Foo + FamilyI baz@(OpenTypeFamilyD (TypeFamilyHead _ tvbs2 res2 m_kind2)) + [inst@(TySynInstD (TySynEqn (Just bndrs2) (AppT _ lhs2) rhs2))] <- reify ''Baz + runIO $ putStrLn $ pprint foo + runIO $ putStrLn $ pprint baz + runIO $ putStrLn $ pprint inst + runIO $ hFlush stdout + return [ ClosedTypeFamilyD + (TypeFamilyHead (mkName "Foo'") tvbs1 res1 m_kind1) + [TySynEqn (Just bndrs1) (AppT (ConT (mkName "Foo'")) lhs1) rhs1] + , OpenTypeFamilyD + (TypeFamilyHead (mkName "Baz'") tvbs2 res2 m_kind2) + , TySynInstD (TySynEqn (Just bndrs2) (AppT (ConT (mkName "Baz'")) lhs2) rhs2)] ) diff --git a/testsuite/tests/th/T12045TH2.stderr b/testsuite/tests/th/T12045TH2.stderr new file mode 100644 index 0000000000..ce626e5e01 --- /dev/null +++ b/testsuite/tests/th/T12045TH2.stderr @@ -0,0 +1,5 @@ +type family T12045TH2.Foo (a_0 :: k_1) :: * where + forall (a_2 :: *). T12045TH2.Foo (a_2 :: *) = GHC.Types.Bool +type family T12045TH2.Baz (a_0 :: k_1) :: * +type instance forall (a_0 :: * -> + * -> *). T12045TH2.Baz (a_0 :: * -> * -> *) = GHC.Types.Char diff --git a/testsuite/tests/th/T12503.hs b/testsuite/tests/th/T12503.hs index eef302c429..78175bcf04 100644 --- a/testsuite/tests/th/T12503.hs +++ b/testsuite/tests/th/T12503.hs @@ -21,9 +21,9 @@ data family T2 (a :: b) data instance T2 b class C2 a -$(do FamilyI (DataFamilyD tName _ _) [DataInstD [] _ _ [tyVar] _ _ _] +$(do FamilyI (DataFamilyD tName _ _) [DataInstD [] _ tyVar _ _ _] <- reify ''T2 d <- instanceD (cxt []) - (conT ''C2 `appT` (conT tName `appT` return tyVar)) + (conT ''C2 `appT` return tyVar) [] return [d]) diff --git a/testsuite/tests/th/T13618.hs b/testsuite/tests/th/T13618.hs index 1156aada39..7ef6e4e9ea 100644 --- a/testsuite/tests/th/T13618.hs +++ b/testsuite/tests/th/T13618.hs @@ -15,11 +15,11 @@ $(return []) main :: IO () main = print $(do FamilyI (DataFamilyD _ _ _) insts <- reify ''DF - lift $ all (\case DataInstD _ _ _ [AppT _ (VarT v1)] _ - [NormalC _ [(_, VarT v2)]] _ + lift $ all (\case DataInstD _ _ (AppT (ConT _) (AppT _ (VarT v1))) _ + [NormalC _ [(_, VarT v2)]] _ -> v1 == v2 - NewtypeInstD _ _ _ [AppT _ (VarT v1)] _ - (NormalC _ [(_, VarT v2)]) _ + NewtypeInstD _ _ (AppT (ConT _) (AppT _ (VarT v1))) _ + (NormalC _ [(_, VarT v2)]) _ -> v1 == v2 _ -> error "Not a data or newtype instance") insts) diff --git a/testsuite/tests/th/T15360b.stderr b/testsuite/tests/th/T15360b.stderr index 8175c12556..aa3f6d93de 100644 --- a/testsuite/tests/th/T15360b.stderr +++ b/testsuite/tests/th/T15360b.stderr @@ -1,20 +1,20 @@ T15360b.hs:10:14: error: - • Expected kind ‘* -> k4’, but ‘Type’ has kind ‘*’ + • Expected kind ‘* -> k3’, but ‘Type’ has kind ‘*’ • In the first argument of ‘Proxy’, namely ‘(Type Double)’ In the type signature: x :: Proxy (Type Double) T15360b.hs:13:14: error: - • Expected kind ‘* -> k3’, but ‘1’ has kind ‘GHC.Types.Nat’ + • Expected kind ‘* -> k2’, but ‘1’ has kind ‘GHC.Types.Nat’ • In the first argument of ‘Proxy’, namely ‘(1 Int)’ In the type signature: y :: Proxy (1 Int) T15360b.hs:16:14: error: - • Expected kind ‘* -> k2’, but ‘Constraint’ has kind ‘*’ + • Expected kind ‘* -> k1’, but ‘Constraint’ has kind ‘*’ • In the first argument of ‘Proxy’, namely ‘(Constraint Bool)’ In the type signature: z :: Proxy (Constraint Bool) T15360b.hs:19:14: error: - • Expected kind ‘* -> k1’, but ‘'[]’ has kind ‘[k0]’ + • Expected kind ‘* -> k0’, but ‘'[]’ has kind ‘[a0]’ • In the first argument of ‘Proxy’, namely ‘('[] Int)’ In the type signature: w :: Proxy ('[] Int) diff --git a/testsuite/tests/th/T15362.hs b/testsuite/tests/th/T15362.hs new file mode 100644 index 0000000000..183f887252 --- /dev/null +++ b/testsuite/tests/th/T15362.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators, DataKinds #-} + +module T15362 where + +data Nat = Zero | Succ Nat + +$( [d| type family a + b where + Maybe Zero b = b + Succ a + b = Succ (a + b) |] ) diff --git a/testsuite/tests/th/T15362.stderr b/testsuite/tests/th/T15362.stderr new file mode 100644 index 0000000000..0ec2dd8e48 --- /dev/null +++ b/testsuite/tests/th/T15362.stderr @@ -0,0 +1,10 @@ + +T15362.hs:8:10: error: + • Mismatched type name in type family instance. + Expected: + + Actual: Maybe + In the declaration for type family ‘+’ + • In the Template Haskell quotation + [d| type family a + b where + Maybe Zero b = b + Succ a + b = Succ (a + b) |] diff --git a/testsuite/tests/th/T5886a.hs b/testsuite/tests/th/T5886a.hs index 5756fcc513..66992014f9 100644 --- a/testsuite/tests/th/T5886a.hs +++ b/testsuite/tests/th/T5886a.hs @@ -11,5 +11,5 @@ class C α where type AT α ∷ Type bang ∷ DecsQ -bang = return [InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int)) - [TySynInstD ''AT (TySynEqn Nothing [ConT ''Int] (ConT ''Int))]] +bang = return [InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int)) + [TySynInstD (TySynEqn Nothing (AppT (ConT ''AT) (ConT ''Int)) (ConT ''Int))]] diff --git a/testsuite/tests/th/T6018th.hs b/testsuite/tests/th/T6018th.hs index 6b7b67d5a9..d0f448b80a 100644 --- a/testsuite/tests/th/T6018th.hs +++ b/testsuite/tests/th/T6018th.hs @@ -19,23 +19,18 @@ $( return (Just $ InjectivityAnn (mkName "result") [(mkName "a"), (mkName "b"), (mkName "c") ])) , TySynInstD - (mkName "F") - (TySynEqn Nothing - [ ConT (mkName "Int"), ConT (mkName "Char") - , ConT (mkName "Bool")] - ( ConT (mkName "Bool"))) + (TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "F")) (ConT (mkName "Int"))) + (ConT (mkName "Char"))) (ConT (mkName "Bool"))) + (ConT (mkName "Bool"))) + , TySynInstD - (mkName "F") - (TySynEqn Nothing - [ ConT (mkName "Char"), ConT (mkName "Bool") - , ConT (mkName "Int")] - ( ConT (mkName "Int"))) + (TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "F")) (ConT (mkName "Char"))) + (ConT (mkName "Bool"))) (ConT (mkName "Int"))) + (ConT (mkName "Int"))) , TySynInstD - (mkName "F") - (TySynEqn Nothing - [ ConT (mkName "Bool"), ConT (mkName "Int") - , ConT (mkName "Char")] - ( ConT (mkName "Char"))) + (TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "F")) (ConT (mkName "Bool"))) + (ConT (mkName "Int"))) (ConT (mkName "Char"))) + (ConT (mkName "Char"))) ] ) -- this is injective - a type variables mentioned on LHS is not mentioned on RHS @@ -50,10 +45,9 @@ $( return (TyVarSig (PlainTV (mkName "r"))) (Just $ InjectivityAnn (mkName "r") [mkName "a"])) , TySynInstD - (mkName "J") - (TySynEqn Nothing - [ ConT (mkName "Int"), VarT (mkName "b") ] - ( ConT (mkName "Int"))) + (TySynEqn Nothing (AppT (AppT (ConT (mkName "J")) (ConT (mkName "Int"))) + (VarT (mkName "b"))) + (ConT (mkName "Char"))) ] ) -- Closed type families @@ -70,18 +64,18 @@ $( return , KindedTV (mkName "c") StarT ] (TyVarSig (PlainTV (mkName "r"))) (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")])) - [ TySynEqn Nothing - [ ConT (mkName "Int"), ConT (mkName "Char") - , ConT (mkName "Bool")] - ( ConT (mkName "Bool")) - , TySynEqn Nothing - [ ConT (mkName "Int"), ConT (mkName "Char") - , ConT (mkName "Int")] - ( ConT (mkName "Bool")) - , TySynEqn Nothing - [ ConT (mkName "Bool"), ConT (mkName "Int") - , ConT (mkName "Int")] - ( ConT (mkName "Int")) + + [ TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "I")) (ConT (mkName "Int"))) + (ConT (mkName "Char"))) (ConT (mkName "Bool"))) + (ConT (mkName "Bool")) + + , TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "I")) (ConT (mkName "Int"))) + (ConT (mkName "Char"))) (ConT (mkName "Int"))) + (ConT (mkName "Bool")) + + , TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "I")) (ConT (mkName "Bool"))) + (ConT (mkName "Int"))) (ConT (mkName "Int"))) + (ConT (mkName "Int")) ] ] ) @@ -108,22 +102,19 @@ $( return (TyVarSig (PlainTV (mkName "r"))) (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b") ])) + , TySynInstD - (mkName "H") - (TySynEqn Nothing - [ ConT (mkName "Int"), ConT (mkName "Char") - , ConT (mkName "Bool")] - ( ConT (mkName "Bool"))) + (TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "H")) (ConT (mkName "Int"))) + (ConT (mkName "Char"))) (ConT (mkName "Bool"))) + (ConT (mkName "Bool"))) + , TySynInstD - (mkName "H") - (TySynEqn Nothing - [ ConT (mkName "Int"), ConT (mkName "Int") - , ConT (mkName "Int")] - ( ConT (mkName "Bool"))) + (TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "H")) (ConT (mkName "Int"))) + (ConT (mkName "Int"))) (ConT (mkName "Int"))) + (ConT (mkName "Bool"))) + , TySynInstD - (mkName "H") - (TySynEqn Nothing - [ ConT (mkName "Bool"), ConT (mkName "Int") - , ConT (mkName "Int")] - ( ConT (mkName "Int"))) + (TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "H")) (ConT (mkName "Bool"))) + (ConT (mkName "Int"))) (ConT (mkName "Int"))) + (ConT (mkName "Int"))) ] ) diff --git a/testsuite/tests/th/T6018th.stderr b/testsuite/tests/th/T6018th.stderr index 9566b1acd5..56e3f471f7 100644 --- a/testsuite/tests/th/T6018th.stderr +++ b/testsuite/tests/th/T6018th.stderr @@ -1,5 +1,5 @@ -T6018th.hs:104:4: +T6018th.hs:98:4: error: Type family equations violate injectivity annotation: - H Int Int Int = Bool -- Defined at T6018th.hs:104:4 - H Int Char Bool = Bool -- Defined at T6018th.hs:104:4 + H Int Int Int = Bool -- Defined at T6018th.hs:98:4 + H Int Char Bool = Bool -- Defined at T6018th.hs:98:4 diff --git a/testsuite/tests/th/T7532a.hs b/testsuite/tests/th/T7532a.hs index 8f686fe206..d28a59e87c 100644 --- a/testsuite/tests/th/T7532a.hs +++ b/testsuite/tests/th/T7532a.hs @@ -11,5 +11,5 @@ class C a where bang' :: DecsQ bang' = return [ InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int)) [ - DataInstD [] ''D Nothing [ConT ''Int] Nothing [ + DataInstD [] Nothing (AppT (ConT ''D) (ConT ''Int)) Nothing [ NormalC (mkName "T") []] []]] diff --git a/testsuite/tests/th/T8884.hs b/testsuite/tests/th/T8884.hs index cdc1a93c09..168f529ec4 100644 --- a/testsuite/tests/th/T8884.hs +++ b/testsuite/tests/th/T8884.hs @@ -11,16 +11,18 @@ type family Foo a = r | r -> a where type family Baz (a :: k) = (r :: k) | r -> a type instance Baz x = x -$( do FamilyI foo@(ClosedTypeFamilyD (TypeFamilyHead _ tvbs1 res1 m_kind1) eqs1) +$( do FamilyI foo@(ClosedTypeFamilyD (TypeFamilyHead _ tvbs1 res1 m_kind1) + [TySynEqn (Just bndrs1) (AppT _ lhs1) rhs1]) [] <- reify ''Foo FamilyI baz@(OpenTypeFamilyD (TypeFamilyHead _ tvbs2 res2 m_kind2)) - [inst@(TySynInstD _ eqn2)] <- reify ''Baz + [inst@(TySynInstD (TySynEqn (Just bndrs2) (AppT _ lhs2) rhs2))] <- reify ''Baz runIO $ putStrLn $ pprint foo runIO $ putStrLn $ pprint baz runIO $ putStrLn $ pprint inst runIO $ hFlush stdout return [ ClosedTypeFamilyD - (TypeFamilyHead (mkName "Foo'") tvbs1 res1 m_kind1) eqs1 + (TypeFamilyHead (mkName "Foo'") tvbs1 res1 m_kind1) + [TySynEqn (Just bndrs1) (AppT (ConT (mkName "Foo'")) lhs1) rhs1] , OpenTypeFamilyD (TypeFamilyHead (mkName "Baz'") tvbs2 res2 m_kind2) - , TySynInstD (mkName "Baz'") eqn2 ] ) + , TySynInstD (TySynEqn (Just bndrs2) (AppT (ConT (mkName "Baz'")) lhs2) rhs2)] ) diff --git a/testsuite/tests/th/TH_TyInstWhere2.hs b/testsuite/tests/th/TH_TyInstWhere2.hs index 47fedad8da..bfd0975b8f 100644 --- a/testsuite/tests/th/TH_TyInstWhere2.hs +++ b/testsuite/tests/th/TH_TyInstWhere2.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE PolyKinds, DataKinds, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE PolyKinds, DataKinds, TemplateHaskell, TypeFamilies, TypeApplications #-} module TH_TyInstWhere2 where -import Language.Haskell.TH +import Language.Haskell.TH hiding (Type) +import Data.Kind $( do { decs <- [d| type family F (a :: k) (b :: k) :: Bool where F a a = True @@ -10,4 +11,8 @@ $( do { decs <- [d| type family F (a :: k) (b :: k) :: Bool where ; reportWarning (pprint decs) ; return [] }) - +$( do { dec1 <- [d| type family F1 (a :: k) :: Type where + F1 @Type Int = Bool + F1 @Bool 'False = Char |] + ; reportWarning (pprint dec1) + ; return [] }) diff --git a/testsuite/tests/th/TH_TyInstWhere2.stderr b/testsuite/tests/th/TH_TyInstWhere2.stderr index 17caf61bad..717fb0e170 100644 --- a/testsuite/tests/th/TH_TyInstWhere2.stderr +++ b/testsuite/tests/th/TH_TyInstWhere2.stderr @@ -1,5 +1,10 @@ -TH_TyInstWhere2.hs:7:4: Warning: +TH_TyInstWhere2.hs:8:4: warning: type family F_0 (a_1 :: k_2) (b_3 :: k_2) :: GHC.Types.Bool where F_0 a_4 a_4 = 'GHC.Types.True F_0 a_5 b_6 = 'GHC.Types.False + +TH_TyInstWhere2.hs:14:4: warning: + type family F1_0 (a_1 :: k_2) :: * where + F1_0 @* GHC.Types.Int = GHC.Types.Bool + F1_0 @GHC.Types.Bool 'GHC.Types.False = GHC.Types.Char diff --git a/testsuite/tests/th/TH_reifyDecl1.hs b/testsuite/tests/th/TH_reifyDecl1.hs index c4ae3c065d..5437837611 100644 --- a/testsuite/tests/th/TH_reifyDecl1.hs +++ b/testsuite/tests/th/TH_reifyDecl1.hs @@ -1,8 +1,9 @@ -- test reification of data declarations -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies, TypeApplications, PolyKinds #-} module TH_reifyDecl1 where +import Data.Kind as K import System.IO import Language.Haskell.TH import Text.PrettyPrint.HughesPJ @@ -60,6 +61,10 @@ data family DF1 a data family DF2 a data instance DF2 Bool = DBool +data family DF3 (a :: k) +data instance DF3 @K.Type a = DF3Bool +data instance DF3 @(K.Type -> K.Type) b = DF3Char + $(return []) test :: () @@ -83,4 +88,5 @@ test = $(let ; display ''TF2 ; display ''DF1 ; display ''DF2 + ; display ''DF3 ; [| () |] }) diff --git a/testsuite/tests/th/TH_reifyDecl1.stderr b/testsuite/tests/th/TH_reifyDecl1.stderr index b18089b3a0..5ae01471f3 100644 --- a/testsuite/tests/th/TH_reifyDecl1.stderr +++ b/testsuite/tests/th/TH_reifyDecl1.stderr @@ -4,13 +4,13 @@ data TH_reifyDecl1.R (a_0 :: *) data TH_reifyDecl1.List (a_0 :: *) = TH_reifyDecl1.Nil | TH_reifyDecl1.Cons a_0 (TH_reifyDecl1.List a_0) -data TH_reifyDecl1.Tree (a_0 :: *) +data TH_reifyDecl1.Tree (a_0 :: k_1) = TH_reifyDecl1.Leaf | (TH_reifyDecl1.Tree a_0) TH_reifyDecl1.:+: (TH_reifyDecl1.Tree a_0) type TH_reifyDecl1.IntList = [GHC.Types.Int] newtype TH_reifyDecl1.Length = TH_reifyDecl1.Length GHC.Types.Int -Constructor from TH_reifyDecl1.Tree: TH_reifyDecl1.Leaf :: forall (a_0 :: *) . - TH_reifyDecl1.Tree a_0 +Constructor from TH_reifyDecl1.Tree: TH_reifyDecl1.Leaf :: forall (k_0 :: *) (a_1 :: k_0) . + TH_reifyDecl1.Tree a_1 Class op from TH_reifyDecl1.C1: TH_reifyDecl1.m1 :: forall (a_0 :: *) . TH_reifyDecl1.C1 a_0 => a_0 -> GHC.Types.Int class TH_reifyDecl1.C1 (a_0 :: *) @@ -18,13 +18,13 @@ class TH_reifyDecl1.C1 (a_0 :: *) class TH_reifyDecl1.C2 (a_0 :: *) where TH_reifyDecl1.m2 :: a_0 -> GHC.Types.Int instance TH_reifyDecl1.C2 GHC.Types.Int -class TH_reifyDecl1.C3 (a_0 :: *) - where type TH_reifyDecl1.AT1 (a_0 :: *) :: * - data TH_reifyDecl1.AT2 (a_0 :: *) :: * +class TH_reifyDecl1.C3 (a_0 :: k_1) + where type TH_reifyDecl1.AT1 (a_0 :: k_1) :: * + data TH_reifyDecl1.AT2 (a_0 :: k_1) :: * instance TH_reifyDecl1.C3 GHC.Types.Int -type family TH_reifyDecl1.AT1 (a_0 :: *) :: * +type family TH_reifyDecl1.AT1 (a_0 :: k_1) :: * type instance TH_reifyDecl1.AT1 GHC.Types.Int = GHC.Types.Bool -data family TH_reifyDecl1.AT2 (a_0 :: *) :: * +data family TH_reifyDecl1.AT2 (a_0 :: k_1) :: * data instance TH_reifyDecl1.AT2 GHC.Types.Int = TH_reifyDecl1.AT2Int type family TH_reifyDecl1.TF1 (a_0 :: *) :: * @@ -34,3 +34,9 @@ data family TH_reifyDecl1.DF1 (a_0 :: *) :: * data family TH_reifyDecl1.DF2 (a_0 :: *) :: * data instance TH_reifyDecl1.DF2 GHC.Types.Bool = TH_reifyDecl1.DBool +data family TH_reifyDecl1.DF3 (a_0 :: k_1) :: * +data instance forall (a_2 :: *). TH_reifyDecl1.DF3 (a_2 :: *) + = TH_reifyDecl1.DF3Bool +data instance forall (b_3 :: * -> + *). TH_reifyDecl1.DF3 (b_3 :: * -> *) + = TH_reifyDecl1.DF3Char diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 881ba81b18..7f420fb6e7 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -367,6 +367,8 @@ test('T11484', normal, compile, ['-v0']) test('T11629', normal, compile, ['-v0']) test('T8761', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) +test('T12045TH1', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) +test('T12045TH2', normal, compile, ['-v0']) test('T12130', [], multimod_compile, ['T12130', '-v0 ' + config.ghc_th_way_flags]) test('T12387', normal, compile_fail, ['-v0']) @@ -435,6 +437,7 @@ test('T15331', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('T15365', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('T15360a', normal, compile, ['']) test('T15360b', normal, compile_fail, ['']) +test('T15362', normal, compile_fail,['-v0']) # Note: T9693 should be only_ways(['ghci']) once it's fixed. test('T9693', expect_broken(9693), ghci_script, ['T9693.script']) test('T14471', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_compile/T10072.stderr b/testsuite/tests/typecheck/should_compile/T10072.stderr index 848c9158e8..ad7fe2602a 100644 --- a/testsuite/tests/typecheck/should_compile/T10072.stderr +++ b/testsuite/tests/typecheck/should_compile/T10072.stderr @@ -2,7 +2,9 @@ T10072.hs:3:31: error: • Found type wildcard ‘_’ standing for ‘b’ Where: ‘b’ is a rigid type variable bound by - the RULE "map/empty" at T10072.hs:3:1-47 + the RULE "map/empty" + at T10072.hs:3:1-47 To use the inferred type, enable PartialTypeSignatures - • In a RULE for ‘f’: a -> _ + • In the type ‘a -> _’ + In a RULE for ‘f’: a -> _ When checking the transformation rule "map/empty" diff --git a/testsuite/tests/typecheck/should_compile/T12045a.hs b/testsuite/tests/typecheck/should_compile/T12045a.hs new file mode 100644 index 0000000000..469a3307a7 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T12045a.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE PolyKinds, GADTs, TypeApplications, TypeInType, DataKinds, + RankNTypes, ConstraintKinds, TypeFamilies #-} + +module T12045a where + +import Data.Kind +import Data.Typeable + +data T (f :: k -> Type) a = MkT (f a) + +newtype TType f a= MkTType (T @Type f a) + +t1 :: TType Maybe Bool +t1 = MkTType (MkT (Just True)) + +t2 :: TType Maybe a +t2 = MkTType (MkT Nothing) + +data Nat = O | S Nat + +data T1 :: forall k1 k2. k1 -> k2 -> Type where + MkT1 :: T1 a b + +x :: T1 @_ @Nat False n +x = MkT1 + +-- test from trac 12045 +type Cat k = k -> k -> Type + +data FreeCat :: Cat k -> Cat k where + Nil :: FreeCat f a a + Cons :: f a b -> FreeCat f b c -> FreeCat f a c + +liftCat :: f a b -> FreeCat f a b +liftCat x = Cons x Nil + +data Node = Unit | N + +data NatGraph :: Cat Node where + One :: NatGraph Unit N + Succ :: NatGraph N N + +one :: (FreeCat @Node NatGraph) Unit N +one = liftCat One + +type Typeable1 = Typeable @(Type -> Type) +type Typeable2 = Typeable @(Type -> Type -> Type) +type Typeable3 = Typeable @(Cat Bool) + +type family F a where + F Type = Type -> Type + F (Type -> Type) = Type + F other = other + +data T2 :: F k -> Type + +foo :: T2 @Type Maybe -> T2 @(Type -> Type) Int -> Type +foo a b = undefined + +data family D (a :: k) +data instance D @Type a = DBool +data instance D @(Type -> Type) b = DChar + +class C a where + tc :: (D a) -> Int + +instance C Int where + tc DBool = 5 + +instance C Bool where + tc DBool = 6 + +instance C Maybe where + tc DChar = 7 + +-- Tests from D5229 +data P a = MkP +type MkPTrue = MkP @Bool + +type BoolEmpty = '[] @Bool + +type family F1 (a :: k) :: Type +type G2 (a :: Bool) = F1 @Bool a diff --git a/testsuite/tests/typecheck/should_compile/T14366.hs b/testsuite/tests/typecheck/should_compile/T14366.hs new file mode 100644 index 0000000000..56abad5d30 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T14366.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} + +module T14366 where +import Data.Kind +import Data.Type.Equality + +type family Cast (a :: Type) (b :: Type) (e :: a :~: b) (x :: a) :: b where + Cast _ _ Refl x = x + +type family F (a :: Type) :: Type where + F (a :: _) = a diff --git a/testsuite/tests/typecheck/should_compile/T15788.hs b/testsuite/tests/typecheck/should_compile/T15788.hs new file mode 100644 index 0000000000..732afb6932 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T15788.hs @@ -0,0 +1,11 @@ +{-# Language RankNTypes #-} +{-# Language GADTs #-} +{-# Language TypeApplications #-} +{-# Language PolyKinds #-} + +{-# Options_GHC -dcore-lint #-} +module T15788 where +import Data.Kind + +data A :: forall k. Type where + MkA :: A @k diff --git a/testsuite/tests/typecheck/should_compile/T15793.hs b/testsuite/tests/typecheck/should_compile/T15793.hs new file mode 100644 index 0000000000..4e96d83f10 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T15793.hs @@ -0,0 +1,18 @@ +{-# Language RankNTypes #-} +{-# Language TypeFamilies #-} +{-# Language TypeApplications #-} +{-# Language PolyKinds #-} + +module T15793 where +import Data.Kind + +type family + F1 (a :: Type) :: Type where + F1 a = Maybe a + +f1 :: F1 a +f1 = Nothing + +type family + F2 :: forall (a :: Type). Type where + F2 @a = Maybe a diff --git a/testsuite/tests/typecheck/should_compile/T15807a.hs b/testsuite/tests/typecheck/should_compile/T15807a.hs new file mode 100644 index 0000000000..7aa37358a8 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T15807a.hs @@ -0,0 +1,12 @@ +{-# Language RankNTypes #-} +{-# Language TypeApplications #-} +{-# Language PolyKinds #-} +{-# Language GADTs #-} + +module T15807a where +import Data.Kind + +data + App :: forall (f :: Type -> Type). Type -> Type + where + MkApp :: f a -> App @f a diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 3fed2a9466..9d1fc185d0 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -511,6 +511,7 @@ test('T11811', normal, compile, ['']) test('T11793', normal, compile, ['']) test('T11348', normal, compile, ['']) test('T11947', normal, compile, ['']) +test('T12045a', normal, compile, ['']) test('T12064', [], multimod_compile, ['T12064', '-v0']) test('ExPat', normal, compile, ['']) test('ExPatFail', normal, compile_fail, ['']) @@ -606,6 +607,7 @@ test('T14590', normal, compile, ['-fdefer-type-errors -fno-max-valid-hole-fits'] # output we expect (T13032.stderr). test('T13032', omit_ways(['hpc', 'profasm']), compile, ['']) test('T14273', normal, compile, ['-fdefer-type-errors -fno-max-valid-hole-fits']) +test('T14366', normal, compile, ['']) test('T14732', normal, compile, ['']) test('T14774', [], run_command, ['$MAKE -s --no-print-directory T14774']) test('T14763', normal, compile, ['']) @@ -626,6 +628,9 @@ test('T15050', normal, compile, ['']) test('T14735', normal, compile, ['']) test('T15180', normal, compile, ['']) test('T15232', normal, compile, ['']) +test('T15788', normal, compile, ['']) +test('T15793', normal, compile, ['']) +test('T15807a', normal, compile, ['']) test('T13833', normal, compile, ['']) test('T14185', expect_broken(14185), compile, ['']) diff --git a/testsuite/tests/typecheck/should_fail/T12045b.hs b/testsuite/tests/typecheck/should_fail/T12045b.hs new file mode 100644 index 0000000000..19191c05f1 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T12045b.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TypeApplications #-} + +module T12045b where + +import Data.Kind + +x :: Int @Type +x = 5 diff --git a/testsuite/tests/typecheck/should_fail/T12045b.stderr b/testsuite/tests/typecheck/should_fail/T12045b.stderr new file mode 100644 index 0000000000..fcb65b133d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T12045b.stderr @@ -0,0 +1,5 @@ + +T12045b.hs:7:6: error: + • Cannot apply function of kind ‘*’ + to visible kind argument ‘Type’ + • In the type signature: x :: Int @Type diff --git a/testsuite/tests/typecheck/should_fail/T12045c.hs b/testsuite/tests/typecheck/should_fail/T12045c.hs new file mode 100644 index 0000000000..56c2d15abc --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T12045c.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PolyKinds, TypeApplications, KindSignatures, DataKinds, GADTs + , TypeFamilies, RankNTypes #-} + +module T12045c where +import Data.Kind + +type family F a where + F @Type a = Bool + F @(Type -> Type) b = Char diff --git a/testsuite/tests/typecheck/should_fail/T12045c.stderr b/testsuite/tests/typecheck/should_fail/T12045c.stderr new file mode 100644 index 0000000000..86a51a49ac --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T12045c.stderr @@ -0,0 +1,5 @@ + +T12045c.hs:8:3: error: + • Cannot apply function of kind ‘k0 -> k1’ + to visible kind argument ‘Type’ + • In the type family declaration for ‘F’ diff --git a/testsuite/tests/typecheck/should_fail/T13819.stderr b/testsuite/tests/typecheck/should_fail/T13819.stderr index ab818f399b..89959cba39 100644 --- a/testsuite/tests/typecheck/should_fail/T13819.stderr +++ b/testsuite/tests/typecheck/should_fail/T13819.stderr @@ -1,8 +1,8 @@ T13819.hs:12:10: error: - • Couldn't match type ‘w0 -> A w0’ with ‘A a’ + • Couldn't match type ‘_0 -> A _0’ with ‘A a’ Expected type: a -> A a - Actual type: (w1 -> WrappedMonad A w2) (w0 -> A w0) + Actual type: (_1 -> WrappedMonad A _2) (_0 -> A _0) • In the expression: pure @(_ -> WrappedMonad A _) @(_ -> A _) pure In an equation for ‘pure’: pure = pure @(_ -> WrappedMonad A _) @(_ -> A _) pure diff --git a/testsuite/tests/typecheck/should_fail/T15592a.hs b/testsuite/tests/typecheck/should_fail/T15592a.hs new file mode 100644 index 0000000000..1f28c73d2a --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15592a.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE PolyKinds, TypeApplications, DataKinds, RankNTypes #-} + +module T15592 where +import Data.Proxy + +data VisProxy k (a :: k) = MkVP +class D (a :: Proxy j) (b :: Proxy k) c where + meth1 :: forall z. D @j @k a b z => z -> Proxy '(a, b) + meth2 :: Proxy k j -> Proxy '(a, b, c) diff --git a/testsuite/tests/typecheck/should_fail/T15592a.stderr b/testsuite/tests/typecheck/should_fail/T15592a.stderr new file mode 100644 index 0000000000..5002b4771d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15592a.stderr @@ -0,0 +1,8 @@ + +T15592a.hs:8:22: error: + • Cannot apply function of kind ‘Proxy j + -> Proxy k -> k2 -> Constraint’ + to visible kind argument ‘j’ + • In the type signature: + meth1 :: forall z. D @j @k a b z => z -> Proxy '(a, b) + In the class declaration for ‘D’ diff --git a/testsuite/tests/typecheck/should_fail/T15797.hs b/testsuite/tests/typecheck/should_fail/T15797.hs new file mode 100644 index 0000000000..eadd8cb972 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15797.hs @@ -0,0 +1,26 @@ +{-# Language RankNTypes #-} +{-# Language TypeFamilies #-} +{-# Language ScopedTypeVariables #-} +{-# Language TypeApplications #-} +{-# Language DataKinds #-} +{-# Language PolyKinds #-} +{-# Language TypeOperators #-} +{-# Language GADTs #-} +{-# Language FlexibleInstances #-} + +module T15797 where +import Data.Kind + +class Ríki (obj :: Type) where + type Obj :: obj -> Constraint + type Obj = Bæ @obj + +class Bæ (a :: k) +instance Bæ @k (a :: k) + +data + EQ :: forall ob. ob -> ob -> Type where + EQ :: EQ a a + +instance + Ríki (EQ @ob) diff --git a/testsuite/tests/typecheck/should_fail/T15797.stderr b/testsuite/tests/typecheck/should_fail/T15797.stderr new file mode 100644 index 0000000000..04c2a5fc50 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15797.stderr @@ -0,0 +1,6 @@ + +T15797.hs:26:9: error: + • Expecting two more arguments to ‘EQ @ob’ + Expected a type, but ‘EQ @ob’ has kind ‘ob -> ob -> *’ + • In the first argument of ‘Ríki’, namely ‘(EQ @ob)’ + In the instance declaration for ‘Ríki (EQ @ob)’ diff --git a/testsuite/tests/typecheck/should_fail/T15799.hs b/testsuite/tests/typecheck/should_fail/T15799.hs new file mode 100644 index 0000000000..fe692620a6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15799.hs @@ -0,0 +1,47 @@ +{-# Language CPP #-} +{-# Language DataKinds #-} +{-# Language RankNTypes #-} +{-# Language PatternSynonyms #-} +{-# Language TypeOperators #-} +{-# Language PolyKinds #-} +{-# Language GADTs #-} +{-# Language TypeFamilies #-} +{-# Language TypeApplications #-} +{-# Language FlexibleContexts #-} +{-# Language FlexibleInstances #-} +{-# Language InstanceSigs #-} + +module T15799 where +import qualified GHC.TypeLits as TypeLits +import GHC.TypeLits (Nat, KnownNat) +import Data.Kind + +data Op obj = Op obj + +type family + UnOp (op_a :: Op obj) :: obj where + UnOp ('Op obj) = obj + +class + Ríki (obj :: Type) where + type (-->) :: Op obj -> obj -> Type + type (<--) :: obj -> Op obj -> Type + + unop :: forall (a :: obj) (b :: obj). (a <-- 'Op b) -> ('Op b --> a) + +data (<=) :: Op Nat -> Nat -> Type where + LessThan :: (KnownNat (UnOp op_a), KnownNat b, UnOp op_a TypeLits.<= b) + => (op_a <= b) + +newtype (>=) :: Nat -> Op Nat -> Type where + Y :: (a <= b) -> (b >= a) + +instance Ríki Nat where + type (-->) = (<=) + type (<--) = (>=) + + unop :: (a >= b) -> (b <= a) + unop GreaterThan = LessThan + +pattern GreaterThan :: () => (KnownNat (UnOp b), KnownNat a, UnOp b <= a) => a >= b +pattern GreaterThan = Y LessThan diff --git a/testsuite/tests/typecheck/should_fail/T15799.stderr b/testsuite/tests/typecheck/should_fail/T15799.stderr new file mode 100644 index 0000000000..f93e043471 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15799.stderr @@ -0,0 +1,7 @@ + +T15799.hs:46:62: error: + • Expected kind ‘Op Nat’, but ‘UnOp b’ has kind ‘Nat’ + • In the first argument of ‘(<=)’, namely ‘UnOp b’ + +T15799.hs:46:62: error: + Expected a constraint, but ‘UnOp b <= a’ has kind ‘*’ diff --git a/testsuite/tests/typecheck/should_fail/T15801.hs b/testsuite/tests/typecheck/should_fail/T15801.hs new file mode 100644 index 0000000000..9b39408aef --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15801.hs @@ -0,0 +1,53 @@ +{-# Language CPP #-} +{-# Language QuantifiedConstraints #-} +{-# Language TypeApplications #-} +{-# Language PolyKinds #-} +{-# Language TypeOperators #-} +{-# Language DataKinds #-} +{-# Language TypeFamilies #-} +{-# Language TypeSynonymInstances #-} +{-# Language FlexibleInstances #-} +{-# Language GADTs #-} +{-# Language UndecidableInstances #-} +{-# Language MultiParamTypeClasses #-} +{-# Language FlexibleContexts #-} + +module Bug where +import Data.Coerce +import Data.Kind + +type Cat ob = ob -> ob -> Type + +type Obj = Type + +class Coercible (op_a --> b) (b <-- op_a) => (op_a -#- b) +instance Coercible (op_a --> b) (b <-- op_a) => (op_a -#- b) + +class (forall (op_a :: obj) (b :: obj). op_a -#- b) => OpOpNoOp obj +instance (forall (op_a :: obj) (b :: obj). op_a -#- b) => OpOpNoOp obj + +class + Ríki (obj :: Obj) where + type (-->) :: obj -> obj -> Type + + ið :: a --> (a::obj) + +class + OpOpNoOp obj + => + OpRíki (obj :: Obj) where + type (<--) :: obj -> obj -> Type + +data Op a = Op a + +type family UnOp op where UnOp ('Op obj) = obj + +newtype Y :: Cat (Op a) where + Y :: (UnOp b --> UnOp a) -> Y a b + +instance Ríki Type where + type (-->) = (->) + ið x = x + +instance OpRíki (Op Type) where + type (<--) @(Op Type) = Y @Type diff --git a/testsuite/tests/typecheck/should_fail/T15801.stderr b/testsuite/tests/typecheck/should_fail/T15801.stderr new file mode 100644 index 0000000000..887c0f2a35 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15801.stderr @@ -0,0 +1,6 @@ + +T15801.hs:52:10: error: + • Couldn't match representation of type ‘UnOp op_a -> UnOp b’ + with that of ‘op_a --> b’ + arising from the superclasses of an instance declaration + • In the instance declaration for ‘OpRíki (Op *)’ diff --git a/testsuite/tests/typecheck/should_fail/T15807.hs b/testsuite/tests/typecheck/should_fail/T15807.hs new file mode 100644 index 0000000000..fa121d608e --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15807.hs @@ -0,0 +1,12 @@ +{-# Language RankNTypes #-} +{-# Language TypeApplications #-} +{-# Language PolyKinds #-} +{-# Language GADTs #-} + +module T15807 where +import Data.Kind + +data + App :: forall (f :: k -> Type). k -> Type + where + MkApp :: f a -> App @f a diff --git a/testsuite/tests/typecheck/should_fail/T15807.stderr b/testsuite/tests/typecheck/should_fail/T15807.stderr new file mode 100644 index 0000000000..e24f5bb855 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15807.stderr @@ -0,0 +1,16 @@ + +T15807.hs:12:24: error: + • Expecting one more argument to ‘f’ + Expected a type, but ‘f’ has kind ‘k0 -> *’ + • In the first argument of ‘App’, namely ‘f’ + In the type ‘App @f a’ + In the definition of data constructor ‘MkApp’ + +T15807.hs:12:26: error: + • Couldn't match kind ‘*’ with ‘k0 -> *’ + When matching kinds + k0 :: * + f :: k0 -> * + • In the second argument of ‘App’, namely ‘a’ + In the type ‘App @f a’ + In the definition of data constructor ‘MkApp’ diff --git a/testsuite/tests/typecheck/should_fail/T15816.hs b/testsuite/tests/typecheck/should_fail/T15816.hs new file mode 100644 index 0000000000..a9958ee38c --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15816.hs @@ -0,0 +1,8 @@ +{-# Language TypeApplications #-} +{-# Language TypeFamilies #-} + +module T15816 where +import Data.Kind + +data family U +data instance U @Int diff --git a/testsuite/tests/typecheck/should_fail/T15816.stderr b/testsuite/tests/typecheck/should_fail/T15816.stderr new file mode 100644 index 0000000000..90bf2122d6 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/T15816.stderr @@ -0,0 +1,5 @@ + +T15816.hs:8:1: error: + • Cannot apply function of kind ‘*’ + to visible kind argument ‘Int’ + • In the data instance declaration for ‘U’ diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index f0afa0d3a9..bac4d6b14e 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -404,6 +404,8 @@ test('T11990b', normal, compile_fail, ['']) test('T12035', [], multimod_compile_fail, ['T12035', '-v0']) test('T12035j', [extra_files(['T12035.hs', 'T12035a.hs', 'T12035.hs-boot']), req_smp], multimod_compile_fail, ['T12035', '-j2 -v0']) +test('T12045b', normal, compile_fail, ['']) +test('T12045c', normal, compile_fail, ['']) test('T12063', [expect_broken(12063)], multimod_compile_fail, ['T12063', '-v0']) test('T12083a', normal, compile_fail, ['']) test('T12083b', normal, compile_fail, ['']) @@ -486,10 +488,16 @@ test('T15523', normal, compile_fail, ['-O']) test('T15527', normal, compile_fail, ['']) test('T15552', normal, compile, ['']) test('T15552a', normal, compile_fail, ['']) +test('T15592a', normal, compile_fail, ['']) test('T15629', normal, compile_fail, ['']) test('T15767', normal, compile_fail, ['']) test('T15648', [extra_files(['T15648a.hs'])], multimod_compile_fail, ['T15648', '-v0 -fprint-equality-relations']) test('T15796', normal, compile_fail, ['']) +test('T15807', normal, compile_fail, ['']) test('T15954', normal, compile_fail, ['']) test('T15962', normal, compile_fail, ['']) test('T16074', normal, compile_fail, ['']) +test('T15797', normal, compile_fail, ['']) +test('T15799', normal, compile_fail, ['']) +test('T15801', normal, compile_fail, ['']) +test('T15816', normal, compile_fail, ['']) diff --git a/utils/haddock b/utils/haddock -Subproject 6414b46e1ac8b63cad20d662311788a80e3b29b +Subproject 21e4f3fa6f73a9b25f3deed80da0e56024238ea |