[commit: ghc] wip/T10803: First part of implementing TypeSignatureSections (4c57c8a)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/T10803
Link       : http://ghc.haskell.org/trac/ghc/changeset/4c57c8a9ccb98704e4ff26d734960b8f07c78c58/ghc

>---------------------------------------------------------------

commit 4c57c8a9ccb98704e4ff26d734960b8f07c78c58
Author: Herbert Valerio Riedel <hvr at gnu.org>
Date:   Fri Aug 28 13:09:26 2015 +0200

    First part of implementing TypeSignatureSections
    
    See #10803


>---------------------------------------------------------------

4c57c8a9ccb98704e4ff26d734960b8f07c78c58
 compiler/hsSyn/HsExpr.hs     |  7 +++++++
 compiler/parser/Parser.y     |  1 +
 compiler/rename/RnExpr.hs    | 13 +++++++++++++
 compiler/typecheck/TcExpr.hs |  3 +++
 4 files changed, 24 insertions(+)

diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 8b8b9df..1acc31a 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -187,6 +187,10 @@ data HsExpr id
   | SectionR    (LHsExpr id)    -- operator; see Note [Sections in HsSyn]
                 (LHsExpr id)    -- operand
 
+
+  | TySigSection (LHsType id) (PostRn id [Name])
+
+
   -- | Used for explicit tuples and sections thereof
   --
   --  - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen',
@@ -643,6 +647,9 @@ 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 (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 1b4df16..e8716b0 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 da0d387..9b36b06 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,12 @@ rnSection section@(SectionL expr op)
         ; checkSectionPrec InfixL section op' expr'
         ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
 
+rnSection (TySigSection pty PlaceHolder)
+  = do  { (wcs, pty') <- extractWildcards pty
+        ; bindLocatedLocalsFV wcs $ \wcs_new -> do {
+          (pty'', fvTy) <- rnLHsType ExprWithTySigCtx pty'
+        ; return (TySigSection pty'' wcs_new, fvTy) } }
+
 rnSection other = pprPanic "rnSection" (ppr other)
 
 {-
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index d2b0c59..02b500d 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -373,6 +373,9 @@ tcExpr (SectionL arg1 op) res_ty
        ; return $ mkHsWrapCo co_res $
          SectionL arg1' (mkLHsWrapCo co_fn op') }
 
+tcExpr (TySigSection sig_ty wcs) res_ty
+ = error "NOT IMPLEMENTED YET" -- TODO
+
 tcExpr (ExplicitTuple tup_args boxity) res_ty
   | all tupArgPresent tup_args
   = do { let tup_tc = tupleTyCon boxity (length tup_args)