summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/DsMeta.hs6
-rw-r--r--compiler/hieFile/HieAst.hs4
-rw-r--r--compiler/hsSyn/Convert.hs9
-rw-r--r--compiler/hsSyn/HsTypes.hs19
-rw-r--r--compiler/parser/Parser.y2
-rw-r--r--compiler/parser/RdrHsSyn.hs69
-rw-r--r--compiler/rename/RnTypes.hs10
-rw-r--r--compiler/typecheck/TcExpr.hs24
-rw-r--r--compiler/typecheck/TcHsType.hs9
-rw-r--r--testsuite/tests/ghc-api/annotations/Makefile4
-rw-r--r--testsuite/tests/ghc-api/annotations/T16236.stdout85
-rw-r--r--testsuite/tests/ghc-api/annotations/Test16236.hs20
-rw-r--r--testsuite/tests/ghc-api/annotations/all.T2
-rw-r--r--testsuite/tests/parser/should_compile/DumpParsedAst.stderr3
-rw-r--r--testsuite/tests/parser/should_compile/DumpRenamedAst.stderr3
15 files changed, 199 insertions, 70 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 02b6cbc21e..a8a4fb6b40 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -596,9 +596,9 @@ 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 (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)
diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs
index b6b5f0ccb7..0040b30cde 100644
--- a/compiler/hieFile/HieAst.hs
+++ b/compiler/hieFile/HieAst.hs
@@ -332,7 +332,7 @@ instance (HasLoc a, HasLoc b) => HasLoc (FamEqn s a b) where
loc _ = noSrcSpan
instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where
loc (HsValArg tm) = loc tm
- loc (HsTypeArg ty) = loc ty
+ loc (HsTypeArg _ ty) = loc ty
loc (HsArgPar sp) = sp
instance HasLoc (HsDataDefn GhcRn) where
@@ -1459,7 +1459,7 @@ instance ToHie (TScoped (LHsType GhcRn)) where
instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where
toHie (HsValArg tm) = toHie tm
- toHie (HsTypeArg ty) = toHie ty
+ toHie (HsTypeArg _ ty) = toHie ty
toHie (HsArgPar sp) = pure $ locOnly sp
instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 8672a662cc..1a801bb1b1 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -1520,8 +1520,8 @@ mk_apps head_ty type_args = do
case arg of
HsValArg ty -> do p_ty <- add_parens ty
mk_apps (HsAppTy noExt phead_ty p_ty) args
- HsTypeArg ki -> do p_ki <- add_parens ki
- mk_apps (HsAppKindTy noExt phead_ty p_ki) args
+ HsTypeArg l ki -> do p_ki <- add_parens ki
+ mk_apps (HsAppKindTy l phead_ty p_ki) args
HsArgPar _ -> mk_apps (HsParTy noExt phead_ty) args
go type_args
@@ -1533,7 +1533,7 @@ mk_apps head_ty type_args = do
wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs
wrap_tyarg (HsValArg ty) = HsValArg $ parenthesizeHsType appPrec ty
-wrap_tyarg (HsTypeArg ki) = HsTypeArg $ parenthesizeHsType appPrec ki
+wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki
wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized
-- ---------------------------------------------------------------------
@@ -1570,7 +1570,8 @@ 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 (HsValArg a':as') }
- go (AppKindT ty ki) as' = do { ki' <- cvtKind ki; go ty (HsTypeArg ki':as') }
+ go (AppKindT ty ki) as' = do { ki' <- cvtKind ki
+ ; go ty (HsTypeArg noSrcSpan ki':as') }
go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }
go f as = return (f,as)
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 73443587fe..5eeca6eac2 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -710,7 +710,7 @@ type instance XIParamTy (GhcPass _) = NoExt
type instance XStarTy (GhcPass _) = NoExt
type instance XKindSig (GhcPass _) = NoExt
-type instance XAppKindTy (GhcPass _) = NoExt
+type instance XAppKindTy (GhcPass _) = SrcSpan -- Where the `@` lives
type instance XSpliceTy GhcPs = NoExt
type instance XSpliceTy GhcRn = NoExt
@@ -1045,10 +1045,10 @@ mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]
-> LHsType (GhcPass p)
mkHsAppTys = foldl' mkHsAppTy
-mkHsAppKindTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
+mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
-> LHsType (GhcPass p)
-mkHsAppKindTy ty k
- = addCLoc ty k (HsAppKindTy noExt ty k)
+mkHsAppKindTy ext ty k
+ = addCLoc ty k (HsAppKindTy ext ty k)
{-
************************************************************************
@@ -1107,7 +1107,8 @@ hsTyGetAppHead_maybe = go
-- 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)
+ | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty)
+ -- SrcSpan is location of the `@`
| HsArgPar SrcSpan -- See Note [HsArgPar]
numVisibleArgs :: [HsArg tm ty] -> Arity
@@ -1119,9 +1120,9 @@ numVisibleArgs = count is_vis
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
+ 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
@@ -1142,7 +1143,7 @@ splitHsAppTys e = go (noLoc e) []
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 _ (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)
go (L sp (HsParTy _ f)) as = go f (HsArgPar sp : as)
go f as = (f,as)
--------------------------------
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index e33b715b51..c5b5c5f118 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1989,7 +1989,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) }
+ | TYPEAPP atype { sLL $1 $> $ (TyElKindApp (comb2 $1 $2) $2) }
| qtyconop { sL1 $1 $ TyElOpr (unLoc $1) }
| tyvarop { sL1 $1 $ TyElOpr (unLoc $1) }
| SIMPLEQUOTE qconop {% ams (sLL $1 $> $ TyElOpr (unLoc $2))
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 0766b04ada..f9b511dd26 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -831,7 +831,8 @@ checkTyVars pp_what equals_or_where tc tparms
= do { (tvs, anns) <- fmap unzip $ mapM check tparms
; return (mkHsQTvs tvs, concat anns) }
where
- check (HsTypeArg ki@(L loc _)) = Left (loc,
+ check (HsTypeArg _ ki@(L loc _))
+ = Left (loc,
vcat [ text "Unexpected type application" <+>
text "@" <> ppr ki
, text "In the" <+> pp_what <+>
@@ -967,7 +968,7 @@ checkTyClHdr is_cls ty
| 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 (HsValArg t2:acc) ann fix
- go _ (HsAppKindTy _ ty ki) acc ann fix = goL ty (HsTypeArg ki:acc) ann fix
+ go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix
go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix
= return (cL l (nameRdrName tup_name), map HsValArg ts, fix, ann)
where
@@ -1374,10 +1375,26 @@ isFunLhs e = go e [] []
-- | Either an operator or an operand.
data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)
| TyElKindApp SrcSpan (LHsType GhcPs)
+ -- See Note [TyElKindApp SrcSpan interpretation]
| TyElTilde | TyElBang
| TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)
| TyElDocPrev HsDocString
+
+{- Note [TyElKindApp SrcSpan interpretation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+A TyElKindApp captures type application written in haskell as
+
+ @ Foo
+
+where Foo is some type.
+
+The SrcSpan reflects both elements, and there are AnnAt and AnnVal API
+Annotations attached to this SrcSpan for the specific locations of
+each within it.
+-}
+
instance Outputable TyEl where
ppr (TyElOpr name) = ppr name
ppr (TyElOpd ty) = ppr ty
@@ -1458,12 +1475,11 @@ 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 { (addAccAnns, acc') <- eitherToP $ mergeOpsAcc acc
+ then do { 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
@@ -1499,8 +1515,7 @@ 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 do { (_, a) <- eitherToP (mergeOpsAcc acc)
- -- no need to add annotations since it fails anyways!
+ then do { a <- eitherToP (mergeOpsAcc acc)
; failOpStrictnessCompound (cL l str) (ops_acc a) }
else failOpStrictnessPosition (cL l str)
@@ -1511,8 +1526,7 @@ 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 { (addAccAnns, acc') <- eitherToP (mergeOpsAcc acc)
- ; addAccAnns
+ else do { acc' <- eitherToP (mergeOpsAcc acc)
; go (k + 1) [] (\c -> mkLHsOpTy c (cL l op) (ops_acc acc')) xs }
where
isTyElOpd (dL->L _ (TyElOpd _)) = True
@@ -1534,33 +1548,32 @@ mergeOps all_xs = go (0 :: Int) [] id all_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
+ go k acc ops_acc ((dL->L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs
-- clause [end]
-- See Note [Non-empty 'acc' in mergeOps clause [end]]
- go _ acc ops_acc [] = do { (addAccAnns, acc') <- eitherToP (mergeOpsAcc acc)
- ; addAccAnns
+ go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc)
; return (ops_acc acc') }
go _ _ _ _ = panic "mergeOps.go: Impossible Match"
-- due to #15884
-mergeOpsAcc :: [HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs)]
- -> Either (SrcSpan, SDoc) (P (), LHsType GhcPs)
+mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
+ -> Either (SrcSpan, SDoc) (LHsType GhcPs)
mergeOpsAcc [] = panic "mergeOpsAcc: empty input"
-mergeOpsAcc (HsTypeArg (_, L loc ki):_)
+mergeOpsAcc (HsTypeArg _ (L loc ki):_)
= Left (loc, text "Unexpected type application:" <+> ppr ki)
-mergeOpsAcc (HsValArg ty : xs) = go1 (pure ()) ty xs
+mergeOpsAcc (HsValArg ty : xs) = go1 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
+ go1 :: LHsType GhcPs
+ -> [HsArg (LHsType GhcPs) (LHsKind GhcPs)]
+ -> Either (SrcSpan, SDoc) (LHsType GhcPs)
+ go1 lhs [] = Right lhs
+ go1 lhs (x:xs) = case x of
+ HsValArg ty -> go1 (mkHsAppTy lhs ty) xs
+ HsTypeArg loc ki -> let ty = mkHsAppKindTy loc lhs ki
+ in go1 ty xs
+ HsArgPar _ -> go1 lhs xs
mergeOpsAcc (HsArgPar _: xs) = mergeOpsAcc xs
{- Note [Impossible case in mergeOps clause [unpk]]
@@ -1623,19 +1636,19 @@ pInfixSide (el:xs1)
| Just t1 <- pLHsTypeArg el
= go [t1] xs1
where
- go :: [HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs)]
+ go :: [HsArg (LHsType GhcPs) (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)
+ Right acc' -> Just (acc', pure (), xs)
pInfixSide _ = Nothing
-pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (SrcSpan, LHsKind GhcPs))
+pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs))
pLHsTypeArg (dL->L l (TyElOpd a)) = Just (HsValArg (L l a))
-pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg (l,a))
+pLHsTypeArg (dL->L _ (TyElKindApp l a)) = Just (HsTypeArg l a)
pLHsTypeArg _ = Nothing
pDocPrev :: [Located TyEl] -> (Maybe LHsDocString, [Located TyEl])
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 3703f1ac63..1eaf89a7b9 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -486,9 +486,9 @@ rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
rnLHsTypeArg ctxt (HsValArg ty)
= do { (tys_rn, fvs) <- rnLHsType ctxt ty
; return (HsValArg tys_rn, fvs) }
-rnLHsTypeArg ctxt (HsTypeArg ki)
+rnLHsTypeArg ctxt (HsTypeArg l ki)
= do { (kis_rn, fvs) <- rnLHsKind ctxt ki
- ; return (HsTypeArg kis_rn, fvs) }
+ ; return (HsTypeArg l kis_rn, fvs) }
rnLHsTypeArg _ (HsArgPar sp)
= return (HsArgPar sp, emptyFVs)
@@ -636,12 +636,12 @@ rnHsTyKi env (HsAppTy _ ty1 ty2)
; (ty2', fvs2) <- rnLHsTyKi env ty2
; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }
-rnHsTyKi env (HsAppKindTy _ ty k)
+rnHsTyKi env (HsAppKindTy l ty k)
= do { kind_app <- xoptM LangExt.TypeApplications
; unless kind_app (addErr (typeAppErr "kind" k))
; (ty', fvs1) <- rnLHsTyKi env ty
; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k
- ; return (HsAppKindTy noExt ty' k', fvs1 `plusFV` fvs2) }
+ ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) }
rnHsTyKi env t@(HsIParamTy _ n ty)
= do { notInKinds env t
@@ -1632,7 +1632,7 @@ inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
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 (HsTypeArg _ ki) acc = extract_lty KindLevel ki acc
extract_tyarg (HsArgPar _) acc = acc
extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 63cb35194c..0e090085ad 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1099,10 +1099,10 @@ wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn)
=> LHsExpr (GhcPass id)
-> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)]
-> LHsExpr (GhcPass id)
-wrapHsArgs f [] = f
-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
+wrapHsArgs f [] = f
+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
isHsValArg :: HsArg tm ty -> Bool
isHsValArg (HsValArg {}) = True
@@ -1143,7 +1143,7 @@ tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty
= tcApp m_herald fun (HsValArg arg1 : args) res_ty
tcApp m_herald (L _ (HsAppType _ fun ty1)) args res_ty
- = tcApp m_herald fun (HsTypeArg ty1 : args) res_ty
+ = tcApp m_herald fun (HsTypeArg noSrcSpan ty1 : args) res_ty
tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty
| Ambiguous _ lbl <- fld_lbl -- Still ambiguous
@@ -1177,7 +1177,7 @@ tcApp m_herald fun@(L loc (HsVar _ (L _ fun_id))) args res_ty
where
n_val_args = count isHsValArg args
-tcApp _ (L loc (ExplicitList _ Nothing [])) [HsTypeArg ty_arg] res_ty
+tcApp _ (L loc (ExplicitList _ Nothing [])) [HsTypeArg _ ty_arg] res_ty
-- See Note [Visible type application for the empty list constructor]
= do { ty_arg' <- tcHsTypeApp ty_arg liftedTypeKind
; let list_ty = TyConApp listTyCon [ty_arg']
@@ -1233,7 +1233,7 @@ mk_app_msg fun args = sep [ text "The" <+> text what <+> quotes (ppr expr)
-- Include visible type arguments (but not other arguments) in the herald.
-- See Note [Herald for matchExpectedFunTys] in TcUnify.
expr = mkHsAppTypes fun type_app_args
- type_app_args = [hs_ty | HsTypeArg hs_ty <- args]
+ type_app_args = [hs_ty | HsTypeArg _ hs_ty <- args]
mk_op_msg :: LHsExpr GhcRn -> SDoc
mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"
@@ -1303,7 +1303,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
; return (inner_wrap, HsArgPar sp : args', res_ty)
}
- go acc_args n fun_ty (HsTypeArg hs_ty_arg : args)
+ go acc_args n fun_ty (HsTypeArg l hs_ty_arg : args)
= do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty
-- wrap1 :: fun_ty "->" upsilon_ty
; case tcSplitForAllTy_maybe upsilon_ty of
@@ -1334,7 +1334,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
-- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty
; let inst_wrap = mkWpTyApps [ty_arg]
; return ( inner_wrap <.> inst_wrap <.> wrap1
- , HsTypeArg hs_ty_arg : args'
+ , HsTypeArg l hs_ty_arg : args'
, res_ty ) }
_ -> ty_app_err upsilon_ty hs_ty_arg }
@@ -1915,7 +1915,7 @@ tcTagToEnum loc fun_name args res_ty
(before, _:after) = break isHsValArg args
; arg <- case filterOut isArgPar args of
- [HsTypeArg hs_ty_arg, HsValArg term_arg]
+ [HsTypeArg _ hs_ty_arg, HsValArg term_arg]
-> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind
; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty
-- other than influencing res_ty, we just
@@ -1973,8 +1973,8 @@ too_many_args fun args
2 (sep (map pp args))
where
pp (HsValArg e) = ppr e
- pp (HsTypeArg (HsWC { hswc_body = L _ t })) = pprHsType t
- pp (HsTypeArg (XHsWildCardBndrs _)) = panic "too_many_args"
+ pp (HsTypeArg _ (HsWC { hswc_body = L _ t })) = pprHsType t
+ pp (HsTypeArg _ (XHsWildCardBndrs _)) = panic "too_many_args"
pp (HsArgPar _) = empty
diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index e5d0aa6838..7a63202f96 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -993,7 +993,7 @@ tcInferApps mode orig_hs_ty fun_ty orig_fun_ki orig_hs_args
(HsArgPar _ : args, _) -> go n subst fun fun_ki args
-- Next argument is a kind application (fun @ki)
- (HsTypeArg ki_arg : args, Just (ki_binder, inner_ki)) ->
+ (HsTypeArg _ ki_arg : args, Just (ki_binder, inner_ki)) ->
case tyCoBinderArgFlag ki_binder of
Inferred -> instantiate ki_binder inner_ki
Specified ->
@@ -1026,8 +1026,8 @@ tcInferApps mode orig_hs_ty fun_ty orig_fun_ki orig_hs_args
; ty_app_err ki_arg $ nakedSubstTy subst fun_ki }
-- no binder; try applying the substitution, or fail if that's not possible
- (HsTypeArg ki_arg : _, Nothing) -> try_again_after_substing_or $
- ty_app_err ki_arg substed_fun_ki
+ (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $
+ ty_app_err ki_arg substed_fun_ki
-- normal argument (fun ty)
(HsValArg arg : args, Just (ki_binder, inner_ki))
@@ -1086,7 +1086,8 @@ tcInferApps mode orig_hs_ty fun_ty orig_fun_ki orig_hs_args
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 (HsTypeArg l arg : args)
+ = appTypeToArg (mkHsAppKindTy l f arg) args
appTypeToArg f (HsArgPar _ : arg) = appTypeToArg f arg
-- | Applies a type to a list of arguments.
diff --git a/testsuite/tests/ghc-api/annotations/Makefile b/testsuite/tests/ghc-api/annotations/Makefile
index f7a66f41bb..ef2b5eaafa 100644
--- a/testsuite/tests/ghc-api/annotations/Makefile
+++ b/testsuite/tests/ghc-api/annotations/Makefile
@@ -153,3 +153,7 @@ T16212:
.PHONY: T16230
T16230:
$(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16230.hs
+
+.PHONY: T16236
+T16236:
+ $(CHECK_API_ANNOTATIONS) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Test16236.hs
diff --git a/testsuite/tests/ghc-api/annotations/T16236.stdout b/testsuite/tests/ghc-api/annotations/T16236.stdout
new file mode 100644
index 0000000000..986b9a4ff2
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/T16236.stdout
@@ -0,0 +1,85 @@
+---Unattached Annotation Problems (should be empty list)---
+[]
+---Ann before enclosing span problem (should be empty list)---
+[
+
+]
+
+---Annotations-----------------------
+-- SrcSpan the annotation is attached to, AnnKeywordId,
+-- list of locations the keyword item appears in
+[
+((Test16236.hs:1:1,AnnModule), [Test16236.hs:4:1-6]),
+((Test16236.hs:1:1,AnnWhere), [Test16236.hs:4:22-26]),
+((Test16236.hs:5:1-16,AnnImport), [Test16236.hs:5:1-6]),
+((Test16236.hs:5:1-16,AnnSemi), [Test16236.hs:7:1]),
+((Test16236.hs:7:1-30,AnnData), [Test16236.hs:7:1-4]),
+((Test16236.hs:7:1-30,AnnEqual), [Test16236.hs:7:12]),
+((Test16236.hs:7:1-30,AnnSemi), [Test16236.hs:9:1]),
+((Test16236.hs:7:14-17,AnnVbar), [Test16236.hs:7:19]),
+((Test16236.hs:9:1-39,AnnCloseP), [Test16236.hs:9:30]),
+((Test16236.hs:9:1-39,AnnDcolon), [Test16236.hs:9:32-33]),
+((Test16236.hs:9:1-39,AnnFamily), [Test16236.hs:9:6-11]),
+((Test16236.hs:9:1-39,AnnOpenP), [Test16236.hs:9:20]),
+((Test16236.hs:9:1-39,AnnSemi), [Test16236.hs:14:1]),
+((Test16236.hs:9:1-39,AnnType), [Test16236.hs:9:1-4]),
+((Test16236.hs:9:1-39,AnnWhere), [Test16236.hs:9:41-45]),
+((Test16236.hs:9:20-30,AnnCloseP), [Test16236.hs:9:30]),
+((Test16236.hs:9:20-30,AnnOpenP), [Test16236.hs:9:20]),
+((Test16236.hs:9:21-29,AnnDcolon), [Test16236.hs:9:24-25]),
+((Test16236.hs:9:27-29,AnnCloseS), [Test16236.hs:9:29]),
+((Test16236.hs:9:27-29,AnnOpenS), [Test16236.hs:9:27]),
+((Test16236.hs:10:3-36,AnnEqual), [Test16236.hs:10:19]),
+((Test16236.hs:10:3-36,AnnSemi), [Test16236.hs:11:3]),
+((Test16236.hs:10:10-17,AnnCloseP), [Test16236.hs:10:17]),
+((Test16236.hs:10:10-17,AnnOpenP), [Test16236.hs:10:10]),
+((Test16236.hs:10:26-36,AnnCloseP), [Test16236.hs:10:36]),
+((Test16236.hs:10:26-36,AnnOpenP), [Test16236.hs:10:26]),
+((Test16236.hs:11:3-24,AnnEqual), [Test16236.hs:11:19]),
+((Test16236.hs:11:10-12,AnnCloseS), [Test16236.hs:11:12]),
+((Test16236.hs:11:10-12,AnnOpenS), [Test16236.hs:11:11]),
+((Test16236.hs:11:10-12,AnnSimpleQuote), [Test16236.hs:11:10]),
+((Test16236.hs:14:1-29,AnnCloseP), [Test16236.hs:14:17]),
+((Test16236.hs:14:1-29,AnnData), [Test16236.hs:14:1-4]),
+((Test16236.hs:14:1-29,AnnEqual), [Test16236.hs:14:19]),
+((Test16236.hs:14:1-29,AnnOpenP), [Test16236.hs:14:10]),
+((Test16236.hs:14:1-29,AnnSemi), [Test16236.hs:16:1]),
+((Test16236.hs:14:10-17,AnnCloseP), [Test16236.hs:14:17]),
+((Test16236.hs:14:10-17,AnnOpenP), [Test16236.hs:14:10]),
+((Test16236.hs:14:11-16,AnnDcolon), [Test16236.hs:14:13-14]),
+((Test16236.hs:14:25-29,AnnCloseP), [Test16236.hs:14:29]),
+((Test16236.hs:14:25-29,AnnOpenP), [Test16236.hs:14:25]),
+((Test16236.hs:16:1-48,AnnCloseP), [Test16236.hs:16:23, Test16236.hs:16:40]),
+((Test16236.hs:16:1-48,AnnDcolon), [Test16236.hs:16:42-43]),
+((Test16236.hs:16:1-48,AnnFamily), [Test16236.hs:16:6-11]),
+((Test16236.hs:16:1-48,AnnOpenP), [Test16236.hs:16:16, Test16236.hs:16:25]),
+((Test16236.hs:16:1-48,AnnSemi), [Test16236.hs:19:1]),
+((Test16236.hs:16:1-48,AnnType), [Test16236.hs:16:1-4]),
+((Test16236.hs:16:1-48,AnnWhere), [Test16236.hs:16:50-54]),
+((Test16236.hs:16:16-23,AnnCloseP), [Test16236.hs:16:23]),
+((Test16236.hs:16:16-23,AnnOpenP), [Test16236.hs:16:16]),
+((Test16236.hs:16:17-22,AnnDcolon), [Test16236.hs:16:19-20]),
+((Test16236.hs:16:25-40,AnnCloseP), [Test16236.hs:16:40]),
+((Test16236.hs:16:25-40,AnnOpenP), [Test16236.hs:16:25]),
+((Test16236.hs:16:26-39,AnnDcolon), [Test16236.hs:16:28-29]),
+((Test16236.hs:16:31,AnnRarrow), [Test16236.hs:16:33-34]),
+((Test16236.hs:16:31-39,AnnRarrow), [Test16236.hs:16:33-34]),
+((Test16236.hs:17:3-30,AnnEqual), [Test16236.hs:17:17]),
+((Test16236.hs:19:1-11,AnnCloseP), [Test16236.hs:19:24]),
+((Test16236.hs:19:1-11,AnnData), [Test16236.hs:19:1-4]),
+((Test16236.hs:19:1-11,AnnFamily), [Test16236.hs:19:6-11]),
+((Test16236.hs:19:1-11,AnnOpenP), [Test16236.hs:19:17]),
+((Test16236.hs:19:1-11,AnnSemi), [Test16236.hs:20:1]),
+((Test16236.hs:19:17-24,AnnCloseP), [Test16236.hs:19:24]),
+((Test16236.hs:19:17-24,AnnOpenP), [Test16236.hs:19:17]),
+((Test16236.hs:19:18-23,AnnDcolon), [Test16236.hs:19:20-21]),
+((Test16236.hs:20:1-49,AnnData), [Test16236.hs:20:1-4]),
+((Test16236.hs:20:1-49,AnnEqual), [Test16236.hs:20:41]),
+((Test16236.hs:20:1-49,AnnInstance), [Test16236.hs:20:6-13]),
+((Test16236.hs:20:1-49,AnnSemi), [Test16236.hs:21:1]),
+((Test16236.hs:20:20-37,AnnCloseP), [Test16236.hs:20:37]),
+((Test16236.hs:20:20-37,AnnOpenP), [Test16236.hs:20:20]),
+((Test16236.hs:20:21-26,AnnRarrow), [Test16236.hs:20:28-29]),
+((Test16236.hs:20:21-36,AnnRarrow), [Test16236.hs:20:28-29]),
+((<no location info>,AnnEofPos), [Test16236.hs:21:1])
+]
diff --git a/testsuite/tests/ghc-api/annotations/Test16236.hs b/testsuite/tests/ghc-api/annotations/Test16236.hs
new file mode 100644
index 0000000000..e19a0ee0c1
--- /dev/null
+++ b/testsuite/tests/ghc-api/annotations/Test16236.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies
+ , TypeApplications, TypeInType #-}
+
+module DumpParsedAst where
+import Data.Kind
+
+data Peano = Zero | Succ Peano
+
+type family Length (as :: [k]) :: Peano where
+ Length (a : as) = Succ (Length as)
+ Length '[] = Zero
+
+-- vis kind app
+data T f (a :: k) = MkT (f a)
+
+type family F1 (a :: k) (f :: k -> Type) :: Type where
+ F1 @Peano a f = T @Peano f a
+
+data family DF3 (a :: k)
+data instance DF3 @(K.Type -> K.Type) b = DF3Char
diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T
index e4413f7924..139c4412ed 100644
--- a/testsuite/tests/ghc-api/annotations/all.T
+++ b/testsuite/tests/ghc-api/annotations/all.T
@@ -63,3 +63,5 @@ test('T16212', [expect_broken(16212),extra_files(['Test16212.hs']),
ignore_stderr], makefile_test, ['T16212'])
test('T16230', [extra_files(['Test16230.hs']),
ignore_stderr], makefile_test, ['T16230'])
+test('T16236', [extra_files(['Test16236.hs']),
+ ignore_stderr], makefile_test, ['T16236'])
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
index 81607d729e..5c8bb34e50 100644
--- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -292,6 +292,7 @@
{OccName: F1}))
(Nothing)
[(HsTypeArg
+ { DumpParsedAst.hs:17:6-11 }
({ DumpParsedAst.hs:17:7-11 }
(HsTyVar
(NoExt)
@@ -324,7 +325,7 @@
(NoExt)
({ DumpParsedAst.hs:17:19-26 }
(HsAppKindTy
- (NoExt)
+ { DumpParsedAst.hs:17:21-26 }
({ DumpParsedAst.hs:17:19 }
(HsTyVar
(NoExt)
diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
index 8df66c806f..d6cfe26b40 100644
--- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
@@ -536,6 +536,7 @@
{Name: DumpRenamedAst.F1})
(Nothing)
[(HsTypeArg
+ { DumpRenamedAst.hs:24:6-11 }
({ DumpRenamedAst.hs:24:7-11 }
(HsTyVar
(NoExt)
@@ -565,7 +566,7 @@
(NoExt)
({ DumpRenamedAst.hs:24:19-26 }
(HsAppKindTy
- (NoExt)
+ { DumpRenamedAst.hs:24:21-26 }
({ DumpRenamedAst.hs:24:19 }
(HsTyVar
(NoExt)
View Lorry Controller Status