First part of implementing TypeSignatureSectionswip/T10803

See #10803

6 files changed, 47 insertions, 0 deletions

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 433a13ee37..f4d92e19bb 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 8b8b9df255..79d76115c1 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 1b4df16d28..e8716b0ec7 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 da0d38754d..85ef82d049 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 d2b0c59244..a71b493448 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 c461d513e2..b7e1fae395 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) }