Commit effdd948 authored by Andrew Martin's avatar Andrew Martin Committed by Marge Bot

Implement the -XUnliftedNewtypes extension.

GHC Proposal: 0013-unlifted-newtypes.rst
Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98
Issues: #15219, #1311, #13595, #15883
Implementation Details:
  Note [Implementation of UnliftedNewtypes]
  Note [Unifying data family kinds]
  Note [Compulsory newtype unfolding]

This patch introduces the -XUnliftedNewtypes extension. When this
extension is enabled, GHC drops the restriction that the field in
a newtype must be of kind (TYPE 'LiftedRep). This allows types
like Int# and ByteArray# to be used in a newtype. Additionally,
coerce is made levity-polymorphic so that it can be used with
newtypes over unlifted types.

The bulk of the changes are in TcTyClsDecls.hs. With -XUnliftedNewtypes,
getInitialKind is more liberal, introducing a unification variable to
return the kind (TYPE r0) rather than just returning (TYPE 'LiftedRep).
When kind-checking a data constructor with kcConDecl, we attempt to
unify the kind of a newtype with the kind of its field's type. When
typechecking a data declaration with tcTyClDecl, we again perform a
unification. See the implementation note for more on this.
Co-authored-by: Richard Eisenberg's avatarRichard Eisenberg <rae@richarde.dev>
parent 3bc6df32
Pipeline #7136 failed with stages
in 126 minutes and 3 seconds
......@@ -567,7 +567,7 @@ lambdas if it is not applied to enough arguments; e.g. (#14561)
The desugar has special magic to detect such cases: DsExpr.badUseOfLevPolyPrimop.
And we want that magic to apply to levity-polymorphic compulsory-inline things.
The easiest way to do this is for hasNoBinding to return True of all things
that have compulsory unfolding. A very Ids with a compulsory unfolding also
that have compulsory unfolding. Some Ids with a compulsory unfolding also
have a binding, but it does not harm to say they don't here, and its a very
simple way to fix #14561.
......
......@@ -29,6 +29,7 @@ module MkId (
nullAddrId, seqId, lazyId, lazyIdKey,
coercionTokenId, magicDictId, coerceId,
proxyHashId, noinlineId, noinlineIdName,
coerceName,
-- Re-export error Ids
module PrelRules
......@@ -71,6 +72,7 @@ import DynFlags
import Outputable
import FastString
import ListSetOps
import Var (VarBndr(Bndr))
import qualified GHC.LanguageExtensions as LangExt
import Data.Maybe ( maybeToList )
......@@ -338,6 +340,32 @@ effect whether a wrapper is present or not:
We'd like 'map Age' to match the LHS. For this to happen, Age
must be unfolded, otherwise we'll be stuck. This is tested in T16208.
It also allows for the posssibility of levity polymorphic newtypes
with wrappers (with -XUnliftedNewtypes):
newtype N (a :: TYPE r) = MkN a
With -XUnliftedNewtypes, this is allowed -- even though MkN is levity-
polymorphic. It's OK because MkN evaporates in the compiled code, becoming
just a cast. That is, it has a compulsory unfolding. As long as its
argument is not levity-polymorphic (which it can't be, according to
Note [Levity polymorphism invariants] in CoreSyn), and it's saturated,
no levity-polymorphic code ends up in the code generator. The saturation
condition is effectively checked by Note [Detecting forced eta expansion]
in DsExpr.
However, if we make a *wrapper* for a newtype, we get into trouble.
The saturation condition is no longer checked (because hasNoBinding
returns False) and indeed we generate a forbidden levity-polymorphic
binding.
The solution is simple, though: just make the newtype wrappers
as ephemeral as the newtype workers. In other words, give the wrappers
compulsory unfoldings and no bindings. The compulsory unfolding is given
in wrap_unf in mkDataConRep, and the lack of a binding happens in
TidyPgm.getTyConImplicitBinds, where we say that a newtype has no implicit
bindings.
************************************************************************
* *
\subsection{Dictionary selectors}
......@@ -595,6 +623,7 @@ But if we inline the wrapper, we get
map (\a. case i of I# i# a -> Foo i# a) (f a)
and now case-of-known-constructor eliminates the redundant allocation.
-}
mkDataConRep :: DynFlags
......@@ -624,7 +653,7 @@ mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
-- We need to get the CAF info right here because TidyPgm
-- does not tidy the IdInfo of implicit bindings (like the wrapper)
-- so it not make sure that the CAF info is sane
`setNeverLevPoly` wrap_ty
`setLevityInfoWithType` wrap_ty
wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
......@@ -1423,19 +1452,23 @@ coerceId = pcMiscPrelId coerceName ty info
where
info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` mkCompulsoryUnfolding rhs
`setNeverLevPoly` ty
eqRTy = mkTyConApp coercibleTyCon [ liftedTypeKind
, alphaTy, betaTy ]
eqRPrimTy = mkTyConApp eqReprPrimTyCon [ liftedTypeKind
, liftedTypeKind
, alphaTy, betaTy ]
ty = mkSpecForAllTys [alphaTyVar, betaTyVar] $
mkInvisFunTy eqRTy $
mkVisFunTy alphaTy betaTy
[eqR,x,eq] = mkTemplateLocals [eqRTy, alphaTy, eqRPrimTy]
rhs = mkLams [alphaTyVar, betaTyVar, eqR, x] $
mkWildCase (Var eqR) eqRTy betaTy $
eqRTy = mkTyConApp coercibleTyCon [ tYPE r , a, b ]
eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ]
ty = mkForAllTys [ Bndr rv Inferred
, Bndr av Specified
, Bndr bv Specified
] $
mkInvisFunTy eqRTy $
mkVisFunTy a b
bndrs@[rv,av,bv] = mkTemplateKiTyVar runtimeRepTy
(\r -> [tYPE r, tYPE r])
[r, a, b] = mkTyVarTys bndrs
[eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy]
rhs = mkLams (bndrs ++ [eqR, x]) $
mkWildCase (Var eqR) eqRTy b $
[(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))]
{-
......
......@@ -619,6 +619,9 @@ typeToStgFArgType typ
| tycon == mutableByteArrayPrimTyCon = StgByteArrayType
| otherwise = StgPlainType
where
-- should be a tycon app, since this is a foreign call
-- Should be a tycon app, since this is a foreign call. We look
-- through newtypes so the offset does not change if a user replaces
-- a type in a foreign function signature with a representationally
-- equivalent newtype.
tycon = tyConAppTyCon (unwrapType typ)
......@@ -1091,7 +1091,7 @@ Note [Detecting forced eta expansion]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We cannot have levity polymorphic function arguments. See
Note [Levity polymorphism invariants] in CoreSyn. But we *can* have
functions that take levity polymorphism arguments, as long as these
functions that take levity polymorphic arguments, as long as these
functions are eta-reduced. (See #12708 for an example.)
However, we absolutely cannot do this for functions that have no
......@@ -1162,7 +1162,11 @@ badUseOfLevPolyPrimop id ty
levPolyPrimopErr :: Id -> Type -> [Type] -> DsM ()
levPolyPrimopErr primop ty bad_tys
= errDs $ vcat [ hang (text "Cannot use primitive with levity-polymorphic arguments:")
2 (ppr primop <+> dcolon <+> pprWithTYPE ty)
, hang (text "Levity-polymorphic arguments:")
2 (vcat (map (\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t)) bad_tys)) ]
= errDs $ vcat
[ hang (text "Cannot use function with levity-polymorphic arguments:")
2 (ppr primop <+> dcolon <+> pprWithTYPE ty)
, hang (text "Levity-polymorphic arguments:")
2 $ vcat $ map
(\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t))
bad_tys
]
......@@ -62,6 +62,7 @@ module HsTypes (
mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,
ignoreParens, hsSigType, hsSigWcType,
hsLTyVarBndrToType, hsLTyVarBndrsToTypes,
hsConDetailsArgs,
-- Printing
pprHsType, pprHsForAll, pprHsForAllExtra, pprHsExplicitForAll,
......@@ -912,6 +913,14 @@ instance (Outputable arg, Outputable rec)
ppr (RecCon rec) = text "RecCon:" <+> ppr rec
ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]
hsConDetailsArgs ::
HsConDetails (LHsType a) (Located [LConDeclField a])
-> [LHsType a]
hsConDetailsArgs details = case details of
InfixCon a b -> [a,b]
PrefixCon xs -> xs
RecCon r -> map (cd_fld_type . unLoc) (unLoc r)
{-
Note [ConDeclField passs]
~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -4527,6 +4527,7 @@ xFlagsDeps = [
flagSpec "UndecidableSuperClasses" LangExt.UndecidableSuperClasses,
flagSpec "UnicodeSyntax" LangExt.UnicodeSyntax,
flagSpec "UnliftedFFITypes" LangExt.UnliftedFFITypes,
flagSpec "UnliftedNewtypes" LangExt.UnliftedNewtypes,
flagSpec "ViewPatterns" LangExt.ViewPatterns
]
......
......@@ -566,7 +566,9 @@ See Note [Data constructor workers] in CorePrep.
-}
getTyConImplicitBinds :: TyCon -> [CoreBind]
getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))
getTyConImplicitBinds tc
| isNewTyCon tc = [] -- See Note [Compulsory newtype unfolding] in MkId
| otherwise = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))
getClassImplicitBinds :: Class -> [CoreBind]
getClassImplicitBinds cls
......
......@@ -13,7 +13,7 @@ module TysPrim(
mkPrimTyConName, -- For implicit parameters in TysWiredIn only
mkTemplateKindVars, mkTemplateTyVars, mkTemplateTyVarsFrom,
mkTemplateKiTyVars,
mkTemplateKiTyVars, mkTemplateKiTyVar,
mkTemplateTyConBinders, mkTemplateKindTyConBinders,
mkTemplateAnonTyConBinders,
......@@ -251,14 +251,15 @@ alphaTyVars is a list of type variables for use in templates:
["a", "b", ..., "z", "t1", "t2", ... ]
-}
mkTemplateKindVar :: Kind -> TyVar
mkTemplateKindVar = mkTyVar (mk_tv_name 0 "k")
mkTemplateKindVars :: [Kind] -> [TyVar]
-- k0 with unique (mkAlphaTyVarUnique 0)
-- k1 with unique (mkAlphaTyVarUnique 1)
-- ... etc
mkTemplateKindVars [kind]
= [mkTyVar (mk_tv_name 0 "k") kind]
-- Special case for one kind: just "k"
mkTemplateKindVars [kind] = [mkTemplateKindVar kind]
-- Special case for one kind: just "k"
mkTemplateKindVars kinds
= [ mkTyVar (mk_tv_name u ('k' : show u)) kind
| (kind, u) <- kinds `zip` [0..] ]
......@@ -307,7 +308,7 @@ mkTemplateKiTyVars
-> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm]
-- Example: if you want the tyvars for
-- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah
-- call mkTemplateKiTyVars [RuntimeRep] (\[r]. [TYPE r, *)
-- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, *])
mkTemplateKiTyVars kind_var_kinds mk_arg_kinds
= kv_bndrs ++ tv_bndrs
where
......@@ -315,6 +316,21 @@ mkTemplateKiTyVars kind_var_kinds mk_arg_kinds
anon_kinds = mk_arg_kinds (mkTyVarTys kv_bndrs)
tv_bndrs = mkTemplateTyVarsFrom (length kv_bndrs) anon_kinds
mkTemplateKiTyVar
:: Kind -- [k1, .., kn] Kind of kind-forall'd var
-> (Kind -> [Kind]) -- Arg is kv1:k1
-- Result is anon arg kinds [ak1, .., akm]
-> [TyVar] -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm]
-- Example: if you want the tyvars for
-- forall (r:RuntimeRep) (a:TYPE r) (b:*). blah
-- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, *])
mkTemplateKiTyVar kind mk_arg_kinds
= kv_bndr : tv_bndrs
where
kv_bndr = mkTemplateKindVar kind
anon_kinds = mk_arg_kinds (mkTyVarTy kv_bndr)
tv_bndrs = mkTemplateTyVarsFrom 1 anon_kinds
mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder]
-- Makes named, Specified binders
mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds]
......
......@@ -3439,6 +3439,11 @@ pseudoop "coerce"
the newtype's concrete type to the abstract type. But it also works in
more complicated settings, e.g. converting a list of newtypes to a list of
concrete types.
This function is runtime-representation polymorphic, but the
{\tt RuntimeRep} type argument is marked as {\tt Inferred}, meaning
that it is not available for visible type application. This means
the typechecker will accept {\tt coerce @Int @Age 42}.
}
------------------------------------------------------------------------
......
......@@ -69,7 +69,7 @@ import Control.Arrow ( first )
import Data.List ( mapAccumL )
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty ( NonEmpty(..) )
import Data.Maybe ( isNothing, fromMaybe )
import Data.Maybe ( isNothing, isJust, fromMaybe )
import qualified Data.Set as Set ( difference, fromList, toList, null )
{- | @rnSourceDecl@ "renames" declarations.
......@@ -1539,18 +1539,22 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
-- "data", "newtype" declarations
-- both top level and (for an associated type) in an instance decl
rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
tcdFixity = fixity, tcdDataDefn = defn })
rnTyClDecl (DataDecl _ _ _ _ (XHsDataDefn _)) =
panic "rnTyClDecl: DataDecl with XHsDataDefn"
rnTyClDecl (DataDecl
{ tcdLName = tycon, tcdTyVars = tyvars,
tcdFixity = fixity,
tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data
, dd_kindSig = kind_sig} })
= do { tycon' <- lookupLocatedTopBndrRn tycon
; let kvs = extractDataDefnKindVars defn
doc = TyDataCtx tycon
; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
do { (defn', fvs) <- rnDataDefn doc defn
-- See Note [Complete user-supplied kind signatures] in HsDecls
; cusks_enabled <- xoptM LangExt.CUSKs
; let cusk = cusks_enabled && hsTvbAllKinded tyvars' && no_rhs_kvs
rn_info = DataDeclRn { tcdDataCusk = cusk
; cusk <- dataDeclHasCUSK
tyvars' new_or_data no_rhs_kvs (isJust kind_sig)
; let rn_info = DataDeclRn { tcdDataCusk = cusk
, tcdFVs = fvs }
; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
; return (DataDecl { tcdLName = tycon'
......@@ -1626,6 +1630,42 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl"
-- Does the data type declaration include a CUSK?
dataDeclHasCUSK :: LHsQTyVars pass -> NewOrData -> Bool -> Bool -> RnM Bool
dataDeclHasCUSK tyvars new_or_data no_rhs_kvs has_kind_sig = do
{ -- See Note [Unlifted Newtypes and CUSKs], and for a broader
-- picture, see Note [Implementation of UnliftedNewtypes].
; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes
; let non_cusk_newtype
| NewType <- new_or_data =
unlifted_newtypes && not has_kind_sig
| otherwise = False
-- See Note [CUSKs: complete user-supplied kind signatures] in HsDecls
; cusks_enabled <- xoptM LangExt.CUSKs
; return $ cusks_enabled && hsTvbAllKinded tyvars &&
no_rhs_kvs && not non_cusk_newtype
}
{- Note [Unlifted Newtypes and CUSKs]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When unlifted newtypes are enabled, a newtype must have a kind signature
in order to be considered have a CUSK. This is because the flow of
kind inference works differently. Consider:
newtype Foo = FooC Int
When UnliftedNewtypes is disabled, we decide that Foo has kind
`TYPE 'LiftedRep` without looking inside the data constructor. So, we
can say that Foo has a CUSK. However, when UnliftedNewtypes is enabled,
we fill in the kind of Foo as a metavar that gets solved by unification
with the kind of the field inside FooC (that is, Int, whose kind is
`TYPE 'LiftedRep`). But since we have to look inside the data constructors
to figure out the kind signature of Foo, it does not have a CUSK.
See Note [Implementation of UnliftedNewtypes] for where this fits in to
the broader picture of UnliftedNewtypes.
-}
-- "type" and "type instance" declarations
rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnTySyn doc rhs = rnLHsType doc rhs
......
......@@ -2015,11 +2015,11 @@ mkExpectedActualMsg ty1 ty2 ct@(TypeEqOrigin { uo_actual = act
level = m_level `orElse` TypeLevel
occurs_check_error
| Just act_tv <- tcGetTyVar_maybe act
, act_tv `elemVarSet` tyCoVarsOfType exp
| Just tv <- tcGetTyVar_maybe ty1
, tv `elemVarSet` tyCoVarsOfType ty2
= True
| Just exp_tv <- tcGetTyVar_maybe exp
, exp_tv `elemVarSet` tyCoVarsOfType act
| Just tv <- tcGetTyVar_maybe ty2
, tv `elemVarSet` tyCoVarsOfType ty1
= True
| otherwise
= False
......@@ -2043,13 +2043,17 @@ mkExpectedActualMsg ty1 ty2 ct@(TypeEqOrigin { uo_actual = act
-> empty
thing_msg = case maybe_thing of
Just thing -> \_ -> quotes thing <+> text "is"
Nothing -> \vowel -> text "got a" <>
if vowel then char 'n' else empty
Just thing -> \_ levity ->
quotes thing <+> text "is" <+> levity
Nothing -> \vowel levity ->
text "got a" <>
(if vowel then char 'n' else empty) <+>
levity <+>
text "type"
msg2 = sep [ text "Expecting a lifted type, but"
, thing_msg True, text "unlifted" ]
, thing_msg True (text "unlifted") ]
msg3 = sep [ text "Expecting an unlifted type, but"
, thing_msg False, text "lifted" ]
, thing_msg False (text "lifted") ]
msg4 = maybe_num_args_msg $$
sep [ text "Expected a type, but"
, maybe (text "found something with kind")
......
......@@ -30,6 +30,7 @@ module TcEvidence (
-- TcCoercion
TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole,
TcMCoercion,
Role(..), LeftOrRight(..), pickLR,
mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo,
mkTcTyConAppCo, mkTcAppCo, mkTcFunCo,
......@@ -42,7 +43,7 @@ module TcEvidence (
mkTcKindCo,
tcCoercionKind, coVarsOfTcCo,
mkTcCoVarCo,
isTcReflCo, isTcReflexiveCo,
isTcReflCo, isTcReflexiveCo, isTcGReflMCo, tcCoToMCo,
tcCoercionRole,
unwrapIP, wrapIP
) where
......@@ -98,6 +99,7 @@ type TcCoercion = Coercion
type TcCoercionN = CoercionN -- A Nominal coercion ~N
type TcCoercionR = CoercionR -- A Representational coercion ~R
type TcCoercionP = CoercionP -- a phantom coercion
type TcMCoercion = MCoercion
mkTcReflCo :: Role -> TcType -> TcCoercion
mkTcSymCo :: TcCoercion -> TcCoercion
......@@ -133,6 +135,7 @@ tcCoercionKind :: TcCoercion -> Pair TcType
tcCoercionRole :: TcCoercion -> Role
coVarsOfTcCo :: TcCoercion -> TcTyCoVarSet
isTcReflCo :: TcCoercion -> Bool
isTcGReflMCo :: TcMCoercion -> Bool
-- | This version does a slow check, calculating the related types and seeing
-- if they are equal.
......@@ -168,8 +171,12 @@ tcCoercionKind = coercionKind
tcCoercionRole = coercionRole
coVarsOfTcCo = coVarsOfCo
isTcReflCo = isReflCo
isTcGReflMCo = isGReflMCo
isTcReflexiveCo = isReflexiveCo
tcCoToMCo :: TcCoercion -> TcMCoercion
tcCoToMCo = coToMCo
{-
%************************************************************************
%* *
......
......@@ -2122,8 +2122,6 @@ bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv
bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar)
bindExplicitTKBndrs_Q_Tv ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar)
-- | Used during the "kind-checking" pass in TcTyClsDecls only,
-- and even then only for data-con declarations.
bindExplicitTKBndrsX
:: (HsTyVarBndr GhcRn -> TcM TcTyVar)
-> [LHsTyVarBndr GhcRn]
......
This diff is collapsed.
......@@ -80,6 +80,7 @@ module TcMType (
zonkCt, zonkSkolemInfo,
tcGetGlobalTyCoVars,
skolemiseUnboundMetaTyVar,
------------------------------
-- Levity polymorphism
......
......@@ -30,9 +30,7 @@ import GhcPrelude
import Bag
import Class ( Class, classKey, classTyCon )
import DynFlags ( WarningFlag ( Opt_WarnMonomorphism )
, WarnReason ( Reason )
, DynFlags( solverIterations ) )
import DynFlags
import HsExpr ( UnboundVar(..) )
import Id ( idType, mkLocalId )
import Inst
......@@ -229,12 +227,16 @@ simpl_top :: WantedConstraints -> TcS WantedConstraints
simpl_top wanteds
= do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds)
-- This is where the main work happens
; try_tyvar_defaulting wc_first_go }
; dflags <- getDynFlags
; try_tyvar_defaulting dflags wc_first_go }
where
try_tyvar_defaulting :: WantedConstraints -> TcS WantedConstraints
try_tyvar_defaulting wc
try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints
try_tyvar_defaulting dflags wc
| isEmptyWC wc
= return wc
| insolubleWC wc
, gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles]
= try_class_defaulting wc
| otherwise
= do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)
; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs
......@@ -252,7 +254,7 @@ simpl_top wanteds
try_class_defaulting :: WantedConstraints -> TcS WantedConstraints
try_class_defaulting wc
| isEmptyWC wc
| isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles]
= return wc
| otherwise -- See Note [When to do type-class defaulting]
= do { something_happened <- applyDefaultingRules wc
......@@ -518,6 +520,50 @@ solveWantedsAndDrop, not simpl_top, so that we do no defaulting.
This is ambiguous of course, but we don't want to default the
(Num alpha) constraint to (Num Int)! Doing so gives a defaulting
warning, but no error.
Note [Defaulting insolubles]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If a set of wanteds is insoluble, we have no hope of accepting the
program. Yet we do not stop constraint solving, etc., because we may
simplify the wanteds to produce better error messages. So, once
we have an insoluble constraint, everything we do is just about producing
helpful error messages.
Should we default in this case or not? Let's look at an example (tcfail004):
(f,g) = (1,2,3)
With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer).
Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard)
find the latter more helpful. Several other test cases (e.g. tcfail005) suggest
similarly. So: we should not do class defaulting with insolubles.
On the other hand, RuntimeRep-defaulting is different. Witness tcfail078:
f :: Integer i => i
f = 0
Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind
TYPE r0 -> Constraint and then complains that r0 is actually untouchable
(presumably, because it can't be sure if `Integer i` entails an equality).
If we default, we are told of a clash between (* -> Constraint) and Constraint.
The latter seems far better, suggesting we *should* do RuntimeRep-defaulting
even on insolubles.
But, evidently, not always. Witness UnliftedNewtypesInfinite:
newtype Foo = FooC (# Int#, Foo #)
This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes).
If we default RuntimeRep-vars, we get
Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted
which is just plain wrong.
Conclusion: we should do RuntimeRep-defaulting on insolubles only when the user does not
want to hear about RuntimeRep stuff -- that is, when -fprint-explicit-runtime-reps
is not set.
-}
------------------
......
This diff is collapsed.
......@@ -17,7 +17,7 @@ import GhcPrelude
import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )
import TcBinds( addTypecheckedBinds )
import IfaceEnv( newGlobalBinder )
import TyCoRep( Type(..), TyLit(..) )
import TyCoRep( Type(..), TyLit(..), isLiftedTypeKind )
import TcEnv
import TcEvidence ( mkWpTyApps )
import TcRnMonad
......@@ -426,12 +426,14 @@ tyConIsTypeable tc =
-- polytypes and types containing casts (which may be, for instance, a type
-- family).
typeIsTypeable :: Type -> Bool
-- We handle types of the form (TYPE rep) specifically to avoid
-- looping on (tyConIsTypeable RuntimeRep)
-- We handle types of the form (TYPE LiftedRep) specifically to avoid
-- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr)
-- to be typeable without inspecting rr, but this exhibits bad behavior
-- when rr is a type family.
typeIsTypeable ty
| Just ty' <- coreView ty = typeIsTypeable ty'
typeIsTypeable ty
| isJust (kindRep_maybe ty) = True
| isLiftedTypeKind ty = True
typeIsTypeable (TyVarTy _) = True
typeIsTypeable (AppTy a b) = typeIsTypeable a && typeIsTypeable b
typeIsTypeable (FunTy _ a b) = typeIsTypeable a && typeIsTypeable b
......
......@@ -62,7 +62,7 @@ module Coercion (
pickLR,
isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,
isReflCoVar_maybe,
isReflCoVar_maybe, isGReflMCo, coToMCo,
-- ** Coercion variables
mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,
......@@ -592,6 +592,11 @@ isReflexiveCo_maybe co
= Nothing
where (Pair ty1 ty2, r) = coercionKindRole co
coToMCo :: Coercion -> MCoercion
coToMCo c = if isReflCo c
then MRefl
else MCo c
{-
%************************************************************************
%* *
......
......@@ -59,6 +59,7 @@ module Type (
getRuntimeRep_maybe, kindRep_maybe, kindRep,
mkCastTy, mkCoercionTy, splitCastTy_maybe,
discardCast,
userTypeError_maybe, pprUserTypeErrorTy,
......@@ -137,6 +138,7 @@ module Type (
-- ** Finding the kind of a type
typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly,
tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind,
tcIsRuntimeTypeKind,
-- ** Common Kind
liftedTypeKind,
......@@ -1277,6 +1279,21 @@ tyConBindersTyCoBinders = map to_tyb
to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis)
to_tyb (Bndr tv (AnonTCB af)) = Anon af (varType tv)
-- | Drop the cast on a type, if any. If there is no
-- cast, just return the original type. This is rarely what
-- you want. The CastTy data constructor (in TyCoRep) has the
-- invariant that another CastTy is not inside. See the
-- data constructor for a full description of this invariant.
-- Since CastTy cannot be nested, the result of discardCast
-- cannot be a CastTy.
discardCast :: Type -> Type
discardCast (CastTy ty _) = ASSERT(not (isCastTy ty)) ty
where
isCastTy CastTy{} = True
isCastTy _ = False
discardCast ty = ty
{-
--------------------------------------------------------------------
CoercionTy
......@@ -1827,6 +1844,17 @@ tcIsLiftedTypeKind ty
| otherwise
= False
-- | Is this kind equivalent to @TYPE r@ (for some unknown r)?
--
-- This considers 'Constraint' to be distinct from @*@.
tcIsRuntimeTypeKind :: Kind -> Bool
tcIsRuntimeTypeKind ty
| Just (tc, _) <- tcSplitTyConApp_maybe ty -- Note: tcSplit here
, tc `hasKey` tYPETyConKey
= True
| otherwise
= False
tcReturnsConstraintKind :: Kind -> Bool
-- True <=> the Kind ultimately returns a Constraint
-- E.g. * -> Constraint
......
......@@ -10,6 +10,8 @@ following sections.
Highlights
----------
- The `UnliftedNewtypes` extension.
Full details
------------
......@@ -83,6 +85,11 @@ Language
type forall a (f :: forall k. k -> Type).
T a f = f Int
- A new extension :extension:`UnliftedNewtypes` that relaxes restrictions
around what kinds of types can appear inside of the data constructor
for a `newtype`. This was proposed in
`GHC proposal #13 <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst>`__.
Compiler
~~~~~~~~
......
......@@ -178,6 +178,10 @@ There are some restrictions on the use of primitive types:
newtype A = MkA Int#
However, this restriction can be relaxed by enabling
:extension:`-XUnliftedNewtypes`. The `section on unlifted newtypes
<#unlifted-newtypes>`__ details the behavior of such types.
- You cannot bind a variable with an unboxed type in a *top-level*
binding.