[commit: ghc] master: Make SigSkol take TcType not ExpType (0ad2021)
git at git.haskell.org
git at git.haskell.org
Thu Mar 31 07:01:59 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/0ad2021b39ed39940d0f6332d58c7b6debd366ad/ghc
>---------------------------------------------------------------
commit 0ad2021b39ed39940d0f6332d58c7b6debd366ad
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Wed Mar 30 17:23:37 2016 +0100
Make SigSkol take TcType not ExpType
For some reason a SigSkol had an ExpType in it, and there were
lots of places where we needed it to have a TcType. And was indeed
always a Check. All a lot of fuss about nothing.
Delete code, fewer failure points, types are more precise.
All good.
>---------------------------------------------------------------
0ad2021b39ed39940d0f6332d58c7b6debd366ad
compiler/typecheck/TcBinds.hs | 4 ++--
compiler/typecheck/TcExpr.hs | 2 +-
compiler/typecheck/TcMType.hs | 9 +++------
compiler/typecheck/TcPat.hs | 3 +--
compiler/typecheck/TcRnTypes.hs | 4 ++--
compiler/typecheck/TcUnify.hs | 6 ++----
6 files changed, 11 insertions(+), 17 deletions(-)
diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 6ce9aed..3bad211 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -585,7 +585,7 @@ tcPolyCheck rec_tc prag_fn
, sig_loc = loc })
bind
= do { ev_vars <- newEvVars theta
- ; let skol_info = SigSkol ctxt (mkCheckExpType $ mkPhiTy theta tau)
+ ; let skol_info = SigSkol ctxt (mkPhiTy theta tau)
prag_sigs = lookupPragEnv prag_fn name
skol_tvs = map snd skol_prs
-- Find the location of the original source type sig, if
@@ -764,7 +764,7 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
; return (binders, my_theta) }
chooseInferredQuantifiers inferred_theta tau_tvs qtvs
- (Just (TISI { sig_bndr = bndr_info
+ (Just (TISI { sig_bndr = bndr_info -- Always PartialSig
, sig_ctxt = ctxt
, sig_theta = annotated_theta
, sig_skols = annotated_tvs }))
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 5eb28f0..a65e60f 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1480,7 +1480,7 @@ tcExprSig expr sig@(TISI { sig_bndr = s_bndr
| otherwise = panic "tcExprSig" -- Can't happen
where
- skol_info = SigSkol ExprSigCtxt (mkCheckExpType $ mkPhiTy theta tau)
+ skol_info = SigSkol ExprSigCtxt (mkPhiTy theta tau)
skol_tvs = map snd skol_prs
{- *********************************************************************
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index 296f88c..3a03e4d 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -1270,9 +1270,8 @@ zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })
; return (ctev { ctev_pred = pred' }) }
zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo
-zonkSkolemInfo (SigSkol cx ty) = do { ty <- readExpType ty
- ; ty' <- zonkTcType ty
- ; return (SigSkol cx (mkCheckExpType ty')) }
+zonkSkolemInfo (SigSkol cx ty) = do { ty' <- zonkTcType ty
+ ; return (SigSkol cx ty') }
zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys
; return (InferSkol ntys') }
where
@@ -1458,9 +1457,7 @@ tidyEvVar env var = setVarType var (tidyType env (varType var))
----------------
tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty)
-tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (mkCheckExpType $
- tidyType env $
- checkingExpType "tidySkolemInfo" ty)
+tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty)
tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids)
tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty)
tidySkolemInfo _ info = info
diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs
index 6cc6429..513eb6d 100644
--- a/compiler/typecheck/TcPat.hs
+++ b/compiler/typecheck/TcPat.hs
@@ -398,8 +398,7 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
-- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty)
-- check that overall pattern is more polymorphic than arg type
- ; let pat_origin = GivenOrigin (SigSkol GenSigCtxt overall_pat_ty)
- ; expr_wrap2 <- tcSubTypeET pat_origin overall_pat_ty inf_arg_ty
+ ; expr_wrap2 <- tcSubTypeET (pe_orig penv) overall_pat_ty inf_arg_ty
-- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty
-- pattern must have inf_res_ty
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index a7bb56a..6021735 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -2574,7 +2574,7 @@ pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl })
-- b) an implication constraint is generated
data SkolemInfo
= SigSkol UserTypeCtxt -- A skolem that is created by instantiating
- ExpType -- a programmer-supplied type signature
+ TcType -- a programmer-supplied type signature
-- Location of the binding site is on the TyVar
| PatSynSigSkol Name -- Bound by a programmer-supplied type signature of a pattern
@@ -2653,7 +2653,7 @@ pprSkolInfo (PatSynSigSkol name) = text "the type signature of pattern synonym"
-- For Insts, these cases should not happen
pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol"
-pprSigSkolInfo :: UserTypeCtxt -> ExpType -> SDoc
+pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc
pprSigSkolInfo ctxt ty
= case ctxt of
FunSigCtxt f _ -> pp_sig f
diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
index d8f1e6a..b18671b 100644
--- a/compiler/typecheck/TcUnify.hs
+++ b/compiler/typecheck/TcUnify.hs
@@ -746,8 +746,7 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected
do { res_wrap <- tc_sub_type_ds eq_orig inst_orig ctxt act_res exp_res
; arg_wrap
<- tc_sub_tc_type eq_orig (GivenOrigin
- (SigSkol GenSigCtxt
- (mkCheckExpType exp_arg)))
+ (SigSkol GenSigCtxt exp_arg))
ctxt exp_arg act_arg
; return (mkWpFun arg_wrap res_wrap exp_arg exp_res) }
-- arg_wrap :: exp_arg ~ act_arg
@@ -883,8 +882,7 @@ tcSkolemise ctxt expected_ty thing_inside
-- Use the *instantiated* type in the SkolemInfo
-- so that the names of displayed type variables line up
- ; let skol_info = SigSkol ctxt (mkCheckExpType $
- mkFunTys (map varType given) rho')
+ ; let skol_info = SigSkol ctxt (mkFunTys (map varType given) rho')
; (ev_binds, result) <- checkConstraints skol_info tvs' given $
thing_inside tvs' rho'
More information about the ghc-commits
mailing list