diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 433a13ee3778bb7a15bd591be479526421953ae3..f4d92e19bbccdb1aa506b8c5d1b19dd4e4ba4f2f 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -276,6 +276,11 @@ dsExpr (SectionR op expr) = do
return (bindNonRec y_id y_core $
Lam x_id (mkCoreAppsDs core_op [Var x_id, Var y_id]))
+dsExpr (TySigSectionOut _ ty co) = do
+ -- (\(x:ty) -> x) |> co
+ arg_var <- newSysLocalDs ty
+ return $ Lam arg_var (Var arg_var)
+
dsExpr (ExplicitTuple tup_args boxity)
= do { let go (lam_vars, args) (L _ (Missing ty))
-- For every missing expression, we need
@@ -673,6 +678,7 @@ dsExpr (HsTickPragma _ _ expr) = do
-- HsSyn constructs that just shouldn't be here:
dsExpr (ExprWithTySig {}) = panic "dsExpr:ExprWithTySig"
+dsExpr (TySigSection {}) = panic "dsExpr:TySigSection"
dsExpr (HsBracket {}) = panic "dsExpr:HsBracket"
dsExpr (HsArrApp {}) = panic "dsExpr:HsArrApp"
dsExpr (HsArrForm {}) = panic "dsExpr:HsArrForm"
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 8b8b9df2552a869aa10671ed7ec43978bf654445..79d76115c12351eeb733f0d8a26367613c2e1e0b 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -36,6 +36,7 @@ import StaticFlags( opt_PprStyle_Debug )
import Outputable
import FastString
import Type
+import Coercion
-- libraries:
import Data.Data hiding (Fixity)
@@ -187,6 +188,15 @@ data HsExpr id
| SectionR (LHsExpr id) -- operator; see Note [Sections in HsSyn]
(LHsExpr id) -- operand
+ -- | Type-signature operator sections
+
+ | TySigSection (LHsType id)
+ (PostRn id [Name]) -- wildcards
+
+ | TySigSectionOut (LHsType Name)
+ (PostTc id Type)
+ (PostTc id Coercion)
+
-- | Used for explicit tuples and sections thereof
--
-- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
@@ -643,6 +653,12 @@ ppr_expr (SectionR op expr)
4 (pp_expr <> rparen)
pp_infixly v = sep [pprInfixOcc v, pp_expr]
+ppr_expr (TySigSection sig _)
+ = hang dcolon 4 (ppr sig)
+
+ppr_expr (TySigSectionOut sig _ _)
+ = hang dcolon 4 (ppr sig)
+
ppr_expr (ExplicitTuple exprs boxity)
= tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))
where
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 1b4df16d288d4d149c5787805f7739b7861e3209..e8716b0ec761b4897d87555607e383f554b5341e 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2327,6 +2327,7 @@ texp :: { LHsExpr RdrName }
-- inside parens.
| infixexp qop { sLL $1 $> $ SectionL $1 $2 }
| qopm infixexp { sLL $1 $> $ SectionR $1 $2 }
+ | '::' sigtype { sLL $1 $> $ TySigSection $2 PlaceHolder }
-- View patterns get parenthesized above
| exp '->' texp {% ams (sLL $1 $> $ EViewPat $1 $3) [mj AnnRarrow $2] }
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index da0d38754d8cf037ea29a346e40113559e57781a..85ef82d04916f11f33efa6d6b34aa69f9ad77303 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -176,6 +176,10 @@ rnExpr (HsPar (L loc (section@(SectionR {}))))
= do { (section', fvs) <- rnSection section
; return (HsPar (L loc section'), fvs) }
+rnExpr (HsPar (L loc (section@(TySigSection {}))))
+ = do { (section', fvs) <- rnSection section
+ ; return (HsPar (L loc section'), fvs) }
+
rnExpr (HsPar e)
= do { (e', fvs_e) <- rnLExpr e
; return (HsPar e', fvs_e) }
@@ -184,6 +188,9 @@ rnExpr expr@(SectionL {})
= do { addErr (sectionErr expr); rnSection expr }
rnExpr expr@(SectionR {})
= do { addErr (sectionErr expr); rnSection expr }
+rnExpr expr@(TySigSection {})
+ = do { addErr (sectionErr expr); rnSection expr }
+
---------------------------------------------
rnExpr (HsCoreAnn src ann expr)
@@ -400,6 +407,10 @@ rnSection section@(SectionL expr op)
; checkSectionPrec InfixL section op' expr'
; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
+rnSection (TySigSection pty PlaceHolder)
+ = do { (pty', fvTy, wcs) <- rnLHsTypeWithWildCards ExprWithTySigCtx pty
+ ; return (TySigSection pty' wcs, fvTy) }
+
rnSection other = pprPanic "rnSection" (ppr other)
{-
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index d2b0c59244c34f0a0cfc2023817d8117573f8d0c..a71b49344897b06db2d9e9e1b7be1f53ddb7d812 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -373,6 +373,15 @@ tcExpr (SectionL arg1 op) res_ty
; return $ mkHsWrapCo co_res $
SectionL arg1' (mkLHsWrapCo co_fn op') }
+tcExpr (TySigSection sig_ty wcs) res_ty
+ = tcWildcardBinders wcs $ \ wc_prs ->
+ do { addErrCtxt (pprSigCtxt ExprSigCtxt empty (ppr sig_ty)) $
+ emitWildcardHoleConstraints wc_prs
+ ; sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
+ ; co <- unifyType (mkFunTy sig_tc_ty sig_tc_ty) res_ty -- TcM TcCoercion
+ ; return $ mkHsWrapCo co (TySigSectionOut sig_ty res_ty (panic "FIXME"))
+ }
+
tcExpr (ExplicitTuple tup_args boxity) res_ty
| all tupArgPresent tup_args
= do { let tup_tc = tupleTyCon boxity (length tup_args)
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index c461d513e23ddf885848ab8352fa5d59650c2b11..b7e1fae395130aa7140d83ae5b28a9435a66f9d0 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -651,6 +651,10 @@ zonkExpr env (SectionR op expr)
new_expr <- zonkLExpr env expr
return (SectionR new_op new_expr)
+-- FIXME: is this really right?
+zonkExpr env (tysig@TySigSectionOut {}) = pure tysig
+zonkExpr env (tysig@TySigSection {}) = panic "zonkExpr TySigSection"
+
zonkExpr env (ExplicitTuple tup_args boxed)
= do { new_tup_args <- mapM zonk_tup_arg tup_args
; return (ExplicitTuple new_tup_args boxed) }