Be willing to parse {-# UNPACK #-} without '!'

This change gives a more helpful error message when the
user says    data T = MkT {-# UNPACK #-} Int
which should have a strictness '!' as well. Rather than
just a parse error, we get

  T7562.hs:3:14: Warning:
    UNPACK pragma lacks '!' on the first argument of `MkT'

Fixes Trac #7562

9 files changed, 73 insertions, 44 deletions

diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs
index e55a6e4c18..47e37a9c0e 100644
--- a/compiler/basicTypes/DataCon.lhs
+++ b/compiler/basicTypes/DataCon.lhs
@@ -442,15 +442,19 @@ data DataConRep
 -- HsBang describes what the *programmer* wrote
 -- This info is retained in the DataCon.dcStrictMarks field
 data HsBang 
-  = HsNoBang	       -- Lazy field
+  = HsUserBang   -- The user's source-code request
+       (Maybe Bool)       -- Just True    {-# UNPACK #-}
+                          -- Just False   {-# NOUNPACK #-}
+                          -- Nothing      no pragma
+       Bool               -- True <=> '!' specified
 
-  | HsBang Bool      -- Source-language '!' bang
-                     --  True <=> also an {-# UNPACK #-} pragma
+  | HsNoBang	          -- Lazy field
+                          -- HsUserBang Nothing False means the same as HsNoBang
 
   | HsUnpack              -- Definite commitment: this field is strict and unboxed
        (Maybe Coercion)   --    co :: arg-ty ~ product-ty
 
-  | HsStrict            -- Definite commitment: this field is strict but not unboxed
+  | HsStrict              -- Definite commitment: this field is strict but not unboxed
   deriving (Data.Data, Data.Typeable)
 
 -------------------------
@@ -489,7 +493,9 @@ Note [Bangs on data constructor arguments]
 Consider
   data T = MkT !Int {-# UNPACK #-} !Int Bool
 Its dcArgBangs field records the *users* specifications, in this case
-    [HsBang False, HsBang True, HsNoBang]
+    [ HsUserBang Nothing True
+    , HsUserBang (Just True) True
+    , HsNoBang]
 See the declaration of HsBang in BasicTypes
 
 The dcr_bangs field of the dcRep field records the *actual, decided*
@@ -538,12 +544,16 @@ instance Data.Data DataCon where
     dataTypeOf _ = mkNoRepType "DataCon"
 
 instance Outputable HsBang where
-    ppr HsNoBang             = empty
-    ppr (HsBang True)        = ptext (sLit "{-# UNPACK #-} !")
-    ppr (HsBang False)       = char '!'
-    ppr (HsUnpack Nothing)   = ptext (sLit "Unpk")
-    ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co)
-    ppr HsStrict             = ptext (sLit "SrictNotUnpacked")
+    ppr HsNoBang               = empty
+    ppr (HsUserBang prag bang) = pp_unpk prag <+> ppWhen bang (char '!')
+    ppr (HsUnpack Nothing)     = ptext (sLit "Unpk")
+    ppr (HsUnpack (Just co))   = ptext (sLit "Unpk") <> parens (ppr co)
+    ppr HsStrict               = ptext (sLit "SrictNotUnpacked")
+
+pp_unpk :: Maybe Bool -> SDoc
+pp_unpk Nothing      = empty
+pp_unpk (Just True)  = ptext (sLit "{-# UNPACK #-}")
+pp_unpk (Just False) = ptext (sLit "{-# NOUNPACK #-}")
 
 instance Outputable StrictnessMark where
   ppr MarkedStrict     = ptext (sLit "!")
@@ -551,16 +561,16 @@ instance Outputable StrictnessMark where
 
 
 eqHsBang :: HsBang -> HsBang -> Bool
-eqHsBang HsNoBang             HsNoBang             = True
 eqHsBang HsStrict             HsStrict             = True
-eqHsBang (HsBang b1)          (HsBang b2)          = b1 == b2
+eqHsBang (HsUserBang u1 b1)   (HsUserBang u2 b2)   = u1==u2 && b1==b2
 eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)   = True
 eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2)
 eqHsBang _ _ = False
 
 isBanged :: HsBang -> Bool
-isBanged HsNoBang = False
-isBanged _        = True
+isBanged HsNoBang                  = False
+isBanged (HsUserBang Nothing bang) = bang
+isBanged _                         = True
 
 isMarkedStrict :: StrictnessMark -> Bool
 isMarkedStrict NotMarkedStrict = False
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 1d12f6f12f..375e731077 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -593,7 +593,11 @@ dataConArgRep
 dataConArgRep _ _ arg_ty HsNoBang
   = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
-dataConArgRep dflags fam_envs arg_ty (HsBang user_unpack_prag) 
+dataConArgRep _ _ arg_ty (HsUserBang _ False)  -- No '!'
+  = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
+
+dataConArgRep dflags fam_envs arg_ty 
+    (HsUserBang unpk_prag True)  -- {-# UNPACK #-} !
   | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas
           -- Don't unpack if we aren't optimising; 
           -- rather arbitrarily, we use -fomit-iface-pragmas
@@ -602,10 +606,11 @@ dataConArgRep dflags fam_envs arg_ty (HsBang user_unpack_prag)
         arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
   , isUnpackableType fam_envs arg_ty'
   , (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
-  , user_unpack_prag
-    || gopt Opt_UnboxStrictFields dflags
-    || (gopt Opt_UnboxSmallStrictFields dflags 
-        && length rep_tys <= 1)  -- See Note [Unpack one-wide fields]
+  , case unpk_prag of
+      Nothing -> gopt Opt_UnboxStrictFields dflags
+              || (gopt Opt_UnboxSmallStrictFields dflags 
+                   && length rep_tys <= 1)  -- See Note [Unpack one-wide fields]
+      Just unpack_me -> unpack_me
   = case mb_co of
       Nothing          -> (HsUnpack Nothing,   rep_tys, wrappers)
       Just (co,rep_ty) -> (HsUnpack (Just co), rep_tys, wrapCo co rep_ty wrappers)
@@ -687,6 +692,10 @@ dataConArgUnpack arg_ty
 isUnpackableType :: FamInstEnvs -> Type -> Bool
 -- True if we can unpack the UNPACK fields of the constructor
 -- without involving the NameSet tycons
+-- See Note [Recursive unboxing]
+-- We look "deeply" inside rather than relying on the DataCons
+-- we encounter on the way, because otherwise we might well
+-- end up relying on ourselves!
 isUnpackableType fam_envs ty
   | Just (tc, _) <- splitTyConApp_maybe ty
   , Just con <- tyConSingleDataCon_maybe tc
@@ -695,7 +704,7 @@ isUnpackableType fam_envs ty
   | otherwise
   = False
   where
-    ok_arg tcs (ty, bang) = no_unpack bang || ok_ty tcs norm_ty
+    ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty
         where
           norm_ty = case topNormaliseType fam_envs ty of
                       Just (_, ty) -> ty
@@ -713,10 +722,12 @@ isUnpackableType fam_envs ty
 
     ok_con_args tcs con
        = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConStrictMarks con)
+         -- NB: dataConStrictMarks gives the *user* request; 
+         -- We'd get a black hole if we used dataConRepBangs
 
-    no_unpack (HsBang True)   = False
-    no_unpack (HsUnpack {})   = False
-    no_unpack _               = True
+    attempt_unpack (HsUnpack {})              = True
+    attempt_unpack (HsUserBang (Just unpk) _) = unpk
+    attempt_unpack _                          = False
 \end{code}
 
 Note [Unpack one-wide fields]
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index fd57f4656a..04ffb766a0 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -557,8 +557,8 @@ repBangTy ty= do
   rep2 strictTypeName [s, t]
   where
     (str, ty') = case ty of
-		   L _ (HsBangTy (HsBang True) ty) -> (unpackedName,  ty)
-		   L _ (HsBangTy _ ty)             -> (isStrictName,  ty)
+		   L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName,  ty)
+		   L _ (HsBangTy (HsUserBang _     True) ty)       -> (isStrictName,  ty)
 		   _                               -> (notStrictName, ty)
 
 -------------------------------------------------------
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index c5a92f8b28..a21caf44db 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -364,8 +364,8 @@ cvtConstr (ForallC tvs ctxt con)
 
 cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
 cvt_arg (NotStrict, ty) = cvtType ty
-cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang False) ty' }
-cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang True)  ty' }
+cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang Nothing     True) ty' }
+cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang (Just True) True) ty' }
 
 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
 cvt_id_arg (i, str, ty)
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index fed30f19e1..d5b302406e 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1528,7 +1528,7 @@ toIfaceBang _    HsNoBang            = IfNoBang
 toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
 toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (coToIfaceType (tidyCo env co))
 toIfaceBang _   HsStrict             = IfStrict
-toIfaceBang _   (HsBang {})          = panic "toIfaceBang"
+toIfaceBang _   (HsUserBang {})      = panic "toIfaceBang"
 
 classToIfaceDecl :: TidyEnv -> Class -> IfaceDecl
 classToIfaceDecl env clas
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index 4447ad5f35..932b46c2f5 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -217,8 +217,8 @@ pprDataConDecl pefas ss gadt_style dataCon
     -- See Note [Printing bangs on data constructors]
     user_ify :: HsBang -> HsBang
     user_ify bang | opt_PprStyle_Debug = bang
-    user_ify HsStrict                  = HsBang False
-    user_ify (HsUnpack {})             = HsBang True
+    user_ify HsStrict                  = HsUserBang Nothing     True
+    user_ify (HsUnpack {})             = HsUserBang (Just True) True
     user_ify bang                      = bang
 
     maybe_show_label (lbl,bty)
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index b6139621d1..c552b6aec7 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -1030,9 +1030,13 @@ infixtype :: { LHsType RdrName }
         | btype tyvarop  type    { LL $ mkHsOpTy $1 $2 $3 }
 
 strict_mark :: { Located HsBang }
-        : '!'                           { L1 (HsBang False) }
-        | '{-# UNPACK' '#-}' '!'        { LL (HsBang True) }
-        | '{-# NOUNPACK' '#-}' '!'      { LL HsStrict }
+        : '!'                           { L1 (HsUserBang Nothing      True) }
+        | '{-# UNPACK' '#-}'            { LL (HsUserBang (Just True)  False) }
+        | '{-# NOUNPACK' '#-}'          { LL (HsUserBang (Just False) True) }
+        | '{-# UNPACK' '#-}' '!'        { LL (HsUserBang (Just True)  True) }
+        | '{-# NOUNPACK' '#-}' '!'      { LL (HsUserBang (Just False) True) }
+        -- Although UNPAACK with no '!' is illegal, we get a 
+        -- better error message if we parse it here
 
 -- A ctype is a for-all type
 ctype   :: { LHsType RdrName }
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 0a25a6c03b..959c0c1847 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -1487,11 +1487,12 @@ reifyFixity name
       conv_dir BasicTypes.InfixN = TH.InfixN
 
 reifyStrict :: DataCon.HsBang -> TH.Strict
-reifyStrict HsNoBang        = TH.NotStrict
-reifyStrict (HsBang False)  = TH.Unpacked
-reifyStrict (HsBang True)   = TH.Unpacked
-reifyStrict HsStrict        = TH.IsStrict
-reifyStrict (HsUnpack {})   = TH.Unpacked
+reifyStrict HsNoBang                      = TH.NotStrict
+reifyStrict (HsUserBang _ False)          = TH.NotStrict
+reifyStrict (HsUserBang (Just True) True) = TH.Unpacked
+reifyStrict (HsUserBang _     True)       = TH.IsStrict
+reifyStrict HsStrict                      = TH.IsStrict
+reifyStrict (HsUnpack {})                 = TH.Unpacked
 
 ------------------------------
 noTH :: LitString -> SDoc -> TcM a
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 36fcc459c3..998450a0d6 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1399,19 +1399,22 @@ checkValidDataCon dflags existential_ok tc con
     }
   where
     ctxt = ConArgCtxt (dataConName con) 
-    check_bang (HsBang want_unpack, rep_bang, n) 
+    check_bang (HsUserBang (Just want_unpack) has_bang, rep_bang, n)
+      | want_unpack, not has_bang
+      = addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'")))
       | want_unpack
       , case rep_bang of { HsUnpack {} -> False; _ -> True }
       , not (gopt Opt_OmitInterfacePragmas dflags)  
            -- If not optimising, se don't unpack, so don't complain!
            -- See MkId.dataConArgRep, the (HsBang True) case
-      = addWarnTc (cant_unbox_msg n)
+      = addWarnTc (bad_bang n (ptext (sLit "Ignoring unusable UNPACK pragma")))
+
     check_bang _
       = return ()
 
-    cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the")
-                           , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)]
-
+    bad_bang n herald
+      = hang herald 2 (ptext (sLit "on the") <+> speakNth n 
+                       <+> ptext (sLit "argument of") <+> quotes (ppr con))
 -------------------------------
 checkNewDataCon :: DataCon -> TcM ()
 -- Checks for the data constructor of a newtype