Commit 0ad2021b authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent 174d3a53
...@@ -585,7 +585,7 @@ tcPolyCheck rec_tc prag_fn ...@@ -585,7 +585,7 @@ tcPolyCheck rec_tc prag_fn
, sig_loc = loc }) , sig_loc = loc })
bind bind
= do { ev_vars <- newEvVars theta = 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 prag_sigs = lookupPragEnv prag_fn name
skol_tvs = map snd skol_prs skol_tvs = map snd skol_prs
-- Find the location of the original source type sig, if -- Find the location of the original source type sig, if
...@@ -764,7 +764,7 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing ...@@ -764,7 +764,7 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing
; return (binders, my_theta) } ; return (binders, my_theta) }
chooseInferredQuantifiers inferred_theta tau_tvs qtvs chooseInferredQuantifiers inferred_theta tau_tvs qtvs
(Just (TISI { sig_bndr = bndr_info (Just (TISI { sig_bndr = bndr_info -- Always PartialSig
, sig_ctxt = ctxt , sig_ctxt = ctxt
, sig_theta = annotated_theta , sig_theta = annotated_theta
, sig_skols = annotated_tvs })) , sig_skols = annotated_tvs }))
......
...@@ -1480,7 +1480,7 @@ tcExprSig expr sig@(TISI { sig_bndr = s_bndr ...@@ -1480,7 +1480,7 @@ tcExprSig expr sig@(TISI { sig_bndr = s_bndr
| otherwise = panic "tcExprSig" -- Can't happen | otherwise = panic "tcExprSig" -- Can't happen
where where
skol_info = SigSkol ExprSigCtxt (mkCheckExpType $ mkPhiTy theta tau) skol_info = SigSkol ExprSigCtxt (mkPhiTy theta tau)
skol_tvs = map snd skol_prs skol_tvs = map snd skol_prs
{- ********************************************************************* {- *********************************************************************
......
...@@ -1270,9 +1270,8 @@ zonkCtEvidence ctev@(CtDerived { ctev_pred = pred }) ...@@ -1270,9 +1270,8 @@ zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })
; return (ctev { ctev_pred = pred' }) } ; return (ctev { ctev_pred = pred' }) }
zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo
zonkSkolemInfo (SigSkol cx ty) = do { ty <- readExpType ty zonkSkolemInfo (SigSkol cx ty) = do { ty' <- zonkTcType ty
; ty' <- zonkTcType ty ; return (SigSkol cx ty') }
; return (SigSkol cx (mkCheckExpType ty')) }
zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys
; return (InferSkol ntys') } ; return (InferSkol ntys') }
where where
...@@ -1458,9 +1457,7 @@ tidyEvVar env var = setVarType var (tidyType env (varType var)) ...@@ -1458,9 +1457,7 @@ tidyEvVar env var = setVarType var (tidyType env (varType var))
---------------- ----------------
tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty) tidySkolemInfo env (DerivSkol ty) = DerivSkol (tidyType env ty)
tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (mkCheckExpType $ tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty)
tidyType env $
checkingExpType "tidySkolemInfo" ty)
tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids) tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids)
tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty) tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty)
tidySkolemInfo _ info = info tidySkolemInfo _ info = info
...@@ -398,8 +398,7 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside ...@@ -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) -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty)
-- check that overall pattern is more polymorphic than arg type -- check that overall pattern is more polymorphic than arg type
; let pat_origin = GivenOrigin (SigSkol GenSigCtxt overall_pat_ty) ; expr_wrap2 <- tcSubTypeET (pe_orig penv) overall_pat_ty inf_arg_ty
; expr_wrap2 <- tcSubTypeET pat_origin overall_pat_ty inf_arg_ty
-- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty
-- pattern must have inf_res_ty -- pattern must have inf_res_ty
......
...@@ -2574,7 +2574,7 @@ pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl }) ...@@ -2574,7 +2574,7 @@ pushErrCtxtSameOrigin err loc@(CtLoc { ctl_env = lcl })
-- b) an implication constraint is generated -- b) an implication constraint is generated
data SkolemInfo data SkolemInfo
= SigSkol UserTypeCtxt -- A skolem that is created by instantiating = 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 -- Location of the binding site is on the TyVar
| PatSynSigSkol Name -- Bound by a programmer-supplied type signature of a pattern | 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" ...@@ -2653,7 +2653,7 @@ pprSkolInfo (PatSynSigSkol name) = text "the type signature of pattern synonym"
-- For Insts, these cases should not happen -- For Insts, these cases should not happen
pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol" pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) text "UnkSkol"
pprSigSkolInfo :: UserTypeCtxt -> ExpType -> SDoc pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc
pprSigSkolInfo ctxt ty pprSigSkolInfo ctxt ty
= case ctxt of = case ctxt of
FunSigCtxt f _ -> pp_sig f FunSigCtxt f _ -> pp_sig f
......
...@@ -746,8 +746,7 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected ...@@ -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 do { res_wrap <- tc_sub_type_ds eq_orig inst_orig ctxt act_res exp_res
; arg_wrap ; arg_wrap
<- tc_sub_tc_type eq_orig (GivenOrigin <- tc_sub_tc_type eq_orig (GivenOrigin
(SigSkol GenSigCtxt (SigSkol GenSigCtxt exp_arg))
(mkCheckExpType exp_arg)))
ctxt exp_arg act_arg ctxt exp_arg act_arg
; return (mkWpFun arg_wrap res_wrap exp_arg exp_res) } ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res) }
-- arg_wrap :: exp_arg ~ act_arg -- arg_wrap :: exp_arg ~ act_arg
...@@ -883,8 +882,7 @@ tcSkolemise ctxt expected_ty thing_inside ...@@ -883,8 +882,7 @@ tcSkolemise ctxt expected_ty thing_inside
-- Use the *instantiated* type in the SkolemInfo -- Use the *instantiated* type in the SkolemInfo
-- so that the names of displayed type variables line up -- so that the names of displayed type variables line up
; let skol_info = SigSkol ctxt (mkCheckExpType $ ; let skol_info = SigSkol ctxt (mkFunTys (map varType given) rho')
mkFunTys (map varType given) rho')
; (ev_binds, result) <- checkConstraints skol_info tvs' given $ ; (ev_binds, result) <- checkConstraints skol_info tvs' given $
thing_inside tvs' rho' thing_inside tvs' rho'
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment