Commit 17bd1635 authored by My Nguyen's avatar My Nguyen Committed by Richard Eisenberg

Visible kind application

Summary:
This patch implements visible kind application (GHC Proposal 15/#12045), as well as #15360 and #15362.
It also refactors unnamed wildcard handling, and requires that type equations in type families in Template Haskell be
written with full type on lhs. PartialTypeSignatures are on and warnings are off automatically with visible kind
application, just like in term-level.

There are a few remaining issues with this patch, as documented in
ticket #16082.

Includes a submodule update for Haddock.

Test Plan: Tests T12045a/b/c/TH1/TH2, T15362, T15592a

Reviewers: simonpj, goldfire, bgamari, alanz, RyanGlScott, Iceland_jack

Subscribers: ningning, Iceland_jack, RyanGlScott, int-index, rwbarton, mpickering, carter

GHC Trac Issues: `#12045`, `#15362`, `#15592`, `#15788`, `#15793`, `#15795`, `#15797`, `#15799`, `#15801`, `#15807`, `#15816`

Differential Revision: https://phabricator.haskell.org/D5229
parent 6e4e6376
Pipeline #815 passed with stages
in 261 minutes and 44 seconds
This diff is collapsed.
......@@ -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
......
This diff is collapsed.
......@@ -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'
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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)
......
......@@ -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)
......
This diff is collapsed.
......@@ -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,
......
......@@ -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)
......
This diff is collapsed.
......@@ -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
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
This diff is collapsed.
......@@ -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]
......
......@@ -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:
......
......@@ -677,8 +677,15 @@ simplifyInfer :: TcLevel -- Used when generating the constraints