Track visibility in TypeEqOrigin
authorRichard Eisenberg <rae@cs.brynmawr.edu>
Tue, 18 Jul 2017 18:30:40 +0000 (14:30 -0400)
committerRichard Eisenberg <rae@cs.brynmawr.edu>
Thu, 27 Jul 2017 11:49:06 +0000 (07:49 -0400)
A type equality error can arise from a mismatch between
*invisible* arguments just as easily as from visible arguments.
But we should really prefer printing out errors from visible
arguments over invisible ones. Suppose we have a mismatch between
`Proxy Int` and `Proxy Maybe`. Would you rather get an error
between `Int` and `Maybe`? Or between `*` and `* -> *`? I thought
so, too.

There is a fair amount of plumbing with this one, but I think
it's worth it.

This commit introduces a performance regression in test
perf/compiler/T5631. The cause of the regression is not the
new visibility stuff, directly: it's due to a change from
zipWithM to zipWith3M in TcUnify. To my surprise, zipWithM
is nicely optimized (it fuses away), but zipWith3M is not.
There are other examples of functions that could be made faster,
so I've posted a separate ticket, #14037, to track these
improvements. For now, I've accepted the small (6.6%) regression.

12 files changed:
compiler/typecheck/Inst.hs
compiler/typecheck/TcCanonical.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcType.hs
compiler/typecheck/TcUnify.hs
testsuite/tests/perf/compiler/all.T
testsuite/tests/polykinds/KindVType.stderr
testsuite/tests/typecheck/should_fail/T12373.stderr
testsuite/tests/typecheck/should_fail/T13530.stderr
testsuite/tests/typecheck/should_fail/T8603.stderr

index 9c59c0c..34e6e71 100644 (file)
@@ -407,7 +407,8 @@ tcInstBinder _ subst (Anon ty)
   | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty
   = do { let origin = TypeEqOrigin { uo_actual   = k1
                                    , uo_expected = k2
-                                   , uo_thing    = Nothing }
+                                   , uo_thing    = Nothing
+                                   , uo_visible  = True }
        ; co <- case role of
                  Nominal          -> unifyKind Nothing k1 k2
                  Representational -> emitWantedEq origin KindLevel role k1 k2
index 7c061bb..23de0e5 100644 (file)
@@ -930,7 +930,10 @@ can_eq_app ev NomEq s1 t1 s2 t2
        ; stopWith ev "Decomposed [D] AppTy" }
   | CtWanted { ctev_dest = dest, ctev_loc = loc } <- ev
   = do { co_s <- unifyWanted loc Nominal s1 s2
-       ; co_t <- unifyWanted loc Nominal t1 t2
+       ; let arg_loc
+               | isNextArgVisible s1 = loc
+               | otherwise           = updateCtLocOrigin loc toInvisibleOrigin
+       ; co_t <- unifyWanted arg_loc Nominal t1 t2
        ; let co = mkAppCo co_s co_t
        ; setWantedEq dest co
        ; stopWith ev "Decomposed [W] AppTy" }
@@ -1224,13 +1227,16 @@ canDecomposableTyConAppOK ev eq_rel tc tys1 tys2
       -- the following makes a better distinction between "kind" and "type"
       -- in error messages
     bndrs      = tyConBinders tc
-    kind_loc   = toKindLoc loc
     is_kinds   = map isNamedTyConBinder bndrs
-    new_locs | Just KindLevel <- ctLocTypeOrKind_maybe loc
-             = repeat loc
-             | otherwise
-             = map (\is_kind -> if is_kind then kind_loc else loc) is_kinds
+    is_viss    = map isVisibleTyConBinder bndrs
 
+    kind_xforms = map (\is_kind -> if is_kind then toKindLoc else id) is_kinds
+    vis_xforms  = map (\is_vis  -> if is_vis  then id
+                                   else flip updateCtLocOrigin toInvisibleOrigin)
+                      is_viss
+
+    -- zipWith3 (.) composes its first two arguments and applies it to the third
+    new_locs = zipWith3 (.) kind_xforms vis_xforms (repeat loc)
 
 -- | Call when canonicalizing an equality fails, but if the equality is
 -- representational, there is some hope for the future.
index 3c6a1b7..63bc016 100644 (file)
@@ -481,8 +481,7 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl
     -- type checking to get a Lint error later
     report1 = [ ("custom_error", is_user_type_error,True, mkUserTypeErrorReporter)
               , given_eq_spec
-              , ("insoluble2 ty", utterly_wrong_ty, True, mkGroupReporter mkEqErr)
-              , ("insoluble2_ki", utterly_wrong,    True, mkGroupReporter mkEqErr)
+              , ("insoluble2",    utterly_wrong,    True, mkGroupReporter mkEqErr)
               , ("skolem eq1",    very_wrong,       True, mkSkolReporter)
               , ("skolem eq2",    skolem_eq,        True, mkSkolReporter)
               , ("non-tv eq",     non_tv_eq,        True, mkSkolReporter)
@@ -515,12 +514,6 @@ reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_insol = insols, wc_impl
     utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2
     utterly_wrong _ _                      = False
 
-     -- Like utterly_wrong, but suppress derived kind equalities
-    utterly_wrong_ty ct pred
-      = utterly_wrong ct pred && case ctOrigin ct of
-                                   KindEqOrigin {} -> False
-                                   _               -> True
-
     -- Things like (a ~N Int)
     very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2
     very_wrong _ _                      = False
@@ -829,17 +822,21 @@ maybeAddDeferredHoleBinding ctxt err ct
 tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])
 -- Use the first reporter in the list whose predicate says True
 tryReporters ctxt reporters cts
-  = do { traceTc "tryReporters {" (ppr cts)
-       ; (ctxt', cts') <- go ctxt reporters cts
+  = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts
+       ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts)
+       ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts
        ; traceTc "tryReporters }" (ppr cts')
        ; return (ctxt', cts') }
   where
-    go ctxt [] cts
-      = return (ctxt, cts)
-
-    go ctxt (r : rs) cts
-      = do { (ctxt', cts') <- tryReporter ctxt r cts
-           ; go ctxt' rs cts' }
+    go ctxt [] vis_cts invis_cts
+      = return (ctxt, vis_cts ++ invis_cts)
+
+    go ctxt (r : rs) vis_cts invis_cts
+       -- always look at *visible* Origins before invisible ones
+       -- this is the whole point of isVisibleOrigin
+      = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts
+           ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts
+           ; go ctxt'' rs vis_cts' invis_cts' }
                 -- Carry on with the rest, because we must make
                 -- deferred bindings for them if we have -fdefer-type-errors
                 -- But suppress their error messages
index bca9cc3..185c034 100644 (file)
@@ -902,8 +902,9 @@ checkExpectedKind hs_ty ty act_kind exp_kind
  = do { (ty', act_kind') <- instantiate ty act_kind exp_kind
       ; let origin = TypeEqOrigin { uo_actual   = act_kind'
                                   , uo_expected = exp_kind
-                                  , uo_thing    = Just (ppr hs_ty) }
-      ; co_k <- uType origin KindLevel act_kind' exp_kind
+                                  , uo_thing    = Just (ppr hs_ty)
+                                  , uo_visible  = True } -- the hs_ty is visible
+      ; co_k <- uType KindLevel origin act_kind' exp_kind
       ; traceTc "checkExpectedKind" (vcat [ ppr act_kind
                                           , ppr exp_kind
                                           , ppr co_k ])
index a95079e..e30c33e 100644 (file)
@@ -95,8 +95,9 @@ module TcRnTypes(
         CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin,
         ctLocTypeOrKind_maybe,
         ctLocDepth, bumpCtLocDepth,
-        setCtLocOrigin, setCtLocEnv, setCtLocSpan,
+        setCtLocOrigin, updateCtLocOrigin, setCtLocEnv, setCtLocSpan,
         CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,
+        isVisibleOrigin, toInvisibleOrigin,
         TypeOrKind(..), isTypeLevel, isKindLevel,
         pprCtOrigin, pprCtLoc,
         pushErrCtxt, pushErrCtxtSameOrigin,
@@ -2969,6 +2970,10 @@ bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDept
 setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc
 setCtLocOrigin ctl orig = ctl { ctl_origin = orig }
 
+updateCtLocOrigin :: CtLoc -> (CtOrigin -> CtOrigin) -> CtLoc
+updateCtLocOrigin ctl@(CtLoc { ctl_origin = orig }) upd
+  = ctl { ctl_origin = upd orig }
+
 setCtLocEnv :: CtLoc -> TcLclEnv -> CtLoc
 setCtLocEnv ctl env = ctl { ctl_env = env }
 
@@ -3160,7 +3165,11 @@ data CtOrigin
   | TypeEqOrigin { uo_actual   :: TcType
                  , uo_expected :: TcType
                  , uo_thing    :: Maybe SDoc
-                                  -- ^ The thing that has type "actual"
+                       -- ^ The thing that has type "actual"
+                 , uo_visible  :: Bool
+                       -- ^ Is at least one of the three elements above visible?
+                       -- (Errors from the polymorphic subsumption check are considered
+                       -- visible.) Only used for prioritizing error messages.
                  }
 
   | KindEqOrigin
@@ -3252,6 +3261,21 @@ isKindLevel :: TypeOrKind -> Bool
 isKindLevel TypeLevel = False
 isKindLevel KindLevel = True
 
+-- An origin is visible if the place where the constraint arises is manifest
+-- in user code. Currently, all origins are visible except for invisible
+-- TypeEqOrigins. This is used when choosing which error of
+-- several to report
+isVisibleOrigin :: CtOrigin -> Bool
+isVisibleOrigin (TypeEqOrigin { uo_visible = vis }) = vis
+isVisibleOrigin (KindEqOrigin _ _ sub_orig _)       = isVisibleOrigin sub_orig
+isVisibleOrigin _                                   = True
+
+-- Converts a visible origin to an invisible one, if possible. Currently,
+-- this works only for TypeEqOrigin
+toInvisibleOrigin :: CtOrigin -> CtOrigin
+toInvisibleOrigin orig@(TypeEqOrigin {}) = orig { uo_visible = False }
+toInvisibleOrigin orig                   = orig
+
 instance Outputable CtOrigin where
   ppr = pprCtOrigin
 
@@ -3451,7 +3475,7 @@ pprCtO DefaultOrigin         = text "a 'default' declaration"
 pprCtO DoOrigin              = text "a do statement"
 pprCtO MCompOrigin           = text "a statement in a monad comprehension"
 pprCtO ProcOrigin            = text "a proc expression"
-pprCtO (TypeEqOrigin t1 t2 _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2]
+pprCtO (TypeEqOrigin t1 t2 _ _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2]
 pprCtO AnnOrigin             = text "an annotation"
 pprCtO HoleOrigin            = text "a use of" <+> quotes (text "_")
 pprCtO ListOrigin            = text "an overloaded list"
index 9d53910..3b97555 100644 (file)
@@ -58,7 +58,7 @@ module TcType (
   -- These are important because they do not look through newtypes
   getTyVar,
   tcSplitForAllTy_maybe,
-  tcSplitForAllTys, tcSplitPiTys, tcSplitForAllTyVarBndrs,
+  tcSplitForAllTys, tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllTyVarBndrs,
   tcSplitPhiTy, tcSplitPredFunTy_maybe,
   tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN,
   tcSplitFunTysN,
@@ -187,7 +187,11 @@ module TcType (
   pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred,
   pprTvBndr, pprTvBndrs,
 
-  TypeSize, sizeType, sizeTypes, toposortTyVars
+  TypeSize, sizeType, sizeTypes, toposortTyVars,
+
+  ---------------------------------
+  -- argument visibility
+  tcTyConVisibilities, isNextTyConArgVisible, isNextArgVisible
 
   ) where
 
@@ -220,6 +224,7 @@ import BasicTypes
 import Util
 import Bag
 import Maybes
+import ListSetOps ( getNth )
 import Outputable
 import FastString
 import ErrUtils( Validity(..), MsgDoc, isValid )
@@ -1358,6 +1363,10 @@ variables.  It's up to you to make sure this doesn't matter.
 tcSplitPiTys :: Type -> ([TyBinder], Type)
 tcSplitPiTys = splitPiTys
 
+-- | Splits a type into a TyBinder and a body, if possible. Panics otherwise
+tcSplitPiTy_maybe :: Type -> Maybe (TyBinder, Type)
+tcSplitPiTy_maybe = splitPiTy_maybe
+
 tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type)
 tcSplitForAllTy_maybe ty | Just ty' <- tcView ty = tcSplitForAllTy_maybe ty'
 tcSplitForAllTy_maybe (ForAllTy tv ty) = Just (tv, ty)
@@ -2590,3 +2599,28 @@ sizeType = go
 
 sizeTypes :: [Type] -> TypeSize
 sizeTypes tys = sum (map sizeType tys)
+
+-----------------------------------------------------------------------------------
+-----------------------------------------------------------------------------------
+-----------------------
+-- | For every arg a tycon can take, the returned list says True if the argument
+-- is taken visibly, and False otherwise. Ends with an infinite tail of Trues to
+-- allow for oversaturation.
+tcTyConVisibilities :: TyCon -> [Bool]
+tcTyConVisibilities tc = tc_binder_viss ++ tc_return_kind_viss ++ repeat True
+  where
+    tc_binder_viss      = map isVisibleTyConBinder (tyConBinders tc)
+    tc_return_kind_viss = map isVisibleBinder (fst $ tcSplitPiTys (tyConResKind tc))
+
+-- | If the tycon is applied to the types, is the next argument visible?
+isNextTyConArgVisible :: TyCon -> [Type] -> Bool
+isNextTyConArgVisible tc tys
+  = tcTyConVisibilities tc `getNth` length tys
+
+-- | Should this type be applied to a visible argument?
+isNextArgVisible :: TcType -> Bool
+isNextArgVisible ty
+  | Just (bndr, _) <- tcSplitPiTy_maybe ty = isVisibleBinder bndr
+  | otherwise                              = True
+    -- this second case might happen if, say, we have an unzonked TauTv.
+    -- But TauTvs can't range over types that take invisible arguments
index e09b5bf..269f202 100644 (file)
@@ -544,7 +544,8 @@ tcSubTypeET orig ctxt (Check ty_actual) ty_expected
   where
     eq_orig = TypeEqOrigin { uo_actual   = ty_expected
                            , uo_expected = ty_actual
-                           , uo_thing    = Nothing }
+                           , uo_thing    = Nothing
+                           , uo_visible  = True }
 
 tcSubTypeET _ _ (Infer inf_res) ty_expected
   = ASSERT2( not (ir_inst inf_res), ppr inf_res $$ ppr ty_expected )
@@ -602,7 +603,8 @@ tcSubType_NC ctxt ty_actual ty_expected
   where
     origin = TypeEqOrigin { uo_actual   = ty_actual
                           , uo_expected = ty_expected
-                          , uo_thing    = Nothing }
+                          , uo_thing    = Nothing
+                          , uo_visible  = True }
 
 tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWrapper
 -- Just like tcSubType, but with the additional precondition that
@@ -624,7 +626,8 @@ tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected
       Check ty      -> tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty
          where
            eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty
-                                  , uo_thing  = ppr <$> m_thing }
+                                  , uo_thing  = ppr <$> m_thing
+                                  , uo_visible = True }
 
 ---------------
 tc_sub_tc_type :: CtOrigin   -- used when calling uType
@@ -639,7 +642,7 @@ tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected
          vcat [ text "ty_actual   =" <+> ppr ty_actual
               , text "ty_expected =" <+> ppr ty_expected ]
        ; mkWpCastN <$>
-         uType eq_orig TypeLevel ty_actual ty_expected }
+         uType TypeLevel eq_orig ty_actual ty_expected }
 
   | otherwise   -- This is the general case
   = do { traceTc "tc_sub_tc_type (general case)" $
@@ -785,12 +788,12 @@ tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected
                                   -> eq_orig { uo_actual = rho_a }
                                 _ -> eq_orig
 
-                        ; cow <- uType eq_orig' TypeLevel rho_a ty_expected
+                        ; cow <- uType TypeLevel eq_orig' rho_a ty_expected
                         ; return (mkWpCastN cow <.> wrap) }
 
 
      -- use versions without synonyms expanded
-    unify = mkWpCastN <$> uType eq_orig TypeLevel ty_actual ty_expected
+    unify = mkWpCastN <$> uType TypeLevel eq_orig ty_actual ty_expected
 
 -----------------
 -- needs both un-type-checked (for origins) and type-checked (for wrapping)
@@ -954,7 +957,8 @@ promoteTcType dest_lvl ty
            ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr)
            ; let eq_orig = TypeEqOrigin { uo_actual   = ty
                                         , uo_expected = prom_ty
-                                        , uo_thing    = Nothing }
+                                        , uo_thing    = Nothing
+                                        , uo_visible  = False }
 
            ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty
            ; return (co, prom_ty) }
@@ -965,8 +969,9 @@ promoteTcType dest_lvl ty
            ; let ty_kind = typeKind ty
                  kind_orig = TypeEqOrigin { uo_actual   = ty_kind
                                           , uo_expected = res_kind
-                                          , uo_thing    = Nothing }
-           ; ki_co <- uType kind_orig KindLevel (typeKind ty) res_kind
+                                          , uo_thing    = Nothing
+                                          , uo_visible  = False }
+           ; ki_co <- uType KindLevel kind_orig (typeKind ty) res_kind
            ; let co = mkTcNomReflCo ty `mkTcCoherenceRightCo` ki_co
            ; return (co, ty `mkCastTy` ki_co) }
 
@@ -1185,16 +1190,18 @@ unifyType :: Maybe (HsExpr GhcRn)   -- ^ If present, has type 'ty1'
 -- Actual and expected types
 -- Returns a coercion : ty1 ~ ty2
 unifyType thing ty1 ty2 = traceTc "utype" (ppr ty1 $$ ppr ty2 $$ ppr thing) >>
-                          uType origin TypeLevel ty1 ty2
+                          uType TypeLevel origin ty1 ty2
   where
     origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2
-                          , uo_thing  = ppr <$> thing }
+                          , uo_thing  = ppr <$> thing
+                          , uo_visible = True } -- always called from a visible context
 
 unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN
 unifyKind thing ty1 ty2 = traceTc "ukind" (ppr ty1 $$ ppr ty2 $$ ppr thing) >>
-                          uType origin KindLevel ty1 ty2
+                          uType KindLevel origin ty1 ty2
   where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2
-                              , uo_thing  = ppr <$> thing }
+                              , uo_thing  = ppr <$> thing
+                              , uo_visible = True } -- also always from a visible context
 
 ---------------
 unifyPred :: PredType -> PredType -> TcM TcCoercionN
@@ -1221,8 +1228,8 @@ uType is the heart of the unifier.
 -}
 
 uType, uType_defer
-  :: CtOrigin
-  -> TypeOrKind
+  :: TypeOrKind
+  -> CtOrigin
   -> TcType    -- ty1 is the *actual* type
   -> TcType    -- ty2 is the *expected* type
   -> TcM Coercion
@@ -1230,7 +1237,7 @@ uType, uType_defer
 --------------
 -- It is always safe to defer unification to the main constraint solver
 -- See Note [Deferred unification]
-uType_defer origin t_or_k ty1 ty2
+uType_defer t_or_k origin ty1 ty2
   = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2
 
        -- Error trace only
@@ -1245,7 +1252,7 @@ uType_defer origin t_or_k ty1 ty2
        ; return co }
 
 --------------
-uType origin t_or_k orig_ty1 orig_ty2
+uType t_or_k origin orig_ty1 orig_ty2
   = do { tclvl <- getTcLevel
        ; traceTc "u_tys" $ vcat
               [ text "tclvl" <+> ppr tclvl
@@ -1305,8 +1312,8 @@ uType origin t_or_k orig_ty1 orig_ty2
 
         -- Functions (or predicate functions) just check the two parts
     go (FunTy fun1 arg1) (FunTy fun2 arg2)
-      = do { co_l <- uType origin t_or_k fun1 fun2
-           ; co_r <- uType origin t_or_k arg1 arg2
+      = do { co_l <- uType t_or_k origin fun1 fun2
+           ; co_r <- uType t_or_k origin arg1 arg2
            ; return $ mkFunCo Nominal co_l co_r }
 
         -- Always defer if a type synonym family (type function)
@@ -1320,8 +1327,11 @@ uType origin t_or_k orig_ty1 orig_ty2
       -- See Note [Mismatched type lists and application decomposition]
       | tc1 == tc2, equalLength tys1 tys2
       = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )
-        do { cos <- zipWithM (uType origin t_or_k) tys1 tys2
+        do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2
            ; return $ mkTyConAppCo Nominal tc1 cos }
+      where
+        origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin)
+                       (tcTyConVisibilities tc1)
 
     go (LitTy m) ty@(LitTy n)
       | m == n
@@ -1331,24 +1341,24 @@ uType origin t_or_k orig_ty1 orig_ty2
         -- Do not decompose FunTy against App;
         -- it's often a type error, so leave it for the constraint solver
     go (AppTy s1 t1) (AppTy s2 t2)
-      = go_app s1 t1 s2 t2
+      = go_app (isNextArgVisible s1) s1 t1 s2 t2
 
     go (AppTy s1 t1) (TyConApp tc2 ts2)
       | Just (ts2', t2') <- snocView ts2
       = ASSERT( mightBeUnsaturatedTyCon tc2 )
-        go_app s1 t1 (TyConApp tc2 ts2') t2'
+        go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'
 
     go (TyConApp tc1 ts1) (AppTy s2 t2)
       | Just (ts1', t1') <- snocView ts1
       = ASSERT( mightBeUnsaturatedTyCon tc1 )
-        go_app (TyConApp tc1 ts1') t1' s2 t2
+        go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2
 
     go (CoercionTy co1) (CoercionTy co2)
       = do { let ty1 = coercionType co1
                  ty2 = coercionType co2
-           ; kco <- uType (KindEqOrigin orig_ty1 (Just orig_ty2) origin
+           ; kco <- uType KindLevel
+                          (KindEqOrigin orig_ty1 (Just orig_ty2) origin
                                         (Just t_or_k))
-                          KindLevel
                           ty1 ty2
            ; return $ mkProofIrrelCo Nominal kco co1 co2 }
 
@@ -1359,12 +1369,15 @@ uType origin t_or_k orig_ty1 orig_ty2
     ------------------
     defer ty1 ty2   -- See Note [Check for equality before deferring]
       | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1)
-      | otherwise          = uType_defer origin t_or_k ty1 ty2
+      | otherwise          = uType_defer t_or_k origin ty1 ty2
 
     ------------------
-    go_app s1 t1 s2 t2
-      = do { co_s <- uType origin t_or_k s1 s2
-           ; co_t <- uType origin t_or_k t1 t2
+    go_app vis s1 t1 s2 t2
+      = do { co_s <- uType t_or_k origin s1 s2
+           ; let arg_origin
+                   | vis       = origin
+                   | otherwise = toInvisibleOrigin origin
+           ; co_t <- uType t_or_k arg_origin t1 t2
            ; return $ mkAppCo co_s co_t }
 
 {- Note [Check for equality before deferring]
@@ -1518,7 +1531,7 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2
     go dflags cur_lvl
       | canSolveByUnification cur_lvl tv1 ty2
       , Just ty2' <- metaTyVarUpdateOK dflags tv1 ty2
-      = do { co_k <- uType kind_origin KindLevel (typeKind ty2') (tyVarKind tv1)
+      = do { co_k <- uType KindLevel kind_origin (typeKind ty2') (tyVarKind tv1)
            ; if isTcReflCo co_k  -- only proceed if the kinds matched.
 
              then do { writeMetaTyVar tv1 ty2'
@@ -1536,7 +1549,7 @@ uUnfilledVar2 origin t_or_k swapped tv1 ty2
     ty1 = mkTyVarTy tv1
     kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k)
 
-    defer = unSwap swapped (uType_defer origin t_or_k) ty1 ty2
+    defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2
 
 swapOverTyVars :: TcTyVar -> TcTyVar -> Bool
 swapOverTyVars tv1 tv2
@@ -1795,8 +1808,9 @@ matchExpectedFunKind hs_ty = go
                  origin  = TypeEqOrigin { uo_actual   = k
                                         , uo_expected = new_fun
                                         , uo_thing    = Just (ppr hs_ty)
+                                        , uo_visible  = True
                                         }
-           ; co <- uType origin KindLevel k new_fun
+           ; co <- uType KindLevel origin k new_fun
            ; return (co, arg_kind, res_kind) }
 
 
index 0389271..baca57c 100644 (file)
@@ -444,7 +444,7 @@ test('T5631',
         # 2014-04-04:     346389856 (x86 Windows, 64 bit machine)
         # 2014-12-01:     390199244 (Windows laptop)
         # 2016-04-06:     570137436 (amd64/Linux) many reasons
-           (wordsize(64), 1037482512, 5)]),
+           (wordsize(64), 1106015512, 5)]),
         # expected value: 774595008 (amd64/Linux):
         # expected value: 735486328 (amd64/Linux) 2012/12/12:
         # expected value: 690742040 (amd64/Linux) Call Arity improvements
@@ -459,6 +459,8 @@ test('T5631',
         # 2017-02-17:     1517484488 (amd64/Linux) Type-indexed Typeable
         # 2017-03-03:     1065147968 (amd64/Linux) Share Typeable KindReps
         # 2017-03-31:     1037482512 (amd64/Linux) Fix memory leak in simplifier
+       # 2017-07-27:     1106015512 (Mac) Regresssion from tracking visibility in TypeEqOrigin
+       #                                  should be fixed by #14037
        only_ways(['normal'])
       ],
      compile,
index 7ce3404..27e2e58 100644 (file)
@@ -1,6 +1,6 @@
 
 KindVType.hs:8:8: error:
-    • Couldn't match type ‘*’ with ‘* -> *
+    • Couldn't match type ‘Int’ with ‘Maybe
       Expected type: Proxy Maybe
         Actual type: Proxy Int
     • In the expression: (Proxy :: Proxy Int)
index 45852b8..d3a4bb5 100644 (file)
@@ -1,6 +1,9 @@
 
 T12373.hs:10:19: error:
     • Couldn't match a lifted type with an unlifted type
+      When matching types
+        a1 :: *
+        MVar# RealWorld a0 :: TYPE 'UnliftedRep
       Expected type: (# State# RealWorld, a1 #)
         Actual type: (# State# RealWorld, MVar# RealWorld a0 #)
     • In the expression: newMVar# rw
index 8760bcb..139c1b0 100644 (file)
@@ -1,6 +1,9 @@
 
 T13530.hs:11:7: error:
     • Couldn't match a lifted type with an unlifted type
+      When matching types
+        a0 :: *
+        Int# :: TYPE 'IntRep
       Expected type: (# Int#, Int# #)
         Actual type: (# Int#, a0 #)
     • In the expression: g x
index d22d13f..2ee5ad4 100644 (file)
@@ -1,6 +1,9 @@
 
 T8603.hs:33:17: error:
-    • Couldn't match type ‘RV a1’ with ‘StateT s RV a0’
+    • Couldn't match kind ‘* -> *’ with ‘*’
+      When matching types
+        t0 :: (* -> *) -> * -> *
+        (->) :: * -> * -> *
       Expected type: [Integer] -> StateT s RV a0
         Actual type: t0 ((->) [a1]) (RV a1)
     • The function ‘lift’ is applied to two arguments,
@@ -10,5 +13,3 @@ T8603.hs:33:17: error:
       In the expression:
         do prize <- lift uniform [1, 2, ....]
            return False
-    • Relevant bindings include
-        testRVState1 :: RVState s Bool (bound at T8603.hs:32:1)