summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
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