Improve HsBang

Provoked by questions from Johan

 - Improve comments, fix misleading stuff
 - Add commented synonyms for HsSrcBang, HsImplBang, and use them throughout
 - Rename HsUserBang to HsSrcBang
 - Rename dataConStrictMarks to dataConSrcBangs
          dataConRepBangs    to dataConImplBangs

This renaming affects Haddock in a trivial way, hence submodule update

15 files changed, 118 insertions, 89 deletions

diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index 4323d6d147..e77af96af1 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -9,7 +9,9 @@
 
 module DataCon (
         -- * Main data types
-        DataCon, DataConRep(..), HsBang(..), StrictnessMark(..),
+        DataCon, DataConRep(..),
+        HsBang(..), HsSrcBang, HsImplBang,
+        StrictnessMark(..),
         ConTag,
 
         -- ** Type construction
@@ -26,11 +28,11 @@ module DataCon (
         dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
         dataConInstOrigArgTys, dataConRepArgTys,
         dataConFieldLabels, dataConFieldType,
-        dataConStrictMarks,
+        dataConSrcBangs,
         dataConSourceArity, dataConRepArity, dataConRepRepArity,
         dataConIsInfix,
         dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
-        dataConRepStrictness, dataConRepBangs, dataConBoxer,
+        dataConRepStrictness, dataConImplBangs, dataConBoxer,
 
         splitDataProductType_maybe,
 
@@ -342,8 +344,8 @@ data DataCon
 
         -- Now the strictness annotations and field labels of the constructor
         -- See Note [Bangs on data constructor arguments]
-        dcArgBangs :: [HsBang],
-                -- Strictness annotations as decided by the compiler.
+        dcSrcBangs :: [HsSrcBang],
+                -- Strictness annotations as written by the programmer.
                 -- Matches 1-1 with dcOrigArgTys
                 -- Hence length = dataConSourceArity dataCon
 
@@ -406,9 +408,9 @@ data DataConRep
         , dcr_stricts :: [StrictnessMark]  -- 1-1 with dcr_arg_tys
                 -- See also Note [Data-con worker strictness] in MkId.lhs
 
-        , dcr_bangs :: [HsBang]  -- The actual decisions made (including failures)
-                                 -- 1-1 with orig_arg_tys
-                                 -- See Note [Bangs on data constructor arguments]
+        , dcr_bangs :: [HsImplBang]  -- The actual decisions made (including failures)
+                                     -- about the original arguments; 1-1 with orig_arg_tys
+                                     -- See Note [Bangs on data constructor arguments]
 
     }
 -- Algebraic data types always have a worker, and
@@ -437,30 +439,55 @@ data DataConRep
 -- when we bring bits of unfoldings together.)
 
 -------------------------
--- HsBang describes what the *programmer* wrote
--- This info is retained in the DataCon.dcStrictMarks field
+-- HsBang describes the strictness/unpack status of one
+-- of the original data constructor arguments (i.e. *not*
+-- of the representation data constructor which may have
+-- more arguments after the originals have been unpacked)
+-- See Note [Bangs on data constructor arguments]
 data HsBang
-  = HsUserBang   -- The user's source-code request
+  = HsNoBang     -- Equivalent to (HsSrcBang Nothing False)
+
+  | HsSrcBang    -- What the user wrote in the source code
        (Maybe Bool)       -- Just True    {-# UNPACK #-}
                           -- Just False   {-# NOUNPACK #-}
                           -- Nothing      no pragma
        Bool               -- True <=> '!' specified
+       -- (HsSrcBang (Just True) False) makes no sense
+       -- We emit a warning (in checkValidDataCon) and treat it
+       -- just like (HsSrcBang Nothing False)
 
-  | HsNoBang              -- Lazy field
-                          -- HsUserBang Nothing False means the same as HsNoBang
-
+  -- Definite implementation commitments, generated by the compiler
+  -- after consulting HsSrcBang (if any), flags, etc
   | 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
   deriving (Data.Data, Data.Typeable)
 
+-- Two type-insecure, but useful, synonyms
+type HsSrcBang = HsBang   -- What the user wrote; hence always HsNoBang or HsSrcBang
+                          -- But see Note [HsSrcBang exceptions]
+
+type HsImplBang = HsBang   -- A HsBang implementation decision,
+                           -- as determined by the compiler
+                           -- Never HsSrcBang
+
 -------------------------
 -- StrictnessMark is internal only, used to indicate strictness
 -- of the DataCon *worker* fields
 data StrictnessMark = MarkedStrict | NotMarkedStrict
 
-{-
+{- Note [HsSrcBang exceptions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Exceptions to rule that HsSrcBang is always HsSrcBang or HsNoBang:
+
+* When we build a DataCon from an interface file we don't
+  know what the user wrote, so we use HsUnpack/HsStrict
+
+* In MkId.mkDataConRep we want to say "always unpack an equality
+  predicate for equality arguments so we use HsUnpack
+  see MkId.mk_pred_strict_mark
+
 Note [Data con representation]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The dcRepType field contains the type of the representation of a contructor
@@ -483,11 +510,10 @@ Note [Bangs on data constructor arguments]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
   data T = MkT !Int {-# UNPACK #-} !Int Bool
-Its dcArgBangs field records the *users* specifications, in this case
-    [ HsUserBang Nothing True
-    , HsUserBang (Just True) True
+Its dcSrcBangs field records the *users* specifications, in this case
+    [ HsSrcBang Nothing True
+    , HsSrcBang (Just True) True
     , HsNoBang]
-See the declaration of HsBang in BasicTypes
 
 The dcr_bangs field of the dcRep field records the *actual, decided*
 representation of the data constructor.  Without -O this might be
@@ -497,7 +523,7 @@ With -O it might be
 With -funbox-small-strict-fields it might be
     [HsUnpack, HsUnpack, HsNoBang]
 
-For imported data types, the dcArgBangs field is just the same as the
+For imported data types, the dcSrcBangs field is just the same as the
 dcr_bangs field; we don't know what the user originally said.
 
 
@@ -539,11 +565,11 @@ instance Data.Data DataCon where
     dataTypeOf _ = mkNoRepType "DataCon"
 
 instance Outputable HsBang where
-    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")
+    ppr HsNoBang              = empty
+    ppr (HsSrcBang 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
@@ -558,15 +584,16 @@ instance Outputable StrictnessMark where
 eqHsBang :: HsBang -> HsBang -> Bool
 eqHsBang HsNoBang             HsNoBang             = True
 eqHsBang HsStrict             HsStrict             = True
-eqHsBang (HsUserBang u1 b1)   (HsUserBang u2 b2)   = u1==u2 && b1==b2
+eqHsBang (HsSrcBang u1 b1)    (HsSrcBang 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 (HsUserBang Nothing bang) = bang
-isBanged _                         = True
+isBanged HsNoBang           = False
+isBanged (HsSrcBang _ bang) = bang
+isBanged (HsUnpack {})      = True
+isBanged (HsStrict {})      = True
 
 isMarkedStrict :: StrictnessMark -> Bool
 isMarkedStrict NotMarkedStrict = False
@@ -583,7 +610,7 @@ isMarkedStrict _               = True   -- All others are strict
 -- | Build a new data constructor
 mkDataCon :: Name
           -> Bool               -- ^ Is the constructor declared infix?
-          -> [HsBang]           -- ^ Strictness annotations written in the source file
+          -> [HsSrcBang]        -- ^ User-supplied strictness/unpack annotations
           -> [FieldLabel]       -- ^ Field labels for the constructor, if it is a record,
                                 --   otherwise empty
           -> [TyVar]            -- ^ Universally quantified type variables
@@ -626,7 +653,7 @@ mkDataCon name declared_infix
                   dcStupidTheta = stupid_theta,
                   dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
                   dcRepTyCon = rep_tycon,
-                  dcArgBangs = arg_stricts,
+                  dcSrcBangs = arg_stricts,
                   dcFields = fields, dcTag = tag, dcRepType = rep_ty,
                   dcWorkId = work_id,
                   dcRep = rep,
@@ -764,10 +791,10 @@ dataConFieldType con label
       Just ty -> ty
       Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
 
--- | The strictness markings decided on by the compiler.  Does not include those for
--- existential dictionaries.  The list is in one-to-one correspondence with the arity of the 'DataCon'
-dataConStrictMarks :: DataCon -> [HsBang]
-dataConStrictMarks = dcArgBangs
+-- | The strictness markings written by the porgrammer.
+-- The list is in one-to-one correspondence with the arity of the 'DataCon'
+dataConSrcBangs :: DataCon -> [HsSrcBang]
+dataConSrcBangs = dcSrcBangs
 
 -- | Source-level arity of the data constructor
 dataConSourceArity :: DataCon -> Arity
@@ -800,9 +827,11 @@ dataConRepStrictness dc = case dcRep dc of
                             NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]
                             DCR { dcr_stricts = strs } -> strs
 
-dataConRepBangs :: DataCon -> [HsBang]
-dataConRepBangs dc = case dcRep dc of
-                       NoDataConRep -> dcArgBangs dc
+dataConImplBangs :: DataCon -> [HsImplBang]
+-- The implementation decisions about the strictness/unpack of each
+-- source program argument to the data constructor
+dataConImplBangs dc = case dcRep dc of
+                       NoDataConRep              -> dcSrcBangs dc
                        DCR { dcr_bangs = bangs } -> bangs
 
 dataConBoxer :: DataCon -> Maybe DataConBoxer
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index cfdc7385a5..0899997f3b 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -519,7 +519,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
     wrap_ty      = dataConUserType data_con
     ev_tys       = eqSpecPreds eq_spec ++ theta
     all_arg_tys  = ev_tys                         ++ orig_arg_tys
-    orig_bangs   = map mk_pred_strict_mark ev_tys ++ dataConStrictMarks data_con
+    orig_bangs   = map mk_pred_strict_mark ev_tys ++ dataConSrcBangs data_con
 
     wrap_arg_tys = theta ++ orig_arg_tys
     wrap_arity   = length wrap_arg_tys
@@ -580,19 +580,19 @@ newLocal ty = do { uniq <- getUniqueM
 dataConArgRep
    :: DynFlags
    -> FamInstEnvs
-   -> Type -> HsBang
-   -> ( HsBang   -- Like input but with HsUnpackFailed if necy
+   -> Type -> HsSrcBang
+   -> ( HsImplBang                 -- Implementation decision about unpack strategy
       , [(Type, StrictnessMark)]   -- Rep types
       , (Unboxer, Boxer) )
 
 dataConArgRep _ _ arg_ty HsNoBang
   = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
-dataConArgRep _ _ arg_ty (HsUserBang _ False)  -- No '!'
+dataConArgRep _ _ arg_ty (HsSrcBang _ False)  -- No '!'
   = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
 
 dataConArgRep dflags fam_envs arg_ty
-    (HsUserBang unpk_prag True)  -- {-# UNPACK #-} !
+    (HsSrcBang 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 as the indication
@@ -625,7 +625,7 @@ dataConArgRep _ _ _ (HsUnpack (Just co))
   , (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
   = (HsUnpack (Just co), rep_tys, wrapCo co co_rep_ty wrappers)
 
-strict_but_not_unpacked :: Type -> (HsBang, [(Type,StrictnessMark)], (Unboxer, Boxer))
+strict_but_not_unpacked :: Type -> (HsImplBang, [(Type,StrictnessMark)], (Unboxer, Boxer))
 strict_but_not_unpacked arg_ty
   = (HsStrict, [(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
 
@@ -716,15 +716,15 @@ isUnpackableType fam_envs ty
       = True
 
     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
+       = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConSrcBangs con)
+         -- NB: dataConSrcBangs gives the *user* request;
+         -- We'd get a black hole if we used dataConImplBangs
 
-    attempt_unpack (HsUnpack {})                 = True
-    attempt_unpack (HsUserBang (Just unpk) bang) = bang && unpk
-    attempt_unpack (HsUserBang Nothing bang)     = bang  -- Be conservative
-    attempt_unpack HsStrict                      = False
-    attempt_unpack HsNoBang                      = False
+    attempt_unpack (HsUnpack {})                = True
+    attempt_unpack (HsSrcBang (Just unpk) bang) = bang && unpk
+    attempt_unpack (HsSrcBang Nothing bang)     = bang  -- Be conservative
+    attempt_unpack HsStrict                     = False
+    attempt_unpack HsNoBang                     = False
 
 {-
 Note [Unpack one-wide fields]
@@ -789,7 +789,7 @@ heavy lifting.  This one line makes every GADT take a word less
 space for each equality predicate, so it's pretty important!
 -}
 
-mk_pred_strict_mark :: PredType -> HsBang
+mk_pred_strict_mark :: PredType -> HsSrcBang
 mk_pred_strict_mark pred
   | isEqPred pred = HsUnpack Nothing    -- Note [Unpack equality predicates]
   | otherwise     = HsNoBang
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index a94d996e7d..b7445a8e2b 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -651,9 +651,9 @@ repBangTy ty= do
   rep2 strictTypeName [s, t]
   where
     (str, ty') = case ty of
-                   L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName,  ty)
-                   L _ (HsBangTy (HsUserBang _     True) ty)       -> (isStrictName,  ty)
-                   _                               -> (notStrictName, ty)
+                   L _ (HsBangTy (HsSrcBang (Just True) True) ty) -> (unpackedName,  ty)
+                   L _ (HsBangTy (HsSrcBang _     True) ty)       -> (isStrictName,  ty)
+                   _                                              -> (notStrictName, ty)
 
 -------------------------------------------------------
 --                      Deriving clause
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 3c2b5e7fdb..92af65170f 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -436,8 +436,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 (HsUserBang Nothing     True) ty' }
-cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang (Just True) True) ty' }
+cvt_arg (IsStrict,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsSrcBang Nothing     True) ty' }
+cvt_arg (Unpacked,  ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsSrcBang (Just True) True) ty' }
 
 cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
 cvt_id_arg (i, str, ty)
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index badcbe700a..41142bb053 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -28,7 +28,7 @@ module HsTypes (
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
 
-        LBangType, BangType, HsBang(..),
+        LBangType, BangType, HsBang(..), HsSrcBang, HsImplBang,
         getBangType, getBangStrictness,
 
         ConDeclField(..), LConDeclField, pprConDeclFields,
@@ -55,7 +55,7 @@ import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
 
 import Name( Name )
 import RdrName( RdrName )
-import DataCon( HsBang(..) )
+import DataCon( HsBang(..), HsSrcBang, HsImplBang )
 import TysPrim( funTyConName )
 import Type
 import HsDoc
@@ -106,7 +106,7 @@ getBangType :: LHsType a -> LHsType a
 getBangType (L _ (HsBangTy _ ty)) = ty
 getBangType ty                    = ty
 
-getBangStrictness :: LHsType a -> HsBang
+getBangStrictness :: LHsType a -> HsSrcBang
 getBangStrictness (L _ (HsBangTy s _)) = s
 getBangStrictness _                    = HsNoBang
 
@@ -292,8 +292,8 @@ data HsType name
 
   | HsDocTy             (LHsType name) LHsDocString -- A documented type
 
-  | HsBangTy    HsBang (LHsType name)   -- Bang-style type annotations
-  | HsRecTy     [LConDeclField name]    -- Only in data type declarations
+  | HsBangTy    HsSrcBang (LHsType name)   -- Bang-style type annotations
+  | HsRecTy     [LConDeclField name]       -- Only in data type declarations
 
   | HsCoreTy Type       -- An escape hatch for tunnelling a *closed*
                         -- Core Type through HsSyn.
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 6e14700cfa..48f5d99efe 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -128,7 +128,7 @@ mkNewTyConRhs tycon_name tycon con
 ------------------------------------------------------
 buildDataCon :: FamInstEnvs
             -> Name -> Bool
-            -> [HsBang]
+            -> [HsSrcBang]
             -> [Name]                   -- Field labels
             -> [TyVar] -> [TyVar]       -- Univ and ext
             -> [(TyVar,Type)]           -- Equality spec
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 7226cb01f8..e7cc3adc19 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1684,7 +1684,7 @@ tyConToIfaceDecl env tycon
                     ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,
                     ifConFields  = map getOccName
                                        (dataConFieldLabels data_con),
-                    ifConStricts = map (toIfaceBang con_env2) (dataConRepBangs data_con) }
+                    ifConStricts = map (toIfaceBang con_env2) (dataConImplBangs data_con) }
         where
           (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
 
@@ -1701,12 +1701,12 @@ tyConToIfaceDecl env tycon
           (con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs
           to_eq_spec (tv,ty)  = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
 
-toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
+toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
 toIfaceBang _    HsNoBang            = IfNoBang
 toIfaceBang _   (HsUnpack Nothing)   = IfUnpack
 toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
 toIfaceBang _   HsStrict             = IfStrict
-toIfaceBang _   (HsUserBang {})      = panic "toIfaceBang"
+toIfaceBang _   (HsSrcBang {})       = panic "toIfaceBang"
 
 classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
 classToIfaceDecl env clas
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 539961be90..2557ec4fee 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -172,7 +172,7 @@ module GHC (
         DataCon,
         dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
         dataConIsInfix, isVanillaDataCon, dataConUserType,
-        dataConStrictMarks,  
+        dataConSrcBangs,
         StrictnessMark(..), isMarkedStrict,
 
         -- ** Classes
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 7739d973f0..4958e0c6a3 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1351,11 +1351,11 @@ sigtypes1 :: { (OrdList (LHsType RdrName)) }      -- Always HsForAllTys
 -- Types
 
 strict_mark :: { Located ([AddAnn],HsBang) }
-        : '!'                        { sL1 $1    ([],            HsUserBang Nothing      True) }
-        | '{-# UNPACK' '#-}'         { sLL $1 $> ([mo $1,mc $2], HsUserBang (Just True)  False) }
-        | '{-# NOUNPACK' '#-}'       { sLL $1 $> ([mo $1,mc $2], HsUserBang (Just False) False) }
-        | '{-# UNPACK' '#-}' '!'     { sLL $1 $> ([mo $1,mc $2], HsUserBang (Just True)  True) }
-        | '{-# NOUNPACK' '#-}' '!'   { sLL $1 $> ([mo $1,mc $2], HsUserBang (Just False) True) }
+        : '!'                        { sL1 $1    ([],            HsSrcBang Nothing      True) }
+        | '{-# UNPACK' '#-}'         { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True)  False) }
+        | '{-# NOUNPACK' '#-}'       { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) False) }
+        | '{-# UNPACK' '#-}' '!'     { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True)  True) }
+        | '{-# NOUNPACK' '#-}' '!'   { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) True) }
         -- Although UNPACK with no '!' is illegal, we get a
         -- better error message if we parse it here
 
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index f5da0b2014..a3a9be3f80 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1416,7 +1416,7 @@ checkMissingFields data_con rbinds
                           field_labels
                           field_strs
 
-    field_strs = dataConStrictMarks data_con
+    field_strs = dataConSrcBangs data_con
 
 {-
 ************************************************************************
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index b78b69d8be..dfe69055cf 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1006,7 +1006,7 @@ checkBootTyCon tc1 tc2
                (text "The fixities of" <+> pname1 <+>
                 text "differ") `andThenCheck`
          check (eqListBy eqHsBang
-                         (dataConStrictMarks c1) (dataConStrictMarks c2))
+                         (dataConSrcBangs c1) (dataConSrcBangs c2))
                (text "The strictness annotations for" <+> pname1 <+>
                 text "differ") `andThenCheck`
          check (dataConFieldLabels c1 == dataConFieldLabels c2)
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 617a6fc28d..020722c594 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1268,7 +1268,7 @@ reifyDataCon tys dc
              (subst', ex_tvs') = mapAccumL substTyVarBndr subst (dropList tys tvs)
              theta'   = substTheta subst' theta
              arg_tys' = substTys subst' arg_tys
-             stricts  = map reifyStrict (dataConStrictMarks dc)
+             stricts  = map reifyStrict (dataConSrcBangs dc)
              fields   = dataConFieldLabels dc
              name     = reifyName dc
 
@@ -1620,13 +1620,13 @@ reifyFixity name
       conv_dir BasicTypes.InfixL = TH.InfixL
       conv_dir BasicTypes.InfixN = TH.InfixN
 
-reifyStrict :: DataCon.HsBang -> TH.Strict
-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
+reifyStrict :: DataCon.HsSrcBang -> TH.Strict
+reifyStrict HsNoBang                     = TH.NotStrict
+reifyStrict (HsSrcBang _ False)          = TH.NotStrict
+reifyStrict (HsSrcBang (Just True) True) = TH.Unpacked
+reifyStrict (HsSrcBang _     True)       = TH.IsStrict
+reifyStrict HsStrict                     = TH.IsStrict
+reifyStrict (HsUnpack {})                = TH.Unpacked
 
 ------------------------------
 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index d187b091f4..27e2d45a03 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1227,7 +1227,7 @@ tcConIsInfix con details (ResTyGADT _)
 
 
 tcConArgs :: NewOrData -> HsConDeclDetails Name
-          -> TcM ([Name], [(TcType, HsBang)])
+          -> TcM ([Name], [(TcType, HsSrcBang)])
 tcConArgs new_or_data (PrefixCon btys)
   = do { btys' <- mapM (tcConArg new_or_data) btys
        ; return ([], btys') }
@@ -1245,7 +1245,7 @@ tcConArgs new_or_data (RecCon fields)
     exploded = concatMap explode combined
     (field_names,btys) = unzip exploded
 
-tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsBang)
+tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsSrcBang)
 tcConArg new_or_data bty
   = do  { traceTc "tcConArg 1" (ppr bty)
         ; arg_ty <- tcHsConArgType new_or_data bty
@@ -1572,7 +1572,7 @@ checkValidDataCon dflags existential_ok tc con
           -- Check that UNPACK pragmas and bangs work out
           -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"
           --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack
-        ; mapM_ check_bang (zip3 (dataConStrictMarks con) (dataConRepBangs con) [1..])
+        ; mapM_ check_bang (zip3 (dataConSrcBangs con) (dataConImplBangs con) [1..])
 
           -- Check that existentials are allowed if they are used
         ; checkTc (existential_ok || isVanillaDataCon con)
@@ -1589,7 +1589,7 @@ checkValidDataCon dflags existential_ok tc con
     }
   where
     ctxt = ConArgCtxt (dataConName con)
-    check_bang (HsUserBang (Just want_unpack) has_bang, rep_bang, n)
+    check_bang (HsSrcBang (Just want_unpack) has_bang, rep_bang, n)
       | want_unpack, not has_bang
       = addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'")))
       | want_unpack
@@ -1623,7 +1623,7 @@ checkNewDataCon con
           ptext (sLit "A newtype constructor cannot have existential type variables")
                 -- No existentials
 
-        ; checkTc (not (any isBanged (dataConStrictMarks con)))
+        ; checkTc (not (any isBanged (dataConSrcBangs con)))
                   (newtypeStrictError con)
                 -- No strictness
     }
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 37a07f710d..7b4d5aaad0 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -177,7 +177,7 @@ vectDataCon dc
        ; liftDs $ buildDataCon fam_envs
                     name'
                     (dataConIsInfix dc)            -- infix if the original is
-                    (dataConStrictMarks dc)        -- strictness as original constructor
+                    (dataConSrcBangs dc)           -- strictness as original constructor
                     []                             -- no labelled fields for now
                     univ_tvs                       -- universally quantified vars
                     []                             -- no existential tvs for now
diff --git a/utils/haddock b/utils/haddock
-Subproject 8b1d44fbdde141cf883f5ddcd337bbbab843322
+Subproject 04cf63d0195837ed52075ed7d2676e71831e8a0