Make SigSkol take TcType not ExpType
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 30 Mar 2016 16:23:37 +0000 (17:23 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Thu, 31 Mar 2016 07:04:09 +0000 (08:04 +0100)
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.

compiler/typecheck/TcBinds.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcMType.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcUnify.hs

index 6ce9aed..3bad211 100644 (file)
@@ -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 }))
index 5eb28f0..a65e60f 100644 (file)
@@ -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
 
 {- *********************************************************************
index 296f88c..3a03e4d 100644 (file)
@@ -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
index 6cc6429..513eb6d 100644 (file)
@@ -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
index a7bb56a..6021735 100644 (file)
@@ -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
index d8f1e6a..b18671b 100644 (file)
@@ -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'