Commit 4c8aab8f authored by Simon Peyton Jones's avatar Simon Peyton Jones Committed by Ben Gamari
Browse files

Test for newtype with unboxed argument

Newtypes cannot (currently) have an unboxed argument type.
But Trac #12729 showed that this was only being checked for
newtypes in H98 syntax; in GADT snytax they were let through.

This patch moves the test to checkValidDataCon, where it properly
belongs.

(cherry picked from commit 1f09c16c)
parent d84a824c
......@@ -21,7 +21,7 @@ module TcHsType (
-- Type checking type and class decls
kcLookupTcTyCon, kcTyClTyVars, tcTyClTyVars,
tcHsConArgType, tcDataKindSig,
tcDataKindSig,
-- Kind-checking types
-- No kind generalisation, no checkValidType
......@@ -287,17 +287,6 @@ tcHsTypeApp wc_ty kind
First a couple of simple wrappers for kcHsType
-}
tcHsConArgType :: NewOrData -> LHsType Name -> TcM Type
-- Permit a bang, but discard it
tcHsConArgType NewType bty = tcHsLiftedType (getBangType bty)
-- Newtypes can't have bangs, but we don't check that
-- until checkValidDataCon, so do not want to crash here
tcHsConArgType DataType bty = tcHsOpenType (getBangType bty)
-- Can't allow an unlifted type for newtypes, because we're effectively
-- going to remove the constructor while coercing it to a lifted type.
-- And newtypes can't be bang'd
---------------------------
tcHsOpenType, tcHsLiftedType,
tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType Name -> TcM TcType
......
......@@ -675,8 +675,7 @@ tcDataFamInstDecl mb_clsinfo
; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->
do { let ty_binders = mkTyBindersPreferAnon full_tvs liftedTypeKind
; data_cons <- tcConDecls new_or_data
rec_rep_tc
; data_cons <- tcConDecls rec_rep_tc
(full_tvs, ty_binders, orig_res_ty) cons
; tc_rhs <- case new_or_data of
DataType -> return (mkDataTyConRhs data_cons)
......
......@@ -915,8 +915,7 @@ tcDataDefn rec_info -- Knot-tied; don't look at this eagerly
; tycon <- fixM $ \ tycon -> do
{ let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs)
; data_cons <- tcConDecls new_or_data tycon
(final_tvs, final_bndrs, res_ty) cons
; data_cons <- tcConDecls tycon (final_tvs, final_bndrs, res_ty) cons
; tc_rhs <- mk_tc_rhs is_boot tycon data_cons
; tc_rep_nm <- newTyConRepName tc_name
; return (mkAlgTyCon tc_name (tycon_binders `chkAppend` extra_bndrs)
......@@ -1390,23 +1389,22 @@ consUseGadtSyntax _ = False
-- All constructors have same shape
-----------------------------------
tcConDecls :: NewOrData -> TyCon -> ([TyVar], [TyBinder], Type)
tcConDecls :: TyCon -> ([TyVar], [TyBinder], Type)
-> [LConDecl Name] -> TcM [DataCon]
-- Why both the tycon tyvars and binders? Because the tyvars
-- have all the names and the binders have the visibilities.
tcConDecls new_or_data rep_tycon (tmpl_tvs, tmpl_bndrs, res_tmpl)
tcConDecls rep_tycon (tmpl_tvs, tmpl_bndrs, res_tmpl)
= concatMapM $ addLocM $
tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl
tcConDecl rep_tycon tmpl_tvs tmpl_bndrs res_tmpl
tcConDecl :: NewOrData
-> TyCon -- Representation tycon. Knot-tied!
tcConDecl :: TyCon -- Representation tycon. Knot-tied!
-> [TyVar] -> [TyBinder] -> Type
-- Return type template (with its template tyvars)
-- (tvs, T tys), where T is the family TyCon
-> ConDecl Name
-> TcM [DataCon]
tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl
tcConDecl rep_tycon tmpl_tvs tmpl_bndrs res_tmpl
(ConDeclH98 { con_name = name
, con_qvars = hs_qvars, con_cxt = hs_ctxt
, con_details = hs_details })
......@@ -1422,7 +1420,7 @@ tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl
tcExplicitTKBndrs hs_tvs $ \ exp_tvs ->
do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs)
; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt)
; btys <- tcConArgs new_or_data hs_details
; btys <- tcConArgs hs_details
; field_lbls <- lookupConstructorFields (unLoc name)
; let (arg_tys, stricts) = unzip btys
bound_vars = allBoundVariabless ctxt `unionVarSet`
......@@ -1481,7 +1479,7 @@ tcConDecl new_or_data rep_tycon tmpl_tvs tmpl_bndrs res_tmpl
; mapM buildOneDataCon [name]
}
tcConDecl _new_or_data rep_tycon tmpl_tvs _tmpl_bndrs res_tmpl
tcConDecl rep_tycon tmpl_tvs _tmpl_bndrs res_tmpl
(ConDeclGADT { con_names = names, con_type = ty })
= addErrCtxt (dataConCtxtName names) $
do { traceTc "tcConDecl 1" (ppr names)
......@@ -1548,7 +1546,7 @@ tcGadtSigType doc name ty@(HsIB { hsib_vars = vars })
tcImplicitTKBndrs vars $
tcExplicitTKBndrs gtvs $ \ exp_tvs ->
do { ctxt <- tcHsContext cxt
; btys <- tcConArgs DataType hs_details
; btys <- tcConArgs hs_details
; ty' <- tcHsLiftedType res_ty
; field_lbls <- lookupConstructorFields name
; let (arg_tys, stricts) = unzip btys
......@@ -1582,16 +1580,16 @@ tcConIsInfixGADT con details
; return (con `elemNameEnv` fix_env) }
| otherwise -> return False
tcConArgs :: NewOrData -> HsConDeclDetails Name
tcConArgs :: HsConDeclDetails Name
-> TcM [(TcType, HsSrcBang)]
tcConArgs new_or_data (PrefixCon btys)
= mapM (tcConArg new_or_data) btys
tcConArgs new_or_data (InfixCon bty1 bty2)
= do { bty1' <- tcConArg new_or_data bty1
; bty2' <- tcConArg new_or_data bty2
tcConArgs (PrefixCon btys)
= mapM tcConArg btys
tcConArgs (InfixCon bty1 bty2)
= do { bty1' <- tcConArg bty1
; bty2' <- tcConArg bty2
; return [bty1', bty2'] }
tcConArgs new_or_data (RecCon fields)
= mapM (tcConArg new_or_data) btys
tcConArgs (RecCon fields)
= mapM tcConArg btys
where
-- We need a one-to-one mapping from field_names to btys
combined = map (\(L _ f) -> (cd_fld_names f,cd_fld_type f)) (unLoc fields)
......@@ -1600,10 +1598,10 @@ tcConArgs new_or_data (RecCon fields)
(_,btys) = unzip exploded
tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsSrcBang)
tcConArg new_or_data bty
tcConArg :: LHsType Name -> TcM (TcType, HsSrcBang)
tcConArg bty
= do { traceTc "tcConArg 1" (ppr bty)
; arg_ty <- tcHsConArgType new_or_data bty
; arg_ty <- tcHsOpenType (getBangType bty)
; traceTc "tcConArg 2" (ppr bty)
; return (arg_ty, getBangStrictness bty) }
......@@ -2282,6 +2280,9 @@ checkNewDataCon con
= do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))
-- One argument
; checkTc (not (isUnliftedType arg_ty1)) $
text "A newtype cannot have an unlifted argument type"
; check_con (null eq_spec) $
text "A newtype constructor must have a return type of form T a1 ... an"
-- Return type is (T a b c)
......@@ -2303,6 +2304,8 @@ checkNewDataCon con
check_con what msg
= checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con))
(arg_ty1 : _) = arg_tys
ok_bang (HsSrcBang _ _ SrcStrict) = False
ok_bang (HsSrcBang _ _ SrcLazy) = False
ok_bang _ = True
......
{-# LANGUAGE GADTs, MagicHash #-}
module T12729 where
import GHC.Exts
newtype A where
MkA :: Int# -> A
newtype B = MkB Int#
T12729.hs:8:4: error:
• A newtype cannot have an unlifted argument type
• In the definition of data constructor ‘MkA’
In the newtype declaration for ‘A’
T12729.hs:10:13: error:
• A newtype cannot have an unlifted argument type
• In the definition of data constructor ‘MkB’
In the newtype declaration for ‘B’
......@@ -427,3 +427,4 @@ test('T11990b', normal, compile_fail, [''])
test('T12124', normal, compile_fail, [''])
test('T12529', normal, compile_fail, [''])
test('T12589', normal, compile_fail, [''])
test('T12529', normal, compile_fail, [''])
tcfail079.hs:9:27:
Expecting a lifted type, but ‘Int#’ is unlifted
In the type ‘Int#’
In the definition of data constructor ‘Unboxed’
In the newtype declaration for ‘Unboxed’
tcfail079.hs:9:19: error:
• A newtype cannot have an unlifted argument type
• In the definition of data constructor ‘Unboxed’
In the newtype declaration for ‘Unboxed’
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment