Vladislav Zavialov pushed to branch wip/int-index/no-kind-mismatch at Glasgow Haskell Compiler / GHC

Commits:

4 changed files:

Changes:

  • compiler/GHC/Tc/Errors/Ppr.hs
    ... ... @@ -4396,21 +4396,6 @@ pprMismatchMsg ctxt
    4396 4396 
         conc :: [String] -> String
    4397 4397 
         conc = unwords . filter (not . null)
    4398 4398
    4399 
    -pprMismatchMsg _
    4400 
    -  (KindMismatch { kmismatch_what     = thing
    4401 
    -                , kmismatch_expected = exp
    4402 
    -                , kmismatch_actual   = act })
    4403 
    -  = hang (text "Expected" <+> kind_desc <> comma)
    4404 
    -      2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+>
    4405 
    -        quotes (ppr act))
    4406 
    -  where
    4407 
    -    kind_desc | isConstraintLikeKind exp = text "a constraint"
    4408 
    -              | Just arg <- kindRep_maybe exp  -- TYPE t0
    4409 
    -              , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case
    4410 
    -                                   True  -> text "kind" <+> quotes (ppr exp)
    4411 
    -                                   False -> text "a type"
    4412 
    -              | otherwise       = text "kind" <+> quotes (ppr exp)
    4413 
    -
    4414 4399 
     pprMismatchMsg ctxt
    4415 4400 
       (TypeEqMismatch { teq_mismatch_item     = item
    4416 4401 
                       , teq_mismatch_ty1      = ty1   -- These types are the actual types
    ... ... @@ -4429,11 +4414,11 @@ pprMismatchMsg ctxt
    4429 4414
    4430 4415 
             | Just nargs_msg <- num_args_msg
    4431 4416 
             , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig
    4432 
    -        = nargs_msg $$ pprMismatchMsg ctxt ea_msg
    4417 
    +        = nargs_msg $$ ea_msg
    4433 4418
    4434 4419 
             | ea_looks_same ty1 ty2 exp act
    4435 4420 
             , Right ea_msg <- mk_ea_msg ctxt (Just item) level orig
    4436 
    -        = pprMismatchMsg ctxt ea_msg
    4421 
    +        = ea_msg
    4437 4422
    4438 4423 
             | otherwise
    4439 4424 
             = bale_out_msg
    ... ... @@ -4445,7 +4430,7 @@ pprMismatchMsg ctxt
    4445 4430 
                       Left ea_info -> pprMismatchMsg ctxt mismatch_err
    4446 4431 
                                     : map (pprExpectedActualInfo ctxt) ea_info
    4447 4432 
                       Right ea_err -> [ pprMismatchMsg ctxt mismatch_err
    4448 
    -                                  , pprMismatchMsg ctxt ea_err ]
    4433 
    +                                  , ea_err ]
    4449 4434 
             mismatch_err = mkBasicMismatchMsg NoEA item ty1 ty2
    4450 4435
    4451 4436 
           -- 'expected' is (TYPE rep) or (CONSTRAINT rep)
    ... ... @@ -4542,7 +4527,7 @@ pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra)
    4542 4527 
           Left infos
    4543 4528 
             -> vcat (map (pprExpectedActualInfo ctxt) infos)
    4544 4529 
           Right other_msg
    4545 
    -        -> pprMismatchMsg ctxt other_msg
    4530 
    +        -> other_msg
    4546 4531 
       where
    4547 4532 
         main_msg
    4548 4533 
           | null useful_givens
    ... ... @@ -4577,6 +4562,18 @@ pprMismatchMsg ctxt (CouldNotDeduce useful_givens (item :| others) mb_extra)
    4577 4562 
             [wanted] -> quotes (ppr wanted)
    4578 4563 
             _        -> pprTheta wanteds
    4579 4564
    4565 
    +pprKindMismatchMsg :: TypedThing -> Type -> Type -> SDoc
    4566 
    +pprKindMismatchMsg thing exp act
    4567 
    +  = hang (text "Expected" <+> kind_desc <> comma)
    4568 
    +      2 (text "but" <+> quotes (ppr thing) <+> text "has kind" <+>
    4569 
    +        quotes (ppr act))
    4570 
    +  where
    4571 
    +    kind_desc | isConstraintLikeKind exp = text "a constraint"
    4572 
    +              | Just arg <- kindRep_maybe exp  -- TYPE t0
    4573 
    +              , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case
    4574 
    +                                   True  -> text "kind" <+> quotes (ppr exp)
    4575 
    +                                   False -> text "a type"
    4576 
    +              | otherwise       = text "kind" <+> quotes (ppr exp)
    4580 4577
    4581 4578 
     -- | Whether to print explicit kinds (with @-fprint-explicit-kinds@)
    4582 4579 
     -- in an 'SDoc' when a type mismatch occurs to due invisible parts of the types.
    ... ... @@ -4871,7 +4868,7 @@ pprWhenMatching ctxt (WhenMatching cty1 cty2 sub_o mb_sub_t_or_k) =
    4871 4868 
         supplementary =
    4872 4869 
           case mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o of
    4873 4870 
             Left infos -> vcat $ map (pprExpectedActualInfo ctxt) infos
    4874 
    -        Right msg  -> pprMismatchMsg ctxt msg
    4871 
    +        Right msg  -> msg
    4875 4872
    4876 4873 
     pprTyVarInfo :: SolverReportErrCtxt -> TyVarInfo -> SDoc
    4877 4874 
     pprTyVarInfo ctxt (TyVarInfo { thisTyVar = tv1, otherTy = mb_tv2, thisTyVarIsUntouchable = mb_implic })
    ... ... @@ -5102,8 +5099,6 @@ mismatchMsg_ExpectedActuals :: MismatchMsg -> Maybe (Type, Type)
    5102 5099 
     mismatchMsg_ExpectedActuals = \case
    5103 5100 
       BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->
    5104 5101 
         Just (exp, act)
    5105 
    -  KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } ->
    5106 
    -    Just (exp, act)
    5107 5102 
       TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->
    5108 5103 
         Just (exp,act)
    5109 5104 
       CouldNotDeduce { cnd_extra = cnd_extra }
    ... ... @@ -5429,7 +5424,7 @@ skolsSpan skol_tvs = foldr1WithDefault noSrcSpan combineSrcSpans (map getSrcSpan
    5429 5424 
     **********************************************************************-}
    5430 5425
    5431 5426 
     mk_supplementary_ea_msg :: SolverReportErrCtxt -> TypeOrKind
    5432 
    -                        -> Type -> Type -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg
    5427 
    +                        -> Type -> Type -> CtOrigin -> Either [ExpectedActualInfo] SDoc
    5433 5428 
     mk_supplementary_ea_msg ctxt level ty1 ty2 orig
    5434 5429 
       | TypeEqOrigin { uo_expected = exp, uo_actual = act } <- orig
    5435 5430 
       , not (ea_looks_same ty1 ty2 exp act)
    ... ... @@ -5452,7 +5447,7 @@ ea_looks_same ty1 ty2 exp act
    5452 5447 
           -- (TYPE 'LiftedRep) and Type both print the same way.
    5453 5448
    5454 5449 
     mk_ea_msg :: SolverReportErrCtxt -> Maybe ErrorItem -> TypeOrKind
    5455 
    -          -> CtOrigin -> Either [ExpectedActualInfo] MismatchMsg
    5450 
    +          -> CtOrigin -> Either [ExpectedActualInfo] SDoc
    5456 5451 
     -- Constructs a "Couldn't match" message
    5457 5452 
     -- The (Maybe ErrorItem) says whether this is the main top-level message (Just)
    5458 5453 
     --     or a supplementary message (Nothing)
    ... ... @@ -5460,13 +5455,11 @@ mk_ea_msg ctxt at_top level
    5460 5455 
       (TypeEqOrigin { uo_actual = act, uo_expected = exp, uo_thing = mb_thing })
    5461 5456 
       | Just thing <- mb_thing
    5462 5457 
       , KindLevel <- level
    5463 
    -  = Right $ KindMismatch { kmismatch_what     = thing
    5464 
    -                         , kmismatch_expected = exp
    5465 
    -                         , kmismatch_actual   = act }
    5458 
    +  = Right $ pprKindMismatchMsg thing exp act
    5466 5459 
       | Just item <- at_top
    5467 5460 
       , let  ea = EA $ if expanded_syns then Just ea_expanded else Nothing
    5468 5461 
              mismatch = mkBasicMismatchMsg ea item exp act
    5469 
    -  = Right mismatch
    5462 
    +  = Right (pprMismatchMsg ctxt mismatch)
    5470 5463 
       | otherwise
    5471 5464 
       = Left $
    5472 5465 
         if expanded_syns

  • compiler/GHC/Tc/Errors/Types.hs
    ... ... @@ -5690,19 +5690,9 @@ data MismatchMsg
    5690 5690 
           , mismatch_mb_same_occ  :: Maybe SameOccInfo
    5691 5691 
           }
    5692 5692
    5693 
    -  -- | A type has an unexpected kind.
    5694 
    -  --
    5695 
    -  -- Test cases: T2994, T7609, ...
    5696 
    -  | KindMismatch
    5697 
    -      { kmismatch_what     :: TypedThing -- ^ What thing is 'kmismatch_actual' the kind of?
    5698 
    -      , kmismatch_expected :: Type
    5699 
    -      , kmismatch_actual   :: Type
    5700 
    -      }
    5701 
    -    -- TODO: combine with 'BasicMismatch'.
    5702 
    -
    5703 5693 
       -- | A mismatch between two types, which arose from a type equality.
    5704 5694 
       --
    5705 
    -  -- Test cases: T1470, tcfail212.
    5695 
    +  -- Test cases: T1470, tcfail212, T2994, T7609.
    5706 5696 
       | TypeEqMismatch
    5707 5697 
           { teq_mismatch_item     :: ErrorItem
    5708 5698 
           , teq_mismatch_ty1      :: Type

  • compiler/GHC/Types/Error/Codes.hs
    ... ... @@ -420,7 +420,6 @@ type family GhcDiagnosticCode c = n | n -> c where
    420 420 
       GhcDiagnosticCode "MultiplicityCoercionsNotSupported"             = 59840
    421 421 
       -- Type mismatch errors
    422 422 
       GhcDiagnosticCode "BasicMismatch"                                 = 18872
    423 
    -  GhcDiagnosticCode "KindMismatch"                                  = 89223
    424 423 
       GhcDiagnosticCode "TypeEqMismatch"                                = 83865
    425 424 
       GhcDiagnosticCode "CouldNotDeduce"                                = 05617
    426 425

  • testsuite/tests/diagnostic-codes/codes.stdout
    ... ... @@ -46,7 +46,6 @@
    46 46 
     [GHC-06200] is untested (constructor = BlockedEquality)
    47 47 
     [GHC-81325] is untested (constructor = ExpectingMoreArguments)
    48 48 
     [GHC-78125] is untested (constructor = AmbiguityPreventsSolvingCt)
    49 
    -[GHC-89223] is untested (constructor = KindMismatch)
    50 49 
     [GHC-84170] is untested (constructor = TcRnModMissingRealSrcSpan)
    51 50 
     [GHC-95822] is untested (constructor = TcRnSimplifierTooManyIterations)
    52 51 
     [GHC-17268] is untested (constructor = TcRnCharLiteralOutOfRange)

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help