[commit: ghc] wip/T10803: First part of implementing TypeSignatureSections (75cf1ef)
git at git.haskell.org
git at git.haskell.org
Fri Aug 28 15:35:08 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T10803
Link : http://ghc.haskell.org/trac/ghc/changeset/75cf1ef06c1c7b47bd543d3acab003938b51ae5c/ghc
>---------------------------------------------------------------
commit 75cf1ef06c1c7b47bd543d3acab003938b51ae5c
Author: Herbert Valerio Riedel <hvr at gnu.org>
Date: Fri Aug 28 13:09:26 2015 +0200
First part of implementing TypeSignatureSections
See #10803
>---------------------------------------------------------------
75cf1ef06c1c7b47bd543d3acab003938b51ae5c
compiler/deSugar/DsExpr.hs | 6 ++++++
compiler/hsSyn/HsExpr.hs | 16 ++++++++++++++++
compiler/parser/Parser.y | 1 +
compiler/rename/RnExpr.hs | 11 +++++++++++
compiler/typecheck/TcExpr.hs | 9 +++++++++
compiler/typecheck/TcHsSyn.hs | 4 ++++
6 files changed, 47 insertions(+)
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 433a13e..f4d92e1 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 8b8b9df..79d7611 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 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..85ef82d 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 d2b0c59..a71b493 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 c461d51..b7e1fae 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 at TySigSectionOut {}) = pure tysig
+zonkExpr env (tysig at 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) }
More information about the ghc-commits
mailing list