[Git][ghc/ghc][wip/T21623] More wibbles, mainly to error messages
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Mon Aug 22 12:18:17 UTC 2022
Simon Peyton Jones pushed to branch wip/T21623 at Glasgow Haskell Compiler / GHC
Commits:
a3f8b75a by Simon Peyton Jones at 2022-08-22T13:19:30+01:00
More wibbles, mainly to error messages
- - - - -
5 changed files:
- compiler/GHC/Builtin/Types.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Solver/Canonical.hs
Changes:
=====================================
compiler/GHC/Builtin/Types.hs
=====================================
@@ -83,7 +83,7 @@ module GHC.Builtin.Types (
unboxedUnitTy,
unboxedUnitTyCon, unboxedUnitDataCon,
unboxedTupleKind, unboxedSumKind,
- filterCTuple,
+ filterCTuple, mkConstraintTupleTy,
-- ** Constraint tuples
cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,
@@ -2150,6 +2150,17 @@ mkBoxedTupleTy tys = mkTupleTy Boxed tys
unitTy :: Type
unitTy = mkTupleTy Boxed []
+-- Make a constraint tuple
+-- One-tuples vanish
+-- If we get a constraint tuple that is bigger than the pre-built
+-- ones (in ghc-prim:GHC.Tuple), then just make one up anyway; it
+-- this is used only in filling in extra-constraint wildcards
+-- See GHC.Tc.Gen.HsType Note [Extra-constraint holes in partial type signatures]
+mkConstraintTupleTy :: [Type] -> Type
+mkConstraintTupleTy [ty] = ty
+mkConstraintTupleTy tys = mkTyConApp (cTupleTyCon (length tys)) tys
+
+
{- *********************************************************************
* *
The sum types
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -3,7 +3,7 @@
--
-- Type - public interface
-{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -72,7 +72,8 @@ module GHC.Core.Type (
isPredTy,
- getRuntimeRep_maybe, kindRep_maybe, kindRep,
+ getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep,
+ getLevity, levityType_maybe,
mkCastTy, mkCoercionTy, splitCastTy_maybe,
@@ -140,7 +141,6 @@ module GHC.Core.Type (
isLevityTy, isLevityVar,
isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,
dropRuntimeRepArgs,
- getRuntimeRep, getLevity, getLevity_maybe,
-- * Multiplicity
@@ -716,46 +716,6 @@ pickyIsLiftedTypeKind kind
, tc `hasKey` liftedTypeKindTyConKey = True
| otherwise = False
-
--- | See 'isBoxedRuntimeRep_maybe'.
-isBoxedRuntimeRep :: Type -> Bool
-isBoxedRuntimeRep rep = isJust (isBoxedRuntimeRep_maybe rep)
-
--- | `isBoxedRuntimeRep_maybe (rep :: RuntimeRep)` returns `Just lev` if `rep`
--- expands to `Boxed lev` and returns `Nothing` otherwise.
---
--- Types with this runtime rep are represented by pointers on the GC'd heap.
-isBoxedRuntimeRep_maybe :: Type -> Maybe Type
-isBoxedRuntimeRep_maybe rep
- | Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep
- = Just lev
- | otherwise
- = Nothing
-
--- | Check whether a type of kind 'RuntimeRep' is lifted, unlifted, or unknown.
---
--- `isLiftedRuntimeRep rr` returns:
---
--- * `Just Lifted` if `rr` is `LiftedRep :: RuntimeRep`
--- * `Just Unlifted` if `rr` is definitely unlifted, e.g. `IntRep`
--- * `Nothing` if not known (e.g. it's a type variable or a type family application).
-runtimeRepLevity_maybe :: Type -> Maybe Levity
-runtimeRepLevity_maybe rep
- | TyConApp rr_tc args <- coreFullView rep
- , isPromotedDataCon rr_tc =
- -- NB: args might be non-empty e.g. TupleRep [r1, .., rn]
- if (rr_tc `hasKey` boxedRepDataConKey)
- then case args of
- [lev] | isLiftedLevity lev -> Just Lifted
- | isUnliftedLevity lev -> Just Unlifted
- _ -> Nothing
- else Just Unlifted
- -- Avoid searching all the unlifted RuntimeRep type cons
- -- In the RuntimeRep data type, only LiftedRep is lifted
- -- But be careful of type families (F tys) :: RuntimeRep,
- -- hence the isPromotedDataCon rr_tc
-runtimeRepLevity_maybe _ = Nothing
-
-- | Check whether a kind is of the form `TYPE (BoxedRep Lifted)`
-- or `TYPE (BoxedRep Unlifted)`.
--
@@ -835,6 +795,82 @@ isMultiplicityTy = isNullaryTyConKeyApp multiplicityTyConKey
isMultiplicityVar :: TyVar -> Bool
isMultiplicityVar = isMultiplicityTy . tyVarKind
+--------------------------------------------
+-- Splitting RuntimeRep
+--------------------------------------------
+
+-- | (splitRuntimeRep_maybe rr) takes a Type rr :: RuntimeRep, and
+-- returns the (TyCon,[Type]) for the RuntimeRep, if possible, where
+-- the TyCon is one of the promoted DataCons of RuntimeRep.
+-- Remember: the unique on TyCon that is a a promoted DataCon is the
+-- same as the unique on the DataCon
+-- See Note [Promoted data constructors] in GHC.Core.TyCon
+-- May not be possible if `rr` is a type variable or type
+-- family application
+splitRuntimeRep_maybe :: Type -> Maybe (TyCon, [Type])
+splitRuntimeRep_maybe rep
+ | TyConApp rr_tc args <- coreFullView rep
+ , isPromotedDataCon rr_tc
+ = Just (rr_tc, args)
+ | otherwise
+ = Nothing
+
+-- | See 'isBoxedRuntimeRep_maybe'.
+isBoxedRuntimeRep :: Type -> Bool
+isBoxedRuntimeRep rep = isJust (isBoxedRuntimeRep_maybe rep)
+
+-- | `isBoxedRuntimeRep_maybe (rep :: RuntimeRep)` returns `Just lev` if `rep`
+-- expands to `Boxed lev` and returns `Nothing` otherwise.
+--
+-- Types with this runtime rep are represented by pointers on the GC'd heap.
+isBoxedRuntimeRep_maybe :: Type -> Maybe Type
+isBoxedRuntimeRep_maybe rep
+ | Just (rr_tc, args) <- splitRuntimeRep_maybe rep
+ , rr_tc `hasKey` boxedRepDataConKey
+ , [lev] <- args
+ = Just lev
+ | otherwise
+ = Nothing
+
+-- | Check whether a type of kind 'RuntimeRep' is lifted, unlifted, or unknown.
+--
+-- `isLiftedRuntimeRep rr` returns:
+--
+-- * `Just Lifted` if `rr` is `LiftedRep :: RuntimeRep`
+-- * `Just Unlifted` if `rr` is definitely unlifted, e.g. `IntRep`
+-- * `Nothing` if not known (e.g. it's a type variable or a type family application).
+runtimeRepLevity_maybe :: Type -> Maybe Levity
+runtimeRepLevity_maybe rep
+ | Just (rr_tc, args) <- splitRuntimeRep_maybe rep
+ = -- NB: args might be non-empty e.g. TupleRep [r1, .., rn]
+ if (rr_tc `hasKey` boxedRepDataConKey)
+ then case args of
+ [lev] -> levityType_maybe lev
+ _ -> pprPanic "runtimeRepLevity_maybe" (ppr rep)
+ else Just Unlifted
+ -- Avoid searching all the unlifted RuntimeRep type cons
+ -- In the RuntimeRep data type, only LiftedRep is lifted
+ -- But be careful of type families (F tys) :: RuntimeRep,
+ -- hence the isPromotedDataCon rr_tc
+ | otherwise
+ = Nothing
+
+--------------------------------------------
+-- Splitting Levity
+--------------------------------------------
+
+-- | `levity_maybe` takes a Type of kind Levity, and returns its levity
+-- May not be possible for a type variable or type family application
+levityType_maybe :: Type -> Maybe Levity
+levityType_maybe lev
+ | TyConApp lev_tc args <- coreFullView lev
+ = if | lev_tc `hasKey` liftedDataConKey -> assert( null args) $ Just Lifted
+ | lev_tc `hasKey` unliftedDataConKey -> assert( null args) $ Just Unlifted
+ | otherwise -> Nothing
+ | otherwise
+ = Nothing
+
+
{- *********************************************************************
* *
mapType
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -2089,10 +2089,10 @@ pprTcSolverReportMsg _
pprTcSolverReportMsg ctxt
(TypeEqMismatch { teq_mismatch_ppr_explicit_kinds = ppr_explicit_kinds
, teq_mismatch_item = item
- , teq_mismatch_ty1 = ty1
- , teq_mismatch_ty2 = ty2
- , teq_mismatch_expected = exp
- , teq_mismatch_actual = act
+ , teq_mismatch_ty1 = ty1 -- These types are the context
+ , teq_mismatch_ty2 = ty2 -- of the mis-match
+ , teq_mismatch_expected = exp -- These are the kinds that
+ , teq_mismatch_actual = act -- don't match
, teq_mismatch_what = mb_thing })
= addArising ct_loc $ pprWithExplicitKindsWhen ppr_explicit_kinds msg
where
@@ -2123,18 +2123,16 @@ pprTcSolverReportMsg ctxt
| Just (act_torc, act_rep) <- sORTKind_maybe act
, act_torc == exp_torc
= -- (TYPE exp_rep) ~ (TYPE act_rep) or similar with CONSTRAINT
- case (runtimeRepLevity_maybe exp_rep, runtimeRepLevity_maybe act_rep) of
- (Just exp_lev, Just act_lev)
- -> sep [ text "Expecting" <+> ppr_an_lev exp_lev <+> pp_exp_thing <+> text "but"
- , case mb_thing of
- Just thing -> quotes (ppr thing) <+> text "is" <+> ppr_lev act_lev
- Nothing -> text "got" <+> ppr_an_lev act_lev <+> pp_exp_thing ]
- _ -> bale_out_msg
+ case (splitRuntimeRep_maybe exp_rep, splitRuntimeRep_maybe act_rep) of
+ (Just (exp_rr_tc, exp_rr_args), Just (act_rr_tc, act_rr_args))
+ | exp_rr_tc == act_rr_tc -> msg_for_same_rep exp_rr_args act_rr_args
+ | otherwise -> msg_for_different_rep exp_rr_tc act_rr_tc
+ _ -> bale_out_msg
| otherwise
= -- (TYPE _) ~ (CONSTRAINT _) or (TYPE _) ~ Bool, etc
maybe_num_args_msg $$
- sep [ text "Expected a" <+> pp_exp_thing <+> text "but"
+ sep [ text "Expected a" <+> pp_exp_thing <> text ", but"
, case mb_thing of
Nothing -> text "found something with kind"
Just thing -> quotes (ppr thing) <+> text "has kind"
@@ -2143,11 +2141,31 @@ pprTcSolverReportMsg ctxt
where
pp_exp_thing = case exp_torc of TypeLike -> text "type";
ConstraintLike -> text "constraint"
- ppr_lev Lifted = text "lifted"
- ppr_lev Unlifted = text "unlifted"
- ppr_an_lev Lifted = text "a lifted"
- ppr_an_lev Unlifted = text "an unlifted"
+ -- (TYPE (BoxedRep lev1)) ~ (TYPE (BoxedRep lev2))
+ msg_for_same_rep exp_rr_args act_rr_args
+ | [exp_lev_ty] <- exp_rr_args -- BoxedRep has exactly one arg
+ , [act_lev_ty] <- act_rr_args
+ , Just exp_lev <- levityType_maybe exp_lev_ty
+ , Just act_lev <- levityType_maybe act_lev_ty
+ = sep [ text "Expecting" <+> ppr_an_lev exp_lev <+> pp_exp_thing <+> text "but"
+ , case mb_thing of
+ Just thing -> quotes (ppr thing) <+> text "is" <+> ppr_lev act_lev
+ Nothing -> text "got" <+> ppr_an_lev act_lev <+> pp_exp_thing ]
+ msg_for_same_rep _ _
+ = bale_out_msg
+
+ msg_for_different_rep exp_rr_tc act_rr_tc
+ = sep [ text "Expecting a" <+> what <+> text "but"
+ , case mb_thing of
+ Just thing -> quotes (ppr thing)
+ Nothing -> quotes (pprWithTYPE act)
+ <+> text "has representation" <+> ppr_rep act_rr_tc ]
+ where
+ what | exp_rr_tc `hasKey` boxedRepDataConKey
+ = text "boxed" <+> pp_exp_thing
+ | otherwise
+ = pp_exp_thing <+> text "with representation" <+> ppr_rep exp_rr_tc
ct_loc = errorItemCtLoc item
orig = errorItemOrigin item
@@ -2173,6 +2191,14 @@ pprTcSolverReportMsg ctxt
maybe_num_args_msg = num_args_msg `orElse` empty
count_args ty = count isVisibleBinder $ fst $ splitPiTys ty
+
+ ppr_lev Lifted = text "lifted"
+ ppr_lev Unlifted = text "unlifted"
+ ppr_an_lev Lifted = text "a lifted"
+ ppr_an_lev Unlifted = text "an unlifted"
+
+ ppr_rep rep_tc = quotes (ppr (getOccName rep_tc)) -- Don't qualify
+
pprTcSolverReportMsg _ (FixedRuntimeRepError frr_origs) =
vcat (map make_msg frr_origs)
where
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -53,7 +53,7 @@ import GHC.Tc.Instance.Family( tcGetFamInstEnvs )
import GHC.Core.Class ( Class )
import GHC.Tc.Utils.TcType
import GHC.Core.Type (mkStrLitTy, tidyOpenType, mkCastTy)
-import GHC.Builtin.Types ( mkBoxedTupleTy )
+import GHC.Builtin.Types ( mkConstraintTupleTy )
import GHC.Builtin.Types.Prim
import GHC.Types.SourceText
import GHC.Types.Id
@@ -1005,7 +1005,7 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
-- We know that wc_co must have type kind(wc_var) ~ Constraint, as it
-- comes from the checkExpectedKind in GHC.Tc.Gen.HsType.tcAnonWildCardOcc.
-- So, to make the kinds work out, we reverse the cast here.
- Just (wc_var, wc_co) -> writeMetaTyVar wc_var (mk_ctuple diff_theta
+ Just (wc_var, wc_co) -> writeMetaTyVar wc_var (mkConstraintTupleTy diff_theta
`mkCastTy` mkTcSymCo wc_co)
Nothing -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)
@@ -1019,10 +1019,6 @@ chooseInferredQuantifiers residual inferred_theta tau_tvs qtvs
-- Return (annotated_theta ++ diff_theta)
-- See Note [Extra-constraints wildcards]
- mk_ctuple preds = mkBoxedTupleTy preds
- -- Hack alert! See GHC.Tc.Gen.HsType:
- -- Note [Extra-constraint holes in partial type signatures]
-
chooseInferredQuantifiers _ _ _ _ (Just (TISI { sig_inst_sig = sig@(CompleteSig {}) }))
= pprPanic "chooseInferredQuantifiers" (ppr sig)
=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -943,7 +943,7 @@ unknown kind. For instance, we may have,
FunTy (a :: k) Int
-Where k is a unification variable. So the calls to getRuntimeRep_maybe may
+Where k is a unification variable. So the calls to splitRuntimeRep_maybe may
fail (returning Nothing). In that case we'll fall through, zonk, and try again.
Zonking should fill the variable k, meaning that decomposition will succeed the
second time around.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3f8b75abb53c99032e3f4f79ce92a9d2bc0a647
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a3f8b75abb53c99032e3f4f79ce92a9d2bc0a647
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220822/77e8b07d/attachment-0001.html>
More information about the ghc-commits
mailing list