summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/Coverage.hs23
-rw-r--r--compiler/deSugar/DsExpr.hs15
-rw-r--r--compiler/deSugar/DsMeta.hs4
-rw-r--r--compiler/hsSyn/HsExpr.hs63
-rw-r--r--compiler/hsSyn/HsUtils.hs26
-rw-r--r--compiler/parser/Parser.y11
-rw-r--r--compiler/rename/RnExpr.hs10
-rw-r--r--compiler/rename/RnSource.hs1
-rw-r--r--compiler/typecheck/TcExpr.hs115
-rw-r--r--compiler/typecheck/TcHsSyn.hs8
-rw-r--r--compiler/typecheck/TcRnTypes.hs4
-rw-r--r--testsuite/tests/ghci/scripts/T11456.hs5
-rw-r--r--testsuite/tests/ghci/scripts/T11456.script2
-rw-r--r--testsuite/tests/ghci/scripts/T11456.stdout1
-rwxr-xr-xtestsuite/tests/ghci/scripts/all.T1
-rw-r--r--testsuite/tests/typecheck/should_fail/T9605.stderr20
-rw-r--r--testsuite/tests/typecheck/should_fail/VtaFail.stderr2
17 files changed, 167 insertions, 144 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index 479d8cdfe5..c48df8ad4c 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -482,13 +482,15 @@ addTickLHsExprNever (L pos e0) = do
-- general heuristic: expressions which do not denote values are good
-- break points
isGoodBreakExpr :: HsExpr Id -> Bool
-isGoodBreakExpr (HsApp {}) = True
-isGoodBreakExpr (OpApp {}) = True
-isGoodBreakExpr _other = False
+isGoodBreakExpr (HsApp {}) = True
+isGoodBreakExpr (HsAppTypeOut {}) = True
+isGoodBreakExpr (OpApp {}) = True
+isGoodBreakExpr _other = False
isCallSite :: HsExpr Id -> Bool
-isCallSite HsApp{} = True
-isCallSite OpApp{} = True
+isCallSite HsApp{} = True
+isCallSite HsAppTypeOut{} = True
+isCallSite OpApp{} = True
isCallSite _ = False
addTickLHsExprOptAlt :: Bool -> LHsExpr Id -> TM (LHsExpr Id)
@@ -518,13 +520,10 @@ addTickHsExpr e@(HsOverLabel _) = return e
addTickHsExpr e@(HsLit _) = return e
addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
addTickHsExpr (HsLamCase ty mgs) = liftM (HsLamCase ty) (addTickMatchGroup True mgs)
-addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1) e2'
- -- This might be a type application. Then don't put a tick around e2,
- -- or dsExpr won't recognize it as a type application any more (#11329).
- -- It doesn't make sense to put a tick on a type anyways.
- where e2'
- | isLHsTypeExpr e2 = return e2
- | otherwise = addTickLHsExpr e2
+addTickHsExpr (HsApp e1 e2) = liftM2 HsApp (addTickLHsExprNever e1)
+ (addTickLHsExpr e2)
+addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
+ (return ty)
addTickHsExpr (OpApp e1 e2 fix e3) =
liftM4 OpApp
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 2320ab498a..59c8c4d927 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -234,10 +234,11 @@ dsExpr (HsLamCase arg matches)
; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
dsExpr e@(HsApp fun arg)
+ = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg
+
+dsExpr (HsAppTypeOut e _)
-- ignore type arguments here; they're in the wrappers instead at this point
- | isLHsTypeExpr arg = dsLExpr fun
- | otherwise = mkCoreAppDs (text "HsApp" <+> ppr e)
- <$> dsLExpr fun <*> dsLExpr arg
+ = dsLExpr e
{-
@@ -730,16 +731,10 @@ dsExpr (EWildPat {}) = panic "dsExpr:EWildPat"
dsExpr (EAsPat {}) = panic "dsExpr:EAsPat"
dsExpr (EViewPat {}) = panic "dsExpr:EViewPat"
dsExpr (ELazyPat {}) = panic "dsExpr:ELazyPat"
-dsExpr (HsType {}) = panic "dsExpr:HsType" -- removed by typechecker
+dsExpr (HsAppType {}) = panic "dsExpr:HsAppType" -- removed by typechecker
dsExpr (HsDo {}) = panic "dsExpr:HsDo"
dsExpr (HsRecFld {}) = panic "dsExpr:HsRecFld"
--- Normally handled in HsApp case, but a GHC API user might try to desugar
--- an HsTypeOut, since it is an HsExpr in a typechecked module after all.
--- (Such as ghci itself, in #11456.) So improve the error message slightly.
-dsExpr (HsTypeOut {})
- = panic "dsExpr: tried to desugar a naked type application argument (HsTypeOut)"
-
------------------------------
dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
dsSyntaxExpr (SyntaxExpr { syn_expr = expr
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 7a8de3cf0a..4ed3431bad 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -309,8 +309,8 @@ repDataDefn tc bndrs opt_tys
}
repSynDecl :: Core TH.Name -> Core [TH.TyVarBndr]
- -> LHsType Name
- -> DsM (Core TH.DecQ)
+ -> LHsType Name
+ -> DsM (Core TH.DecQ)
repSynDecl tc bndrs ty
= do { ty1 <- repLTy ty
; repTySyn tc bndrs ty1 }
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index dd850c44bd..7f09726fcc 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -9,6 +9,7 @@
{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
-- in module PlaceHolder
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ExistentialQuantification #-}
-- | Abstract Haskell syntax for expressions.
module HsExpr where
@@ -203,6 +204,16 @@ data HsExpr id
| HsApp (LHsExpr id) (LHsExpr id) -- ^ Application
+ | HsAppType (LHsExpr id) (LHsWcType id) -- ^ Visible type application
+ --
+ -- Explicit type argument; e.g f @Int x y
+ -- NB: Has wildcards, but no implicit quantification
+ --
+ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt',
+
+ | HsAppTypeOut (LHsExpr id) (LHsWcType Name) -- just for pretty-printing
+
+
-- | Operator applications:
-- NB Bracketed ops such as (+) come out as Vars.
@@ -545,14 +556,6 @@ data HsExpr id
-- For details on above see note [Api annotations] in ApiAnnotation
| ELazyPat (LHsExpr id) -- ~ pattern
- -- | Use for type application in expressions.
- -- 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt'
-
- -- For details on above see note [Api annotations] in ApiAnnotation
- | HsType (LHsWcType id) -- Explicit type argument; e.g f @Int x y
- -- NB: Has wildcards, but no implicit quant.
-
- | HsTypeOut (LHsWcType Name) -- just for pretty-printing
---------------------------------------
-- Finally, HsWrap appears only in typechecker output
@@ -663,10 +666,12 @@ isQuietHsExpr :: HsExpr id -> Bool
-- Parentheses do display something, but it gives little info and
-- if we go deeper when we go inside them then we get ugly things
-- like (...)
-isQuietHsExpr (HsPar _) = True
+isQuietHsExpr (HsPar _) = True
-- applications don't display anything themselves
-isQuietHsExpr (HsApp _ _) = True
-isQuietHsExpr (OpApp _ _ _ _) = True
+isQuietHsExpr (HsApp _ _) = True
+isQuietHsExpr (HsAppType _ _) = True
+isQuietHsExpr (HsAppTypeOut _ _) = True
+isQuietHsExpr (OpApp _ _ _ _) = True
isQuietHsExpr _ = False
pprBinds :: (OutputableBndr idL, OutputableBndr idR)
@@ -689,12 +694,9 @@ ppr_expr (HsPar e) = parens (ppr_lexpr e)
ppr_expr (HsCoreAnn _ (StringLiteral _ s) e)
= vcat [text "HsCoreAnn" <+> ftext s, ppr_lexpr e]
-ppr_expr (HsApp e1 e2)
- = let (fun, args) = collect_args e1 [e2] in
- hang (ppr_lexpr fun) 2 (sep (map pprParendLExpr args))
- where
- collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
- collect_args fun args = (fun, args)
+ppr_expr e@(HsApp {}) = ppr_apps e []
+ppr_expr e@(HsAppType {}) = ppr_apps e []
+ppr_expr e@(HsAppTypeOut {}) = ppr_apps e []
ppr_expr (OpApp e1 op _ e2)
= case unLoc op of
@@ -815,11 +817,6 @@ ppr_expr (HsWrap co_fn e)
= pprHsWrapper co_fn (\parens -> if parens then pprParendExpr e
else pprExpr e)
-ppr_expr (HsType (HsWC { hswc_body = ty }))
- = char '@' <> pprParendHsType (unLoc ty)
-ppr_expr (HsTypeOut (HsWC { hswc_body = ty }))
- = char '@' <> pprParendHsType (unLoc ty)
-
ppr_expr (HsSpliceE s) = pprSplice s
ppr_expr (HsBracket b) = pprHsBracket b
ppr_expr (HsRnBracketOut e []) = ppr e
@@ -868,6 +865,26 @@ ppr_expr (HsArrForm op _ args)
4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")
ppr_expr (HsRecFld f) = ppr f
+-- We must tiresomely make the "id" parameter to the LHsWcType existential
+-- because it's different in the HsAppType case and the HsAppTypeOut case
+data LHsWcTypeX = forall id. OutputableBndr id => LHsWcTypeX (LHsWcType id)
+
+ppr_apps :: OutputableBndr id
+ => HsExpr id
+ -> [Either (LHsExpr id) LHsWcTypeX]
+ -> SDoc
+ppr_apps (HsApp (L _ fun) arg) args
+ = ppr_apps fun (Left arg : args)
+ppr_apps (HsAppType (L _ fun) arg) args
+ = ppr_apps fun (Right (LHsWcTypeX arg) : args)
+ppr_apps (HsAppTypeOut (L _ fun) arg) args
+ = ppr_apps fun (Right (LHsWcTypeX arg) : args)
+ppr_apps fun args = hang (ppr_expr fun) 2 (sep (map pp args))
+ where
+ pp (Left arg) = pprParendLExpr arg
+ pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))
+ = char '@' <> pprParendHsType arg
+
pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
= ppr (src,(n1,n2),(n3,n4))
@@ -923,8 +940,6 @@ hsExprNeedsParens (HsTcBracketOut {}) = False
hsExprNeedsParens (HsDo sc _ _)
| isListCompExpr sc = False
hsExprNeedsParens (HsRecFld{}) = False
-hsExprNeedsParens (HsType {}) = False
-hsExprNeedsParens (HsTypeOut {}) = False
hsExprNeedsParens _ = True
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index cb2da5c0ee..8ac7e24f8d 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -20,13 +20,13 @@ which deal with the instantiated versions are located elsewhere:
module HsUtils(
-- Terms
- mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
+ mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsConApp, mkSimpleHsAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
mkHsDictLet, mkHsLams,
mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
- mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, isLHsTypeExpr_maybe, isLHsTypeExpr,
+ mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
nlHsIntLit, nlHsVarApps,
@@ -169,6 +169,12 @@ mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches
mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
+mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name
+mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t)
+
+mkHsAppTypeOut :: LHsExpr Id -> LHsWcType Name -> LHsExpr Id
+mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)
+
mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where
@@ -458,21 +464,6 @@ nlHsFunTy a b = noLoc (HsFunTy a b)
nlHsTyConApp :: name -> [LHsType name] -> LHsType name
nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
--- | Extract a type argument from an HsExpr, with the list of wildcards in
--- the type
-isLHsTypeExpr_maybe :: LHsExpr name -> Maybe (LHsWcType name)
-isLHsTypeExpr_maybe (L _ (HsPar e)) = isLHsTypeExpr_maybe e
-isLHsTypeExpr_maybe (L _ (HsType ty)) = Just ty
- -- the HsTypeOut case is ill-typed. We never need it here anyway.
-isLHsTypeExpr_maybe _ = Nothing
-
--- | Is an expression a visible type application?
-isLHsTypeExpr :: LHsExpr name -> Bool
-isLHsTypeExpr (L _ (HsPar e)) = isLHsTypeExpr e
-isLHsTypeExpr (L _ (HsType _)) = True
-isLHsTypeExpr (L _ (HsTypeOut _)) = True
-isLHsTypeExpr _ = False
-
{-
Tuples. All these functions are *pre-typechecker* because they lack
types on the tuple.
@@ -1132,4 +1123,3 @@ lPatImplicits = hs_lpat
(unLoc fld)
pat_explicit = maybe True (i<) (rec_dotdot fs)]
details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2
-
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index dead15bbb3..a640bcb849 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2241,10 +2241,12 @@ hpc_annot :: { Located ( (([AddAnn],SourceText),(StringLiteral,(Int,Int),(Int,In
}
fexp :: { LHsExpr RdrName }
- : fexp aexp { sLL $1 $> $ HsApp $1 $2 }
- | 'static' aexp {% ams (sLL $1 $> $ HsStatic $2)
- [mj AnnStatic $1] }
- | aexp { $1 }
+ : fexp aexp { sLL $1 $> $ HsApp $1 $2 }
+ | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3))
+ [mj AnnAt $2] }
+ | 'static' aexp {% ams (sLL $1 $> $ HsStatic $2)
+ [mj AnnStatic $1] }
+ | aexp { $1 }
aexp :: { LHsExpr RdrName }
: qvar '@' aexp {% ams (sLL $1 $> $ EAsPat $1 $3) [mj AnnAt $2] }
@@ -2252,7 +2254,6 @@ aexp :: { LHsExpr RdrName }
-- Note [Lexing type applications] in Lexer.x
| '~' aexp {% ams (sLL $1 $> $ ELazyPat $2) [mj AnnTilde $1] }
- | TYPEAPP atype {% ams (sLL $1 $> $ HsType (mkHsWildCardBndrs $2)) [mj AnnAt $1] }
| aexp1 { $1 }
aexp1 :: { LHsExpr RdrName }
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 510543c6fe..de03b8d796 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -146,6 +146,11 @@ rnExpr (HsApp fun arg)
; (arg',fvArg) <- rnLExpr arg
; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
+rnExpr (HsAppType fun arg)
+ = do { (fun',fvFun) <- rnLExpr fun
+ ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg
+ ; return (HsAppType fun' arg', fvFun `plusFV` fvArg) }
+
rnExpr (OpApp e1 op _ e2)
= do { (e1', fv_e1) <- rnLExpr e1
; (e2', fv_e2) <- rnLExpr e2
@@ -303,10 +308,6 @@ rnExpr (HsMultiIf _ty alts)
-- ; return (HsMultiIf ty alts', fvs) }
; return (HsMultiIf placeHolderType alts', fvs) }
-rnExpr (HsType ty)
- = do { (ty', fvT) <- rnHsWcType HsTypeCtx ty
- ; return (HsType ty', fvT) }
-
rnExpr (ArithSeq _ _ seq)
= do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
; (new_seq, fvs) <- rnArithSeq seq
@@ -1754,6 +1755,7 @@ isReturnApp (L _ (HsApp f arg))
| otherwise = Nothing
where
is_return (L _ (HsPar e)) = is_return e
+ is_return (L _ (HsAppType e _)) = is_return e
is_return (L _ (HsVar (L _ r))) = r == returnMName || r == pureAName
-- TODO: I don't know how to get this right for rebindable syntax
is_return _ = False
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 67afee7f7c..df729dc44b 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -1024,6 +1024,7 @@ validRuleLhs foralls lhs
check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
+ check (HsAppType e _) = checkl e
check (HsVar (L _ v)) | v `notElem` foralls = Nothing
check other = Just other -- Failure
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index a2b6bfc063..23d0de91b4 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -73,6 +73,7 @@ import qualified GHC.LanguageExtensions as LangExt
import Data.Function
import Data.List
+import Data.Either
import qualified Data.Set as Set
{-
@@ -163,9 +164,8 @@ tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId)
tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
tcExpr (HsUnboundVar v) res_ty = tcUnboundId v res_ty
-tcExpr (HsApp e1 e2) res_ty
- = do { (wrap, fun, args) <- tcApp Nothing e1 [e2] res_ty
- ; return (mkHsWrap wrap $ unLoc $ foldl mkHsApp fun args) }
+tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty
+tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty
tcExpr e@(HsLit lit) res_ty = do { let lit_ty = hsLitType lit
; tcWrapResult e (HsLit lit) lit_ty res_ty }
@@ -257,11 +257,6 @@ tcExpr e@(ExprWithTySig expr sig_ty) res_ty
; let expr'' = ExprWithTySigOut expr' sig_ty
; tcWrapResult e expr'' poly_ty res_ty }
-tcExpr (HsType ty) _
- = failWithTc (sep [ text "Type argument used outside of a function argument:"
- , ppr ty ])
-
-
{-
Note [Type-checking overloaded labels]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -404,9 +399,9 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
| otherwise
= do { traceTc "Non Application rule" (ppr op)
- ; (wrap, op', [arg1', arg2'])
+ ; (wrap, op', [Left arg1', Left arg2'])
<- tcApp (Just $ mk_op_msg op)
- op [arg1, arg2] res_ty
+ op [Left arg1, Left arg2] res_ty
; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2') }
-- Right sections, equivalent to \ x -> x `op` expr, or
@@ -1059,10 +1054,22 @@ arithSeqEltType (Just fl) res_ty
************************************************************************
-}
+type LHsExprArgIn = Either (LHsExpr Name) (LHsWcType Name)
+type LHsExprArgOut = Either (LHsExpr TcId) (LHsWcType Name)
+
+tcApp1 :: HsExpr Name -- either HsApp or HsAppType
+ -> ExpRhoType -> TcM (HsExpr TcId)
+tcApp1 e res_ty
+ = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty
+ ; return (mkHsWrap wrap $ unLoc $ foldl mk_hs_app fun args) }
+ where
+ mk_hs_app f (Left a) = mkHsApp f a
+ mk_hs_app f (Right a) = mkHsAppTypeOut f a
+
tcApp :: Maybe SDoc -- like "The function `f' is applied to"
-- or leave out to get exactly that message
- -> LHsExpr Name -> [LHsExpr Name] -- Function and args
- -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
+ -> LHsExpr Name -> [LHsExprArgIn] -- Function and args
+ -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
-- (wrap, fun, args). For an ordinary function application,
-- these should be assembled as (wrap (fun args)).
-- But OpApp is slightly different, so that's why the caller
@@ -1071,21 +1078,24 @@ tcApp :: Maybe SDoc -- like "The function `f' is applied to"
tcApp m_herald orig_fun orig_args res_ty
= go orig_fun orig_args
where
- go (L _ (HsPar e)) args = go e args
- go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
+ go :: LHsExpr Name -> [LHsExprArgIn]
+ -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
+ go (L _ (HsPar e)) args = go e args
+ go (L _ (HsApp e1 e2)) args = go e1 (Left e2:args)
+ go (L _ (HsAppType e t)) args = go e (Right t:args)
go (L loc (HsVar (L _ fun))) args
| fun `hasKey` tagToEnumKey
- , count (not . isLHsTypeExpr) args == 1
+ , count isLeft args == 1
= do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty
; return (wrap, expr, args) }
| fun `hasKey` seqIdKey
- , count (not . isLHsTypeExpr) args == 2
+ , count isLeft args == 2
= do { (wrap, expr, args) <- tcSeq loc fun args res_ty
; return (wrap, expr, args) }
- go (L loc (HsRecFld (Ambiguous lbl _))) args@(L _ arg : _)
+ go (L loc (HsRecFld (Ambiguous lbl _))) args@(Left (L _ arg) : _)
| Just sig_ty <- obviousSig arg
= do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
; sel_name <- disambiguateSelector lbl sig_tc_ty
@@ -1104,11 +1114,14 @@ tcApp m_herald orig_fun orig_args res_ty
-- up to call that function
; wrap_res <- addFunResCtxt True (unLoc fun) actual_res_ty res_ty $
tcSubTypeDS_NC_O orig GenSigCtxt
- (Just $ foldl mkHsApp fun args)
+ (Just $ foldl mk_hs_app fun args)
actual_res_ty res_ty
; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) }
+ mk_hs_app f (Left a) = mkHsApp f a
+ mk_hs_app f (Right a) = mkHsAppType f a
+
mk_app_msg :: LHsExpr Name -> SDoc
mk_app_msg fun = sep [ text "The function" <+> quotes (ppr fun)
, text "is applied to"]
@@ -1145,9 +1158,9 @@ tcInferFun fun
tcArgs :: LHsExpr Name -- ^ The function itself (for err msgs only)
-> TcSigmaType -- ^ the (uninstantiated) type of the function
-> CtOrigin -- ^ the origin for the function's type
- -> [LHsExpr Name] -- ^ the args
+ -> [LHsExprArgIn] -- ^ the args
-> SDoc -- ^ the herald for matchActualFunTys
- -> TcM (HsWrapper, [LHsExpr TcId], TcSigmaType)
+ -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)
-- ^ (a wrapper for the function, the tc'd args, result type)
tcArgs fun orig_fun_ty fun_orig orig_args herald
= go [] 1 orig_fun_ty orig_args
@@ -1156,8 +1169,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)
- go acc_args n fun_ty (arg:args)
- | Just hs_ty_arg <- isLHsTypeExpr_maybe arg
+ go acc_args n fun_ty (Right hs_ty_arg:args)
= do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty
-- wrap1 :: fun_ty "->" upsilon_ty
; case tcSplitForAllTy_maybe upsilon_ty of
@@ -1172,11 +1184,11 @@ 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
- , L (getLoc arg) (HsTypeOut hs_ty_arg) : args'
+ , Right hs_ty_arg : args'
, res_ty ) }
_ -> ty_app_err upsilon_ty hs_ty_arg }
- | otherwise -- not a type application.
+ go acc_args n fun_ty (Left arg : args)
= do { (wrap, [arg_ty], res_ty)
<- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty
acc_args orig_arity
@@ -1186,7 +1198,7 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
<- go (arg_ty : acc_args) (n+1) res_ty args
-- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty <.> wrap
- , arg' : args'
+ , Left arg' : args'
, inner_res_ty ) }
ty_app_err ty arg
@@ -1650,16 +1662,15 @@ the users that complain.
-}
-tcSeq :: SrcSpan -> Name -> [LHsExpr Name]
- -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
+tcSeq :: SrcSpan -> Name -> [LHsExprArgIn]
+ -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
-- (seq e1 e2) :: res_ty
-- We need a special typing rule because res_ty can be unboxed
-- See Note [Typing rule for seq]
tcSeq loc fun_name args res_ty
= do { fun <- tcLookupId fun_name
; (arg1_ty, args1) <- case args of
- (ty_arg_expr1 : args1)
- | Just hs_ty_arg1 <- isLHsTypeExpr_maybe ty_arg_expr1
+ (Right hs_ty_arg1 : args1)
-> do { ty_arg1 <- tcHsTypeApp hs_ty_arg1 liftedTypeKind
; return (ty_arg1, args1) }
@@ -1667,47 +1678,41 @@ tcSeq loc fun_name args res_ty
; return (arg_ty1, args) }
; (arg1, arg2, arg2_exp_ty) <- case args1 of
- [ty_arg_expr2, term_arg1, term_arg2]
- | Just hs_ty_arg2 <- isLHsTypeExpr_maybe ty_arg_expr2
+ [Right hs_ty_arg2, Left term_arg1, Left term_arg2]
-> do { rr_ty <- newFlexiTyVarTy runtimeRepTy
; ty_arg2 <- tcHsTypeApp hs_ty_arg2 (tYPE rr_ty)
-- see Note [Typing rule for seq]
; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg2 res_ty
; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) }
- [term_arg1, term_arg2] -> return (term_arg1, term_arg2, res_ty)
- _ -> too_many_args
+ [Left term_arg1, Left term_arg2]
+ -> return (term_arg1, term_arg2, res_ty)
+ _ -> too_many_args "seq" args
; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty)
; arg2' <- tcMonoExpr arg2 arg2_exp_ty
; res_ty <- readExpType res_ty -- by now, it's surely filled in
; let fun' = L loc (HsWrap ty_args (HsVar (L loc fun)))
ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
- ; return (idHsWrapper, fun', [arg1', arg2']) }
- where
- too_many_args :: TcM a
- too_many_args
- = failWith $
- hang (text "Too many type arguments to seq:")
- 2 (sep (map pprParendLExpr args))
-tcTagToEnum :: SrcSpan -> Name -> [LHsExpr Name] -> ExpRhoType
- -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
+ ; return (idHsWrapper, fun', [Left arg1', Left arg2']) }
+
+tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType
+ -> TcM (HsWrapper, LHsExpr TcId, [LHsExprArgOut])
-- tagToEnum# :: forall a. Int# -> a
-- See Note [tagToEnum#] Urgh!
tcTagToEnum loc fun_name args res_ty
= do { fun <- tcLookupId fun_name
; arg <- case args of
- [ty_arg_expr, term_arg]
- | Just hs_ty_arg <- isLHsTypeExpr_maybe ty_arg_expr
+ [Right hs_ty_arg, Left term_arg]
-> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind
; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg res_ty
-- other than influencing res_ty, we just
-- don't care about a type arg passed in.
-- So drop the evidence.
; return term_arg }
- [term_arg] -> do { _ <- expTypeToType res_ty
- ; return term_arg }
- _ -> too_many_args
+ [Left term_arg] -> do { _ <- expTypeToType res_ty
+ ; return term_arg }
+ _ -> too_many_args "tagToEnum#" args
; res_ty <- readExpType res_ty
; ty' <- zonkTcType res_ty
@@ -1731,7 +1736,7 @@ tcTagToEnum loc fun_name args res_ty
; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun)))
rep_ty = mkTyConApp rep_tc rep_args
- ; return (mkWpCastR (mkTcSymCo coi), fun', [arg']) }
+ ; return (mkWpCastR (mkTcSymCo coi), fun', [Left arg']) }
-- coi is a Representational coercion
where
doc1 = vcat [ text "Specify the type by giving a type signature"
@@ -1744,11 +1749,15 @@ tcTagToEnum loc fun_name args res_ty
<+> text "at type" <+> ppr ty)
2 what
- too_many_args :: TcM a
- too_many_args
- = failWith $
- hang (text "Too many type arguments to tagToEnum#:")
- 2 (sep (map pprParendLExpr args))
+too_many_args :: String -> [LHsExprArgIn] -> TcM a
+too_many_args fun args
+ = failWith $
+ hang (text "Too many type arguments to" <+> text fun <> colon)
+ 2 (sep (map pp args))
+ where
+ pp (Left e) = pprParendLExpr e
+ pp (Right (HsWC { hswc_body = L _ t })) = pprParendHsType t
+
{-
************************************************************************
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index d7d23a2a81..6e35a2bc57 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -609,6 +609,11 @@ zonkExpr env (HsApp e1 e2)
new_e2 <- zonkLExpr env e2
return (HsApp new_e1 new_e2)
+zonkExpr env (HsAppTypeOut e t)
+ = do new_e <- zonkLExpr env e
+ return (HsAppTypeOut new_e t)
+ -- NB: the type is an HsType; can't zonk that!
+
zonkExpr _ e@(HsRnBracketOut _ _)
= pprPanic "zonkExpr: HsRnBracketOut" (ppr e)
@@ -772,9 +777,6 @@ zonkExpr env (HsWrap co_fn expr)
zonkExpr _ (HsUnboundVar v)
= return (HsUnboundVar v)
- -- nothing to do here. The payload is an LHsType, not a Type.
-zonkExpr _ e@(HsTypeOut {}) = return e
-
zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
-------------------------------------------------------------------------
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index c642397c28..309bb97b8c 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -2816,6 +2816,8 @@ exprCtOrigin (HsLit {}) = Shouldn'tHappenOrigin "concrete literal"
exprCtOrigin (HsLam matches) = matchesCtOrigin matches
exprCtOrigin (HsLamCase _ ms) = matchesCtOrigin ms
exprCtOrigin (HsApp (L _ e1) _) = exprCtOrigin e1
+exprCtOrigin (HsAppType (L _ e1) _) = exprCtOrigin e1
+exprCtOrigin (HsAppTypeOut {}) = panic "exprCtOrigin HsAppTypeOut"
exprCtOrigin (OpApp _ (L _ op) _ _) = exprCtOrigin op
exprCtOrigin (NegApp (L _ e) _) = exprCtOrigin e
exprCtOrigin (HsPar (L _ e)) = exprCtOrigin e
@@ -2853,8 +2855,6 @@ exprCtOrigin EWildPat = panic "exprCtOrigin EWildPat"
exprCtOrigin (EAsPat {}) = panic "exprCtOrigin EAsPat"
exprCtOrigin (EViewPat {}) = panic "exprCtOrigin EViewPat"
exprCtOrigin (ELazyPat {}) = panic "exprCtOrigin ELazyPat"
-exprCtOrigin (HsType {}) = Shouldn'tHappenOrigin "type application"
-exprCtOrigin (HsTypeOut {}) = panic "exprCtOrigin HsTypeOut"
exprCtOrigin (HsWrap {}) = panic "exprCtOrigin HsWrap"
-- | Extract a suitable CtOrigin from a MatchGroup
diff --git a/testsuite/tests/ghci/scripts/T11456.hs b/testsuite/tests/ghci/scripts/T11456.hs
new file mode 100644
index 0000000000..736ffcba70
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T11456.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE TypeApplications #-}
+
+module T11456 where
+
+a = show @Int
diff --git a/testsuite/tests/ghci/scripts/T11456.script b/testsuite/tests/ghci/scripts/T11456.script
new file mode 100644
index 0000000000..0408aac473
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T11456.script
@@ -0,0 +1,2 @@
+:set +c
+:load T11456
diff --git a/testsuite/tests/ghci/scripts/T11456.stdout b/testsuite/tests/ghci/scripts/T11456.stdout
new file mode 100644
index 0000000000..14a67ed0af
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T11456.stdout
@@ -0,0 +1 @@
+Collecting type info for 1 module(s) ...
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 87be4f1727..62326a290d 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -245,3 +245,4 @@ test('T11266', check_stdout(lambda *args: 1), ghci_script, ['T11266.script'])
test('T11389', req_interp, run_command, ['$MAKE -s --no-print-directory T11389'])
test('T11524a', normal, ghci_script, ['T11524a.script'])
+test('T11456', normal, ghci_script, ['T11456.script'])
diff --git a/testsuite/tests/typecheck/should_fail/T9605.stderr b/testsuite/tests/typecheck/should_fail/T9605.stderr
index 479899c20f..38da1c46a3 100644
--- a/testsuite/tests/typecheck/should_fail/T9605.stderr
+++ b/testsuite/tests/typecheck/should_fail/T9605.stderr
@@ -1,11 +1,11 @@
-T9605.hs:7:6:
- Couldn't match type ‘Bool’ with ‘m Bool’
- Expected type: t0 -> m Bool
- Actual type: t0 -> Bool
- The function ‘f1’ is applied to one argument,
- its type is ‘m0 Bool’,
- it is specialized to ‘t0 -> Bool’
- In the expression: f1 undefined
- In an equation for ‘f2’: f2 = f1 undefined
- Relevant bindings include f2 :: m Bool (bound at T9605.hs:7:1)
+T9605.hs:7:6: error:
+ • Couldn't match type ‘Bool’ with ‘m Bool’
+ Expected type: t1 -> m Bool
+ Actual type: t1 -> Bool
+ • The function ‘f1’ is applied to one argument,
+ its type is ‘m0 Bool’,
+ it is specialized to ‘t1 -> Bool’
+ In the expression: f1 undefined
+ In an equation for ‘f2’: f2 = f1 undefined
+ • Relevant bindings include f2 :: m Bool (bound at T9605.hs:7:1)
diff --git a/testsuite/tests/typecheck/should_fail/VtaFail.stderr b/testsuite/tests/typecheck/should_fail/VtaFail.stderr
index 6d11a4a46c..ff1539850a 100644
--- a/testsuite/tests/typecheck/should_fail/VtaFail.stderr
+++ b/testsuite/tests/typecheck/should_fail/VtaFail.stderr
@@ -13,7 +13,7 @@ VtaFail.hs:12:26: error:
answer_constraint_fail = addOne @Bool 5
VtaFail.hs:14:17: error:
- • Cannot apply expression of type ‘t0 -> t0’
+ • Cannot apply expression of type ‘t1 -> t1’
to a visible type argument ‘Int’
• In the expression: (\ x -> x) @Int 12
In an equation for ‘answer_lambda’:
View Lorry Controller Status