summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authormynguyen <mnguyen1@brynmawr.edu>2018-12-18 11:52:26 -0500
committerRichard Eisenberg <rae@cs.brynmawr.edu>2019-01-03 08:57:32 -0500
commit17bd163566153babbf51adaff8397f948ae363ca (patch)
treeef25e933481def276de4cdcad77eb4a34a76444b /compiler
parent6e4e63764aaf558cf177c2a9c2da345b2a360ea6 (diff)
downloadhaskell-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
Diffstat (limited to 'compiler')
-rw-r--r--compiler/deSugar/DsMeta.hs108
-rw-r--r--compiler/hieFile/HieAst.hs18
-rw-r--r--compiler/hsSyn/Convert.hs243
-rw-r--r--compiler/hsSyn/HsBinds.hs12
-rw-r--r--compiler/hsSyn/HsDecls.hs2
-rw-r--r--compiler/hsSyn/HsExtension.hs2
-rw-r--r--compiler/hsSyn/HsInstances.hs4
-rw-r--r--compiler/hsSyn/HsTypes.hs134
-rw-r--r--compiler/hsSyn/HsUtils.hs2
-rw-r--r--compiler/parser/Parser.y30
-rw-r--r--compiler/parser/RdrHsSyn.hs112
-rw-r--r--compiler/prelude/THNames.hs38
-rw-r--r--compiler/rename/RnSource.hs31
-rw-r--r--compiler/rename/RnTypes.hs113
-rw-r--r--compiler/typecheck/TcDeriv.hs2
-rw-r--r--compiler/typecheck/TcExpr.hs26
-rw-r--r--compiler/typecheck/TcHsType.hs437
-rw-r--r--compiler/typecheck/TcInstDcls.hs2
-rw-r--r--compiler/typecheck/TcSigs.hs46
-rw-r--r--compiler/typecheck/TcSimplify.hs17
-rw-r--r--compiler/typecheck/TcSplice.hs15
-rw-r--r--compiler/typecheck/TcTyClsDecls.hs14
-rw-r--r--compiler/types/TyCoRep.hs7
23 files changed, 889 insertions, 526 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
View Lorry Controller Status