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.

3 files changed, 30 insertions, 36 deletions

diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs
index 9919c0fd56..055159d988 100644
--- a/compiler/typecheck/TcHsType.hs
+++ b/compiler/typecheck/TcHsType.hs
@@ -22,7 +22,7 @@ module TcHsType (
 
                 -- Type checking type and class decls
         kcLookupTcTyCon, kcTyClTyVars, tcTyClTyVars,
-        tcHsConArgType, tcDataKindSig,
+        tcDataKindSig,
 
         -- Kind-checking types
         -- No kind generalisation, no checkValidType
@@ -297,17 +297,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
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index a0bbb836fd..c18d69d4be 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -650,8 +650,7 @@ tcDataFamInstDecl mb_clsinfo
 
        ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->
            do { let ty_binders = mkTyConBindersPreferAnon full_tvs liftedTypeKind
-              ; data_cons <- tcConDecls new_or_data
-                                        rec_rep_tc
+              ; data_cons <- tcConDecls rec_rep_tc
                                         (ty_binders, orig_res_ty) cons
               ; tc_rhs <- case new_or_data of
                      DataType -> return (mkDataTyConRhs data_cons)
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index 155396f4b7..6715a8795a 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -942,8 +942,7 @@ tcDataDefn roles_info
 
        ; tycon <- fixM $ \ tycon -> do
              { let res_ty = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs))
-             ; data_cons <- tcConDecls new_or_data tycon
-                                       (final_bndrs, res_ty) cons
+             ; data_cons <- tcConDecls tycon (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
@@ -1426,23 +1425,22 @@ consUseGadtSyntax _                           = False
                  -- All constructors have same shape
 
 -----------------------------------
-tcConDecls :: NewOrData -> TyCon -> ([TyConBinder], Type)
+tcConDecls :: TyCon -> ([TyConBinder], 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_bndrs, res_tmpl)
+tcConDecls rep_tycon (tmpl_bndrs, res_tmpl)
   = concatMapM $ addLocM $
-    tcConDecl new_or_data rep_tycon tmpl_bndrs res_tmpl
+    tcConDecl rep_tycon tmpl_bndrs res_tmpl
 
-tcConDecl :: NewOrData
-          -> TyCon             -- Representation tycon. Knot-tied!
+tcConDecl :: TyCon             -- Representation tycon. Knot-tied!
           -> [TyConBinder] -> 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_bndrs res_tmpl
+tcConDecl rep_tycon tmpl_bndrs res_tmpl
           (ConDeclH98 { con_name = name
                       , con_qvars = hs_qvars, con_cxt = hs_ctxt
                       , con_details = hs_details })
@@ -1458,7 +1456,7 @@ tcConDecl new_or_data rep_tycon 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`
@@ -1516,7 +1514,7 @@ tcConDecl new_or_data rep_tycon tmpl_bndrs res_tmpl
        ; mapM buildOneDataCon [name]
        }
 
-tcConDecl _new_or_data rep_tycon tmpl_bndrs res_tmpl
+tcConDecl rep_tycon tmpl_bndrs res_tmpl
           (ConDeclGADT { con_names = names, con_type = ty })
   = addErrCtxt (dataConCtxtName names) $
     do { traceTc "tcConDecl 1" (ppr names)
@@ -1583,7 +1581,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
@@ -1617,16 +1615,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)
@@ -1635,10 +1633,13 @@ 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)
+             -- Newtypes can't have unboxed types, but we check
+             -- that in checkValidDataCon; this tcConArg stuff
+             -- doesn't happen for GADT-style declarations
         ; traceTc "tcConArg 2" (ppr bty)
         ; return (arg_ty, getBangStrictness bty) }
 
@@ -2340,6 +2341,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)
@@ -2361,6 +2365,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