[commit: ghc] wip/spj-wildcard-refactor: More wibbles (0a30502)
git at git.haskell.org
git at git.haskell.org
Tue Oct 27 08:15:24 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/spj-wildcard-refactor
Link : http://ghc.haskell.org/trac/ghc/changeset/0a30502db2fd0dd93f43c15fb02e3179baebeee2/ghc
>---------------------------------------------------------------
commit 0a30502db2fd0dd93f43c15fb02e3179baebeee2
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Tue Oct 27 00:17:43 2015 +0000
More wibbles
>---------------------------------------------------------------
0a30502db2fd0dd93f43c15fb02e3179baebeee2
compiler/typecheck/TcBinds.hs | 12 ++++++++----
compiler/typecheck/TcExpr.hs | 31 +++++++++++++------------------
compiler/typecheck/TcPat.hs | 6 +++---
compiler/typecheck/TcRnTypes.hs | 2 ++
compiler/typecheck/TcTyClsDecls.hs | 4 +++-
5 files changed, 29 insertions(+), 26 deletions(-)
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 04d995f..6a592fc 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -796,9 +796,10 @@ chooseInferredQuantifiers inferred_theta tau_tvs
; partial_sigs <- xoptM Opt_PartialTypeSignatures
; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures
; msg <- mkLongErrAt loc (mk_msg inferred_diff partial_sigs) empty
- ; traceTc "completeTheta" (vcat
- [ ppr bndr_info
- , ppr annotated_theta, ppr inferred_theta, ppr inferred_diff ])
+ ; traceTc "completeTheta" $
+ vcat [ ppr bndr_info
+ , ppr annotated_theta, ppr inferred_theta
+ , ppr inferred_diff ]
; case partial_sigs of
True | warn_partial_sigs -> reportWarning msg
| otherwise -> return ()
@@ -1800,7 +1801,10 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
| strict_pat_binds = NoGen
| Just (lbind, sig) <- one_funbind_with_sig = if isPartialSig sig
-- See Note [Partial type signatures and generalisation]
- then infer_plan
+ -- We use InferGen False to say "do inference, but do not apply
+ -- the MR". It's stupid to apply the MR when we are given a
+ -- signature! C.f Trac #11016, function f1
+ then InferGen False
else CheckGen lbind sig
| mono_local_binds = NoGen
| otherwise = infer_plan
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 50ad827..2f02862 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1060,9 +1060,19 @@ tcExprSig expr sig@(TISI { sig_bndr = s_bndr
; tau <- zonkTcType tau
; let inferred_theta = map evVarPred givens
tau_tvs = tyVarsOfType tau
- ; (_, theta) <- chooseInferredQuantifiers inferred_theta tau_tvs (Just sig)
- ; let poly_wrap = mkWpTyLams qtvs
- <.> mkWpLams givens -- Not right
+ ; (my_tv_set, my_theta) <- chooseInferredQuantifiers inferred_theta tau_tvs (Just sig)
+ ; let my_tvs = filter (`elemVarSet` my_tv_set) qtvs -- Maintain original order
+ inferred_sigma = mkSigmaTy qtvs inferred_theta tau
+ my_sigma = mkSigmaTy my_tvs my_theta tau
+ ; wrap <- if inferred_sigma `eqType` my_sigma
+ then return idHsWrapper -- Fast path; also avoids complaint when we infer
+ -- an ambiguouse type and have AllowAmbiguousType
+ -- e..g infer x :: forall a. F a -> Int
+ else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma
+
+ ; let poly_wrap = wrap
+ <.> mkWpTyLams qtvs
+ <.> mkWpLams givens
<.> mkWpLet ev_binds
; return (mkLHsWrap poly_wrap expr', mkSigmaTy qtvs theta tau) }
@@ -1070,21 +1080,6 @@ tcExprSig expr sig@(TISI { sig_bndr = s_bndr
where
skol_info = SigSkol ExprSigCtxt (mkPhiTy theta tau)
skol_tvs = map snd skol_prs
-{-
- ; ev_binds <- emitImplicationFor tclvl skol_info
- skol_tvs given wanted
- -- NB: don't use checkConsraints here, because that
- -- doesn't bump the level if skol_tvs is empty
- -- But we must also bump the level if there are
- -- any wildcards. Easier to do so unconditionally.
-
-
- = do { (tclvl, wanted, expr') <- pushLevelAndCaptureConstraints $
- tcExtendTyVarEnvFromSig sig $
- tcPolyExprNC expr tau
- ; (qtvs, givens, _mr_bites, ev_binds)
- <- simplifyInfer tclvl False skol_tvs [(name,tau)] wanted
--}
{- *********************************************************************
* *
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index b0b528d..cb424b1 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -699,10 +699,10 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
; checkExistentials ex_tvs penv
; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs
- ; let ty' = substTy tenv ty
- arg_tys' = substTys tenv arg_tys
+ ; let ty' = substTy tenv ty
+ arg_tys' = substTys tenv arg_tys
prov_theta' = substTheta tenv prov_theta
- req_theta' = substTheta tenv req_theta
+ req_theta' = substTheta tenv req_theta
; wrap <- coToHsWrapper <$> unifyType ty' pat_ty
; traceTc "tcPatSynPat" (ppr pat_syn $$
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 5ee1f87..257ac5a 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -1200,6 +1200,8 @@ instance Outputable TcIdSigInfo where
, ppr (map fst tyvars) ]
instance Outputable TcIdSigBndr where
+ ppr (CompleteSig f) = ptext (sLit "CompleteSig") <+> ppr f
+ ppr (PartialSig { sig_name = n }) = ptext (sLit "PartialSig") <+> ppr n
instance Outputable TcPatSynInfo where
ppr (TPSI{ patsig_name = name}) = ppr name
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index e09e894..65914e4 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1299,7 +1299,9 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl -- Data types
-- See Note [Checking GADT return types]
; fam_envs <- tcGetFamInstEnvs
- ; traceTc "tcConDecl 2" (ppr names $$ ppr arg_tys $$ ppr univ_tvs $$ ppr ex_tvs $$ ppr field_lbls)
+
+ -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here
+ ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)
; let
buildOneDataCon (L _ name) = do
{ is_infix <- tcConIsInfix name hs_details res_ty
More information about the ghc-commits
mailing list