Rework Template Haskell's handling of strictness

Currently, Template Haskell's treatment of strictness is not enough to
cover all possible combinations of unpackedness and strictness. In
addition, it isn't equipped to deal with new features (such as
`-XStrictData`) which can change a datatype's fields' strictness during
compilation.

To address this, I replaced TH's `Strict` datatype with
`SourceUnpackedness` and `SourceStrictness` (which give the programmer a
more complete toolkit to configure a datatype field's strictness than
just `IsStrict`, `IsLazy`, and `Unpack`). I also added the ability to
reify a constructor fields' strictness post-compilation through the
`reifyConStrictness` function.

Fixes #10697.

Test Plan: ./validate

Reviewers: simonpj, goldfire, bgamari, austin

Reviewed By: goldfire, bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D1603

GHC Trac Issues: #10697

37 files changed, 622 insertions, 224 deletions

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 0c72a9f266..f56f446a12 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -637,18 +637,27 @@ repC (L _ (ConDeclGADT { con_names = cons
   where
      gadtDetails = gadtDeclDetails res_ty
 
-repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
+repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)
+repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []
+repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []
+repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []
+
+repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)
+repSrcStrictness SrcLazy     = rep2 sourceLazyName         []
+repSrcStrictness SrcStrict   = rep2 sourceStrictName       []
+repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []
+
+repBangTy :: LBangType Name -> DsM (Core (TH.BangTypeQ))
 repBangTy ty = do
-  MkC s <- rep2 str []
+  MkC u <- repSrcUnpackedness su'
+  MkC s <- repSrcStrictness ss'
+  MkC b <- rep2 bangName [u, s]
   MkC t <- repLTy ty'
-  rep2 strictTypeName [s, t]
+  rep2 bangTypeName [b, t]
   where
-    (str, ty') = case ty of
-         L _ (HsBangTy (HsSrcBang _ SrcUnpack SrcStrict) ty)
-           -> (unpackedName,  ty)
-         L _ (HsBangTy (HsSrcBang _ _         SrcStrict) ty)
-           -> (isStrictName,  ty)
-         _ -> (notStrictName, ty)
+    (su', ss', ty') = case ty of
+            L _ (HsBangTy (HsSrcBang _ su ss) ty) -> (su, ss, ty)
+            _ -> (NoSrcUnpack, NoSrcStrict, ty)
 
 -------------------------------------------------------
 --                      Deriving clause
@@ -1955,18 +1964,18 @@ repConstr :: HsConDeclDetails Name
           -> [Core TH.Name]
           -> DsM (Core TH.ConQ)
 repConstr (PrefixCon ps) Nothing [con]
-    = do arg_tys  <- repList strictTypeQTyConName repBangTy ps
+    = do arg_tys  <- repList bangTypeQTyConName repBangTy ps
          rep2 normalCName [unC con, unC arg_tys]
 
 repConstr (PrefixCon ps) (Just res_ty) cons
-    = do arg_tys      <- repList strictTypeQTyConName repBangTy ps
+    = do arg_tys      <- repList bangTypeQTyConName repBangTy ps
          (res_n, idx) <- repGadtReturnTy res_ty
          rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_n
                         , unC idx]
 
 repConstr (RecCon (L _ ips)) resTy cons
     = do args     <- concatMapM rep_ip ips
-         arg_vtys <- coreList varStrictTypeQTyConName args
+         arg_vtys <- coreList varBangTypeQTyConName args
          case resTy of
            Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]
            Just res_ty -> do
@@ -1980,7 +1989,7 @@ repConstr (RecCon (L _ ips)) resTy cons
       rep_one_ip :: LBangType Name -> LFieldOcc Name -> DsM (Core a)
       rep_one_ip t n = do { MkC v  <- lookupOcc (selectorFieldOcc $ unLoc n)
                           ; MkC ty <- repBangTy  t
-                          ; rep2 varStrictTypeName [v,ty] }
+                          ; rep2 varBangTypeName [v,ty] }
 
 repConstr (InfixCon st1 st2) Nothing [con]
     = do arg1 <- repBangTy st1
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 6c35a25876..4b79922863 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -503,16 +503,24 @@ cvtConstr (RecGadtC c varstrtys ty idx)
         ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ret_ty)
         ; returnL $ mkGadtDecl c' (mkLHsSigType rec_ty) }
 
-cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
-cvt_arg (NotStrict, ty) = cvtType ty
-cvt_arg (IsStrict,  ty)
+cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness
+cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack
+cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack
+cvtSrcUnpackedness SourceUnpack         = SrcUnpack
+
+cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness
+cvtSrcStrictness NoSourceStrictness = NoSrcStrict
+cvtSrcStrictness SourceLazy         = SrcLazy
+cvtSrcStrictness SourceStrict       = SrcStrict
+
+cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType RdrName)
+cvt_arg (Bang su ss, ty)
   = do { ty' <- cvtType ty
-       ; returnL $ HsBangTy (HsSrcBang Nothing NoSrcUnpack SrcStrict) ty' }
-cvt_arg (Unpacked,  ty)
-  = do { ty' <- cvtType ty
-       ; returnL $ HsBangTy (HsSrcBang Nothing SrcUnpack   SrcStrict) ty' }
+       ; let su' = cvtSrcUnpackedness su
+       ; let ss' = cvtSrcStrictness ss
+       ; returnL $ HsBangTy (HsSrcBang Nothing su' ss') ty' }
 
-cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
+cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField RdrName)
 cvt_id_arg (i, str, ty)
   = do  { L li i' <- vNameL i
         ; ty' <- cvt_arg (str,ty)
diff --git a/compiler/prelude/THNames.hs b/compiler/prelude/THNames.hs
index d683b1a9b4..392aeda1ff 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/prelude/THNames.hs
@@ -73,14 +73,18 @@ templateHaskellNames = [
     roleAnnotDName,
     -- Cxt
     cxtName,
-    -- Strict
-    isStrictName, notStrictName, unpackedName,
+    -- SourceUnpackedness
+    noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName,
+    -- SourceStrictness
+    noSourceStrictnessName, sourceLazyName, sourceStrictName,
     -- Con
     normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName,
-    -- StrictType
-    strictTypeName,
-    -- VarStrictType
-    varStrictTypeName,
+    -- Bang
+    bangName,
+    -- BangType
+    bangTypeName,
+    -- VarBangType
+    varBangTypeName,
     -- Type
     forallTName, varTName, conTName, appTName, equalityTName,
     tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, litTName,
@@ -130,8 +134,8 @@ templateHaskellNames = [
     -- And the tycons
     qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
     clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
-    stmtQTyConName, decQTyConName, conQTyConName, strictTypeQTyConName,
-    varStrictTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
+    stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,
+    varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
     typeTyConName, tyVarBndrTyConName, matchTyConName, clauseTyConName,
     patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
     predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
@@ -349,11 +353,17 @@ roleAnnotDName       = libFun (fsLit "roleAnnotD")        roleAnnotDIdKey
 cxtName :: Name
 cxtName = libFun (fsLit "cxt") cxtIdKey
 
--- data Strict = ...
-isStrictName, notStrictName, unpackedName :: Name
-isStrictName      = libFun  (fsLit "isStrict")      isStrictKey
-notStrictName     = libFun  (fsLit "notStrict")     notStrictKey
-unpackedName      = libFun  (fsLit "unpacked")      unpackedKey
+-- data SourceUnpackedness = ...
+noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name
+noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey
+sourceNoUnpackName       = libFun (fsLit "sourceNoUnpack")       sourceNoUnpackKey
+sourceUnpackName         = libFun (fsLit "sourceUnpack")         sourceUnpackKey
+
+-- data SourceStrictness = ...
+noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name
+noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey
+sourceLazyName         = libFun (fsLit "sourceLazy")         sourceLazyKey
+sourceStrictName       = libFun (fsLit "sourceStrict")       sourceStrictKey
 
 -- data Con = ...
 normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name
@@ -364,13 +374,17 @@ forallCName  = libFun (fsLit "forallC" ) forallCIdKey
 gadtCName    = libFun (fsLit "gadtC"   ) gadtCIdKey
 recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey
 
--- type StrictType = ...
-strictTypeName :: Name
-strictTypeName    = libFun  (fsLit "strictType")    strictTKey
+-- data Bang = ...
+bangName :: Name
+bangName = libFun (fsLit "bang") bangIdKey
+
+-- type BangType = ...
+bangTypeName :: Name
+bangTypeName = libFun (fsLit "bangType") bangTKey
 
--- type VarStrictType = ...
-varStrictTypeName :: Name
-varStrictTypeName = libFun  (fsLit "varStrictType") varStrictTKey
+-- type VarBangType = ...
+varBangTypeName :: Name
+varBangTypeName = libFun (fsLit "varBangType") varBangTKey
 
 -- data Type = ...
 forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName,
@@ -479,8 +493,8 @@ typeAnnotationName   = libFun (fsLit "typeAnnotation")   typeAnnotationIdKey
 moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey
 
 matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
-    decQTyConName, conQTyConName, strictTypeQTyConName,
-    varStrictTypeQTyConName, typeQTyConName, fieldExpQTyConName,
+    decQTyConName, conQTyConName, bangTypeQTyConName,
+    varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,
     patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
     ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName :: Name
 matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey
@@ -490,8 +504,8 @@ stmtQTyConName          = libTc (fsLit "StmtQ")          stmtQTyConKey
 decQTyConName           = libTc (fsLit "DecQ")           decQTyConKey
 decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]
 conQTyConName           = libTc (fsLit "ConQ")           conQTyConKey
-strictTypeQTyConName    = libTc (fsLit "StrictTypeQ")    strictTypeQTyConKey
-varStrictTypeQTyConName = libTc (fsLit "VarStrictTypeQ") varStrictTypeQTyConKey
+bangTypeQTyConName      = libTc (fsLit "BangTypeQ")      bangTypeQTyConKey
+varBangTypeQTyConName   = libTc (fsLit "VarBangTypeQ")   varBangTypeQTyConKey
 typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey
 fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey
 patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey
@@ -550,7 +564,7 @@ liftClassKey = mkPreludeClassUnique 200
 expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
     decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
     stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey, tyVarBndrTyConKey,
-    decTyConKey, varStrictTypeQTyConKey, strictTypeQTyConKey,
+    decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
     fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
     fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
     predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
@@ -569,8 +583,8 @@ conQTyConKey            = mkPreludeTyConUnique 210
 typeQTyConKey           = mkPreludeTyConUnique 211
 typeTyConKey            = mkPreludeTyConUnique 212
 decTyConKey             = mkPreludeTyConUnique 213
-varStrictTypeQTyConKey  = mkPreludeTyConUnique 214
-strictTypeQTyConKey     = mkPreludeTyConUnique 215
+bangTypeQTyConKey       = mkPreludeTyConUnique 214
+varBangTypeQTyConKey    = mkPreludeTyConUnique 215
 fieldExpTyConKey        = mkPreludeTyConUnique 216
 fieldPatTyConKey        = mkPreludeTyConUnique 217
 nameTyConKey            = mkPreludeTyConUnique 218
@@ -796,11 +810,17 @@ defaultSigDIdKey       = mkPreludeMiscIdUnique 357
 cxtIdKey :: Unique
 cxtIdKey            = mkPreludeMiscIdUnique 360
 
--- data Strict = ...
-isStrictKey, notStrictKey, unpackedKey :: Unique
-isStrictKey         = mkPreludeMiscIdUnique 363
-notStrictKey        = mkPreludeMiscIdUnique 364
-unpackedKey         = mkPreludeMiscIdUnique 365
+-- data SourceUnpackedness = ...
+noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique
+noSourceUnpackednessKey = mkPreludeMiscIdUnique 361
+sourceNoUnpackKey       = mkPreludeMiscIdUnique 362
+sourceUnpackKey         = mkPreludeMiscIdUnique 363
+
+-- data SourceStrictness = ...
+noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique
+noSourceStrictnessKey   = mkPreludeMiscIdUnique 364
+sourceLazyKey           = mkPreludeMiscIdUnique 365
+sourceStrictKey         = mkPreludeMiscIdUnique 366
 
 -- data Con = ...
 normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,
@@ -812,13 +832,17 @@ forallCIdKey      = mkPreludeMiscIdUnique 373
 gadtCIdKey        = mkPreludeMiscIdUnique 374
 recGadtCIdKey     = mkPreludeMiscIdUnique 375
 
--- type StrictType = ...
-strictTKey :: Unique
-strictTKey        = mkPreludeMiscIdUnique 376
+-- data Bang = ...
+bangIdKey :: Unique
+bangIdKey         = mkPreludeMiscIdUnique 376
+
+-- type BangType = ...
+bangTKey :: Unique
+bangTKey          = mkPreludeMiscIdUnique 377
 
--- type VarStrictType = ...
-varStrictTKey :: Unique
-varStrictTKey     = mkPreludeMiscIdUnique 377
+-- type VarBangType = ...
+varBangTKey :: Unique
+varBangTKey       = mkPreludeMiscIdUnique 378
 
 -- data Type = ...
 forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey,
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 9cce515e8f..e3b4fa8c7e 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -815,6 +815,10 @@ instance TH.Quasi TcM where
   qReifyRoles       = reifyRoles
   qReifyAnnotations = reifyAnnotations
   qReifyModule      = reifyModule
+  qReifyConStrictness nm = do { nm' <- lookupThName nm
+                              ; dc  <- tcLookupDataCon nm'
+                              ; let bangs = dataConImplBangs dc
+                              ; return (map reifyDecidedStrictness bangs) }
 
         -- For qRecover, discard error messages if
         -- the recovery action is chosen.  Otherwise
@@ -1335,7 +1339,9 @@ reifyDataCon isGadtDataCon tys dc
              -- used for GADTs data constructors
              (g_univ_tvs, g_ex_tvs, g_eq_spec, g_theta, g_arg_tys, _)
                  = dataConFullSig dc
-             stricts   = map reifyStrict (dataConSrcBangs dc)
+             (srcUnpks, srcStricts)
+                 = mapAndUnzip reifySourceBang (dataConSrcBangs dc)
+             dcdBangs  = zipWith TH.Bang srcUnpks srcStricts
              fields    = dataConFieldLabels dc
              name      = reifyName dc
              r_ty_name = reifyName (dataConTyCon dc) -- return type for GADTs
@@ -1350,21 +1356,21 @@ reifyDataCon isGadtDataCon tys dc
 
        ; let main_con | not (null fields) && not isGadtDataCon
                       = TH.RecC name (zip3 (map reifyFieldLabel fields)
-                                      stricts r_arg_tys)
+                                      dcdBangs r_arg_tys)
                       | not (null fields)
                       = TH.RecGadtC [name]
                                    (zip3 (map (reifyName . flSelector) fields)
-                                    stricts r_arg_tys) r_ty_name idx_tys
+                                    dcdBangs r_arg_tys) r_ty_name idx_tys
                       | dataConIsInfix dc
                       = ASSERT( length arg_tys == 2 )
                         TH.InfixC (s1,r_a1) name (s2,r_a2)
                       | isGadtDataCon
-                      = TH.GadtC [name] (stricts `zip` r_arg_tys) r_ty_name
+                      = TH.GadtC [name] (dcdBangs `zip` r_arg_tys) r_ty_name
                                  idx_tys
                       | otherwise
-                      = TH.NormalC name (stricts `zip` r_arg_tys)
+                      = TH.NormalC name (dcdBangs `zip` r_arg_tys)
              [r_a1, r_a2] = r_arg_tys
-             [s1,   s2]   = stricts
+             [s1,   s2]   = dcdBangs
              (ex_tvs', theta') | isGadtDataCon = ( g_unsbst_univ_tvs ++ g_ex_tvs
                                                  , g_theta )
                                | otherwise     = ( ex_tvs, theta )
@@ -1373,7 +1379,7 @@ reifyDataCon isGadtDataCon tys dc
                          { cxt <- reifyCxt theta'
                          ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing
                          ; return (TH.ForallC ex_tvs'' cxt main_con) }
-       ; ASSERT( length arg_tys == length stricts )
+       ; ASSERT( length arg_tys == length dcdBangs )
          ret_con }
 
 -- Note [Reifying GADT data constructors]
@@ -1759,11 +1765,24 @@ reifyFixity name
       conv_dir BasicTypes.InfixL = TH.InfixL
       conv_dir BasicTypes.InfixN = TH.InfixN
 
-reifyStrict :: DataCon.HsSrcBang -> TH.Strict
-reifyStrict (HsSrcBang _ _         SrcLazy)     = TH.NotStrict
-reifyStrict (HsSrcBang _ _         NoSrcStrict) = TH.NotStrict
-reifyStrict (HsSrcBang _ SrcUnpack SrcStrict)   = TH.Unpacked
-reifyStrict (HsSrcBang _ _         SrcStrict)   = TH.IsStrict
+reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness
+reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness
+reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack
+reifyUnpackedness SrcUnpack   = TH.SourceUnpack
+
+reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness
+reifyStrictness NoSrcStrict = TH.NoSourceStrictness
+reifyStrictness SrcStrict   = TH.SourceStrict
+reifyStrictness SrcLazy     = TH.SourceLazy
+
+reifySourceBang :: DataCon.HsSrcBang
+                -> (TH.SourceUnpackedness, TH.SourceStrictness)
+reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)
+
+reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness
+reifyDecidedStrictness HsLazy     = TH.DecidedLazy
+reifyDecidedStrictness HsStrict   = TH.DecidedStrict
+reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack
 
 ------------------------------
 lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
diff --git a/docs/users_guide/7.12.1-notes.rst b/docs/users_guide/7.12.1-notes.rst
index 2437abf813..caa1d897a8 100644
--- a/docs/users_guide/7.12.1-notes.rst
+++ b/docs/users_guide/7.12.1-notes.rst
@@ -323,6 +323,9 @@ Template Haskell
    is enabled in the ``Q`` monad. Similarly, ``extsEnabled`` can be used to list
    all enabled language extensions.
 
+-  One can now reify the strictness information of a constructors' fields using
+   Template Haskell's ``reifyConStrictness`` function, which takes into account
+   whether flags such as `-XStrictData` or `-funbox-strict-fields` are enabled.
 
 Runtime system
 ~~~~~~~~~~~~~~
diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs
index 5406854f31..37c9f0c209 100644
--- a/libraries/ghci/GHCi/Message.hs
+++ b/libraries/ghci/GHCi/Message.hs
@@ -158,6 +158,7 @@ data Message a where
   ReifyRoles :: TH.Name -> Message (THResult [TH.Role])
   ReifyAnnotations :: TH.AnnLookup -> TypeRep -> Message (THResult [ByteString])
   ReifyModule :: TH.Module -> Message (THResult TH.ModuleInfo)
+  ReifyConStrictness :: TH.Name -> Message (THResult [TH.DecidedStrictness])
 
   AddDependentFile :: FilePath -> Message (THResult ())
   AddTopDecls :: [TH.Dec] -> Message (THResult ())
@@ -291,12 +292,13 @@ getMessage = do
       35 -> Msg <$> ReifyRoles <$> get
       36 -> Msg <$> (ReifyAnnotations <$> get <*> get)
       37 -> Msg <$> ReifyModule <$> get
-      38 -> Msg <$> AddDependentFile <$> get
-      39 -> Msg <$> AddTopDecls <$> get
-      40 -> Msg <$> (IsExtEnabled <$> get)
-      41 -> Msg <$> return ExtsEnabled
-      42 -> Msg <$> return QDone
-      43 -> Msg <$> QException <$> get
+      38 -> Msg <$> ReifyConStrictness <$> get
+      39 -> Msg <$> AddDependentFile <$> get
+      40 -> Msg <$> AddTopDecls <$> get
+      41 -> Msg <$> (IsExtEnabled <$> get)
+      42 -> Msg <$> return ExtsEnabled
+      43 -> Msg <$> return QDone
+      44 -> Msg <$> QException <$> get
       _  -> Msg <$> QFail <$> get
 
 putMessage :: Message a -> Put
@@ -339,13 +341,14 @@ putMessage m = case m of
   ReifyRoles a                -> putWord8 35 >> put a
   ReifyAnnotations a b        -> putWord8 36 >> put a >> put b
   ReifyModule a               -> putWord8 37 >> put a
-  AddDependentFile a          -> putWord8 38 >> put a
-  AddTopDecls a               -> putWord8 39 >> put a
-  IsExtEnabled a              -> putWord8 40 >> put a
-  ExtsEnabled                 -> putWord8 41
-  QDone                       -> putWord8 42
-  QException a                -> putWord8 43 >> put a
-  QFail a                     -> putWord8 44 >> put a
+  ReifyConStrictness a        -> putWord8 38 >> put a
+  AddDependentFile a          -> putWord8 39 >> put a
+  AddTopDecls a               -> putWord8 40 >> put a
+  IsExtEnabled a              -> putWord8 41 >> put a
+  ExtsEnabled                 -> putWord8 42
+  QDone                       -> putWord8 43
+  QException a                -> putWord8 44 >> put a
+  QFail a                     -> putWord8 45 >> put a
 
 -- -----------------------------------------------------------------------------
 -- Reading/writing messages
diff --git a/libraries/ghci/GHCi/TH.hs b/libraries/ghci/GHCi/TH.hs
index 0121da9426..f379dbc546 100644
--- a/libraries/ghci/GHCi/TH.hs
+++ b/libraries/ghci/GHCi/TH.hs
@@ -118,6 +118,7 @@ instance TH.Quasi GHCiQ where
     where typerep = typeOf (undefined :: a)
 
   qReifyModule m = ghcCmd (ReifyModule m)
+  qReifyConStrictness name = ghcCmd (ReifyConStrictness name)
   qLocation = fromMaybe noLoc . qsLocation <$> getState
   qRunIO m = GHCiQ $ \s -> fmap (,s) m
   qAddDependentFile file = ghcCmd (AddDependentFile file)
diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index 41187fdef9..6183a3d26f 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -45,7 +45,10 @@ instance Binary TH.Pragma
 instance Binary TH.Safety
 instance Binary TH.Callconv
 instance Binary TH.Foreign
-instance Binary TH.Strict
+instance Binary TH.Bang
+instance Binary TH.SourceUnpackedness
+instance Binary TH.SourceStrictness
+instance Binary TH.DecidedStrictness
 instance Binary TH.FixityDirection
 instance Binary TH.OccName
 instance Binary TH.Con
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 66d507cf9d..19882868b0 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -41,6 +41,8 @@ module Language.Haskell.TH(
         reifyRoles,
         -- *** Annotation lookup
         reifyAnnotations, AnnLookup(..),
+        -- *** Constructor strictness lookup
+        reifyConStrictness,
 
         -- * Typed expressions
         TExp, unType,
@@ -66,7 +68,8 @@ module Language.Haskell.TH(
 
     -- ** Declarations
         Dec(..), Con(..), Clause(..),
-        Strict(..), Foreign(..), Callconv(..), Safety(..), Pragma(..),
+        SourceUnpackedness(..), SourceStrictness(..), DecidedStrictness(..),
+        Bang(..), Strict, Foreign(..), Callconv(..), Safety(..), Pragma(..),
         Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),
         FunDep(..), FamFlavour(..), TySynEqn(..), TypeFamilyHead(..),
         Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,
@@ -80,9 +83,10 @@ module Language.Haskell.TH(
 
     -- * Library functions
     -- ** Abbreviations
-        InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, MatchQ, ClauseQ,
-        BodyQ, GuardQ, StmtQ, RangeQ, StrictTypeQ, VarStrictTypeQ, PatQ, FieldPatQ,
-        RuleBndrQ, TySynEqnQ,
+        InfoQ, ExpQ, DecQ, DecsQ, ConQ, TypeQ, TyLitQ, CxtQ, PredQ, MatchQ,
+        ClauseQ, BodyQ, GuardQ, StmtQ, RangeQ, SourceStrictnessQ,
+        SourceUnpackednessQ, BangTypeQ, VarBangTypeQ, StrictTypeQ,
+        VarStrictTypeQ, PatQ, FieldPatQ, RuleBndrQ, TySynEqnQ,
 
     -- ** Constructors lifted to 'Q'
     -- *** Literals
@@ -119,7 +123,9 @@ module Language.Haskell.TH(
     -- **** Type literals
     numTyLit, strTyLit,
     -- **** Strictness
-    isStrict, notStrict, strictType, varStrictType,
+    noSourceUnpackedness, sourceNoUnpack, sourceUnpack,
+    noSourceStrictness, sourceLazy, sourceStrict,
+    bang, bangType, varBangType, strictType, varStrictType,
     -- **** Class Contexts
     cxt, classP, equalP,
     -- **** Constructors
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 737b9d42c7..ef928e8a36 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -18,31 +18,38 @@ import Data.Word( Word8 )
 -- * Type synonyms
 ----------------------------------------------------------
 
-type InfoQ          = Q Info
-type PatQ           = Q Pat
-type FieldPatQ      = Q FieldPat
-type ExpQ           = Q Exp
-type TExpQ a        = Q (TExp a)
-type DecQ           = Q Dec
-type DecsQ          = Q [Dec]
-type ConQ           = Q Con
-type TypeQ          = Q Type
-type TyLitQ         = Q TyLit
-type CxtQ           = Q Cxt
-type PredQ          = Q Pred
-type MatchQ         = Q Match
-type ClauseQ        = Q Clause
-type BodyQ          = Q Body
-type GuardQ         = Q Guard
-type StmtQ          = Q Stmt
-type RangeQ         = Q Range
-type StrictTypeQ    = Q StrictType
-type VarStrictTypeQ = Q VarStrictType
-type FieldExpQ      = Q FieldExp
-type RuleBndrQ      = Q RuleBndr
-type TySynEqnQ      = Q TySynEqn
-type Role           = TH.Role       -- must be defined here for DsMeta to find it
-type InjectivityAnn = TH.InjectivityAnn
+type InfoQ               = Q Info
+type PatQ                = Q Pat
+type FieldPatQ           = Q FieldPat
+type ExpQ                = Q Exp
+type TExpQ a             = Q (TExp a)
+type DecQ                = Q Dec
+type DecsQ               = Q [Dec]
+type ConQ                = Q Con
+type TypeQ               = Q Type
+type TyLitQ              = Q TyLit
+type CxtQ                = Q Cxt
+type PredQ               = Q Pred
+type MatchQ              = Q Match
+type ClauseQ             = Q Clause
+type BodyQ               = Q Body
+type GuardQ              = Q Guard
+type StmtQ               = Q Stmt
+type RangeQ              = Q Range
+type SourceStrictnessQ   = Q SourceStrictness
+type SourceUnpackednessQ = Q SourceUnpackedness
+type BangQ               = Q Bang
+type BangTypeQ           = Q BangType
+type VarBangTypeQ        = Q VarBangType
+type StrictTypeQ         = Q StrictType
+type VarStrictTypeQ      = Q VarStrictType
+type FieldExpQ           = Q FieldExp
+type RuleBndrQ           = Q RuleBndr
+type TySynEqnQ           = Q TySynEqn
+
+-- must be defined here for DsMeta to find it
+type Role                = TH.Role
+type InjectivityAnn      = TH.InjectivityAnn
 
 ----------------------------------------------------------
 -- * Lowercase pattern syntax functions
@@ -529,13 +536,13 @@ tySynEqn lhs rhs =
 cxt :: [PredQ] -> CxtQ
 cxt = sequence
 
-normalC :: Name -> [StrictTypeQ] -> ConQ
+normalC :: Name -> [BangTypeQ] -> ConQ
 normalC con strtys = liftM (NormalC con) $ sequence strtys
 
-recC :: Name -> [VarStrictTypeQ] -> ConQ
+recC :: Name -> [VarBangTypeQ] -> ConQ
 recC con varstrtys = liftM (RecC con) $ sequence varstrtys
 
-infixC :: Q (Strict, Type) -> Name -> Q (Strict, Type) -> ConQ
+infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ
 infixC st1 con st2 = do st1' <- st1
                         st2' <- st2
                         return $ InfixC st1' con st2'
@@ -644,17 +651,37 @@ promotedNilT = return PromotedNilT
 promotedConsT :: TypeQ
 promotedConsT = return PromotedConsT
 
-isStrict, notStrict, unpacked :: Q Strict
-isStrict = return $ IsStrict
-notStrict = return $ NotStrict
-unpacked = return Unpacked
+noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ
+noSourceUnpackedness = return NoSourceUnpackedness
+sourceNoUnpack       = return SourceNoUnpack
+sourceUnpack         = return SourceUnpack
 
+noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ
+noSourceStrictness = return NoSourceStrictness
+sourceLazy         = return SourceLazy
+sourceStrict       = return SourceStrict
+
+bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
+bang u s = do u' <- u
+              s' <- s
+              return (Bang u' s')
+
+bangType :: BangQ -> TypeQ -> BangTypeQ
+bangType = liftM2 (,)
+
+varBangType :: Name -> BangTypeQ -> VarBangTypeQ
+varBangType v bt = do (b, t) <- bt
+                      return (v, b, t)
+
+{-# DEPRECATED strictType
+               "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-}
 strictType :: Q Strict -> TypeQ -> StrictTypeQ
-strictType = liftM2 (,)
+strictType = bangType
 
+{-# DEPRECATED varStrictType
+               "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-}
 varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ
-varStrictType v st = do (s, t) <- st
-                        return (v, s, t)
+varStrictType = varBangType
 
 -- * Type Literals
 
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index bf240f4ec5..d02ad0a30a 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -497,14 +497,14 @@ instance Ppr Clause where
 
 ------------------------------
 instance Ppr Con where
-    ppr (NormalC c sts) = ppr c <+> sep (map pprStrictType sts)
+    ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts)
 
     ppr (RecC c vsts)
-        = ppr c <+> braces (sep (punctuate comma $ map pprVarStrictType vsts))
+        = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))
 
-    ppr (InfixC st1 c st2) = pprStrictType st1
+    ppr (InfixC st1 c st2) = pprBangType st1
                          <+> pprName' Infix c
-                         <+> pprStrictType st2
+                         <+> pprBangType st2
 
     ppr (ForallC ns ctxt (GadtC c sts ty idx))
         = commaSep c <+> dcolon <+> pprForall ns ctxt <+> pprGadtRHS sts ty idx
@@ -529,27 +529,69 @@ pprForall ns ctxt
 
 pprRecFields :: [(Name, Strict, Type)] -> Name -> [Type] -> Doc
 pprRecFields vsts ty idx
-    = braces (sep (punctuate comma $ map pprVarStrictType vsts))
+    = braces (sep (punctuate comma $ map pprVarBangType vsts))
   <+> arrow <+> ppr ty <+> sep (map ppr idx)
 
 pprGadtRHS :: [(Strict, Type)] -> Name -> [Type] -> Doc
 pprGadtRHS [] ty idx
     = ppr ty <+> sep (map ppr idx)
 pprGadtRHS sts ty idx
-    = sep (punctuate (space <> arrow) (map pprStrictType sts))
+    = sep (punctuate (space <> arrow) (map pprBangType sts))
   <+> arrow <+> ppr ty <+> sep (map ppr idx)
 
 ------------------------------
-pprVarStrictType :: (Name, Strict, Type) -> Doc
+pprVarBangType :: VarBangType -> Doc
 -- Slight infelicity: with print non-atomic type with parens
-pprVarStrictType (v, str, t) = ppr v <+> dcolon <+> pprStrictType (str, t)
+pprVarBangType (v, bang, t) = ppr v <+> dcolon <+> pprBangType (bang, t)
+
+------------------------------
+pprBangType :: BangType -> Doc
+-- Make sure we print
+--
+-- Con {-# UNPACK #-} a
+--
+-- rather than
+--
+-- Con {-# UNPACK #-}a
+--
+-- when there's no strictness annotation. If there is a strictness annotation,
+-- it's okay to not put a space between it and the type.
+pprBangType (bt@(Bang _ NoSourceStrictness), t) = ppr bt <+> pprParendType t
+pprBangType (bt, t) = ppr bt <> pprParendType t
+
+------------------------------
+instance Ppr Bang where
+    ppr (Bang su ss) = ppr su <+> ppr ss
+
+------------------------------
+instance Ppr SourceUnpackedness where
+    ppr NoSourceUnpackedness = empty
+    ppr SourceNoUnpack       = text "{-# NOUNPACK #-}"
+    ppr SourceUnpack         = text "{-# UNPACK #-}"
+
+------------------------------
+instance Ppr SourceStrictness where
+    ppr NoSourceStrictness = empty
+    ppr SourceLazy         = char '~'
+    ppr SourceStrict       = char '!'
+
+------------------------------
+instance Ppr DecidedStrictness where
+    ppr DecidedLazy   = empty
+    ppr DecidedStrict = char '!'
+    ppr DecidedUnpack = text "{-# UNPACK #-} !"
+
+------------------------------
+{-# DEPRECATED pprVarStrictType
+               "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'pprVarBangType' instead." #-}
+pprVarStrictType :: (Name, Strict, Type) -> Doc
+pprVarStrictType = pprVarBangType
 
 ------------------------------
+{-# DEPRECATED pprStrictType
+               "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'pprBangType' instead." #-}
 pprStrictType :: (Strict, Type) -> Doc
--- Prints with parens if not already atomic
-pprStrictType (IsStrict, t) = char '!' <> pprParendType t
-pprStrictType (NotStrict, t) = pprParendType t
-pprStrictType (Unpacked, t) = text "{-# UNPACK #-} !" <> pprParendType t
+pprStrictType = pprBangType
 
 ------------------------------
 pprParendType :: Type -> Doc
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index b333b006b6..d10fb3c0a5 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -76,9 +76,10 @@ class (Applicative m, Monad m) => Quasi m where
        -- Returns list of matching instance Decs
        --    (with empty sub-Decs)
        -- Works for classes and type functions
-  qReifyRoles       :: Name -> m [Role]
-  qReifyAnnotations :: Data a => AnnLookup -> m [a]
-  qReifyModule      :: Module -> m ModuleInfo
+  qReifyRoles         :: Name -> m [Role]
+  qReifyAnnotations   :: Data a => AnnLookup -> m [a]
+  qReifyModule        :: Module -> m ModuleInfo
+  qReifyConStrictness :: Name -> m [DecidedStrictness]
 
   qLocation :: m Loc
 
@@ -117,22 +118,23 @@ instance Quasi IO where
   qReport True  msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
   qReport False msg = hPutStrLn stderr ("Template Haskell error: " ++ msg)
 
-  qLookupName _ _     = badIO "lookupName"
-  qReify _            = badIO "reify"
-  qReifyFixity _      = badIO "reifyFixity"
-  qReifyInstances _ _ = badIO "reifyInstances"
-  qReifyRoles _       = badIO "reifyRoles"
-  qReifyAnnotations _ = badIO "reifyAnnotations"
-  qReifyModule _      = badIO "reifyModule"
-  qLocation           = badIO "currentLocation"
-  qRecover _ _        = badIO "recover" -- Maybe we could fix this?
-  qAddDependentFile _ = badIO "addDependentFile"
-  qAddTopDecls _      = badIO "addTopDecls"
-  qAddModFinalizer _  = badIO "addModFinalizer"
-  qGetQ               = badIO "getQ"
-  qPutQ _             = badIO "putQ"
-  qIsExtEnabled _     = badIO "isExtEnabled"
-  qExtsEnabled        = badIO "extsEnabled"
+  qLookupName _ _       = badIO "lookupName"
+  qReify _              = badIO "reify"
+  qReifyFixity _        = badIO "reifyFixity"
+  qReifyInstances _ _   = badIO "reifyInstances"
+  qReifyRoles _         = badIO "reifyRoles"
+  qReifyAnnotations _   = badIO "reifyAnnotations"
+  qReifyModule _        = badIO "reifyModule"
+  qReifyConStrictness _ = badIO "reifyConStrictness"
+  qLocation             = badIO "currentLocation"
+  qRecover _ _          = badIO "recover" -- Maybe we could fix this?
+  qAddDependentFile _   = badIO "addDependentFile"
+  qAddTopDecls _        = badIO "addTopDecls"
+  qAddModFinalizer _    = badIO "addModFinalizer"
+  qGetQ                 = badIO "getQ"
+  qPutQ _               = badIO "putQ"
+  qIsExtEnabled _       = badIO "isExtEnabled"
+  qExtsEnabled          = badIO "extsEnabled"
 
   qRunIO m = m
 
@@ -391,6 +393,21 @@ reifyAnnotations an = Q (qReifyAnnotations an)
 reifyModule :: Module -> Q ModuleInfo
 reifyModule m = Q (qReifyModule m)
 
+-- | @reifyConStrictness nm@ looks up the strictness information for the fields
+-- of the constructor with the name @nm@. Note that the strictness information
+-- that 'reifyConStrictness' returns may not correspond to what is written in
+-- the source code. For example, in the following data declaration:
+--
+-- @
+-- data Pair a = Pair a a
+-- @
+--
+-- 'reifyConStrictness' would return @['DecidedLazy', DecidedLazy]@ under most
+-- circumstances, but it would return @['DecidedStrict', DecidedStrict]@ if the
+-- @-XStrictData@ language extension was enabled.
+reifyConStrictness :: Name -> Q [DecidedStrictness]
+reifyConStrictness n = Q (qReifyConStrictness n)
+
 -- | Is the list of instances returned by 'reifyInstances' nonempty?
 isInstance :: Name -> [Type] -> Q Bool
 isInstance nm tys = do { decs <- reifyInstances nm tys
@@ -451,25 +468,26 @@ extsEnabled :: Q [Extension]
 extsEnabled = Q qExtsEnabled
 
 instance Quasi Q where
-  qNewName          = newName
-  qReport           = report
-  qRecover          = recover
-  qReify            = reify
-  qReifyFixity      = reifyFixity
-  qReifyInstances   = reifyInstances
-  qReifyRoles       = reifyRoles
-  qReifyAnnotations = reifyAnnotations
-  qReifyModule      = reifyModule
-  qLookupName       = lookupName
-  qLocation         = location
-  qRunIO            = runIO
-  qAddDependentFile = addDependentFile
-  qAddTopDecls      = addTopDecls
-  qAddModFinalizer  = addModFinalizer
-  qGetQ             = getQ
-  qPutQ             = putQ
-  qIsExtEnabled     = isExtEnabled
-  qExtsEnabled      = extsEnabled
+  qNewName            = newName
+  qReport             = report
+  qRecover            = recover
+  qReify              = reify
+  qReifyFixity        = reifyFixity
+  qReifyInstances     = reifyInstances
+  qReifyRoles         = reifyRoles
+  qReifyAnnotations   = reifyAnnotations
+  qReifyModule        = reifyModule
+  qReifyConStrictness = reifyConStrictness
+  qLookupName         = lookupName
+  qLocation           = location
+  qRunIO              = runIO
+  qAddDependentFile   = addDependentFile
+  qAddTopDecls        = addTopDecls
+  qAddModFinalizer    = addModFinalizer
+  qGetQ               = getQ
+  qPutQ               = putQ
+  qIsExtEnabled       = isExtEnabled
+  qExtsEnabled        = extsEnabled
 
 
 ----------------------------------------------------
@@ -1593,22 +1611,39 @@ type Cxt = [Pred]                 -- ^ @(Eq a, Ord b)@
 -- be tuples of other constraints.
 type Pred = Type
 
-data Strict = IsStrict | NotStrict | Unpacked
-         deriving( Show, Eq, Ord, Data, Typeable, Generic )
-
-data Con = NormalC Name [StrictType]         -- ^ @C Int a@
-         | RecC Name [VarStrictType]         -- ^ @C { v :: Int, w :: a }@
-         | InfixC StrictType Name StrictType -- ^ @Int :+ a@
-         | ForallC [TyVarBndr] Cxt Con       -- ^ @forall a. Eq a => C [a]@
-         | GadtC [Name] [StrictType]
-                 Name                        -- See Note [GADT return type]
-                 [Type]                      -- Indices of the type constructor
-                                             -- ^ @C :: a -> b -> T b Int@
-         | RecGadtC [Name] [VarStrictType]
-                    Name                     -- See Note [GADT return type]
-                    [Type]                   -- Indices of the type constructor
-                                             -- ^ @C :: { v :: Int } -> T b Int@
-         deriving( Show, Eq, Ord, Data, Typeable, Generic )
+data SourceUnpackedness
+  = NoSourceUnpackedness -- ^ @C a@
+  | SourceNoUnpack       -- ^ @C { {\-\# NOUNPACK \#-\} } a@
+  | SourceUnpack         -- ^ @C { {\-\# UNPACK \#-\} } a@
+        deriving (Show, Eq, Ord, Data, Typeable, Generic)
+
+data SourceStrictness = NoSourceStrictness    -- ^ @C a@
+                      | SourceLazy            -- ^ @C {~}a@
+                      | SourceStrict          -- ^ @C {!}a@
+        deriving (Show, Eq, Ord, Data, Typeable, Generic)
+
+-- | Unlike 'SourceStrictness' and 'SourceUnpackedness', 'DecidedStrictness'
+-- refers to the strictness that the compiler chooses for a data constructor
+-- field, which may be different from what is written in source code. See
+-- 'reifyConStrictness' for more information.
+data DecidedStrictness = DecidedLazy
+                       | DecidedStrict
+                       | DecidedUnpack
+        deriving (Show, Eq, Ord, Data, Typeable, Generic)
+
+data Con = NormalC Name [BangType]       -- ^ @C Int a@
+         | RecC Name [VarBangType]       -- ^ @C { v :: Int, w :: a }@
+         | InfixC BangType Name BangType -- ^ @Int :+ a@
+         | ForallC [TyVarBndr] Cxt Con   -- ^ @forall a. Eq a => C [a]@
+         | GadtC [Name] [BangType]
+                 Name                    -- See Note [GADT return type]
+                 [Type]                  -- Indices of the type constructor
+                                         -- ^ @C :: a -> b -> T b Int@
+         | RecGadtC [Name] [VarBangType]
+                    Name                 -- See Note [GADT return type]
+                    [Type]               -- Indices of the type constructor
+                                         -- ^ @C :: { v :: Int } -> T b Int@
+        deriving (Show, Eq, Ord, Data, Typeable, Generic)
 
 -- Note [GADT return type]
 -- ~~~~~~~~~~~~~~~~~~~~~~~
@@ -1621,8 +1656,23 @@ data Con = NormalC Name [StrictType]         -- ^ @C Int a@
 -- data T a where
 --     MkT :: S Int
 
-type StrictType = (Strict, Type)
-type VarStrictType = (Name, Strict, Type)
+data Bang = Bang SourceUnpackedness SourceStrictness
+         -- ^ @C { {\-\# UNPACK \#-\} !}a@
+        deriving (Show, Eq, Ord, Data, Typeable, Generic)
+
+type BangType    = (Bang, Type)
+type VarBangType = (Name, Bang, Type)
+
+-- | As of @template-haskell-2.11.0.0@, 'Strict' has been replaced by 'Bang'.
+type Strict      = Bang
+
+-- | As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by
+-- 'BangType'.
+type StrictType    = BangType
+
+-- | As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by
+-- 'VarBangType'.
+type VarStrictType = VarBangType
 
 data Type = ForallT [TyVarBndr] Cxt Type  -- ^ @forall \<vars\>. \<ctxt\> -> \<type\>@
           | AppT Type Type                -- ^ @T a b@
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 33419b34ec..9564e95678 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -25,6 +25,18 @@
   * Add `TypeFamilyHead` for common elements of `OpenTypeFamilyD` and
     `ClosedTypeFamilyD` (#10902)
 
+  * The `Strict` datatype was split among different datatypes: three for
+    writing the strictness information of data constructors' fields as denoted
+    in Haskell source code (`SourceUnpackedness` and `SourceStrictness`, as
+    well as `Bang`), and one for strictness information after a constructor is
+    compiled (`DecidedStrictness`). `Strict`, `StrictType` and `VarStrictType`
+    have been deprecated in favor of `Bang`, `BangType` and `VarBangType`, and
+    three functions (`isStrict`, `isLazy`, and `unpack`) were removed because
+    they no longer serve any use in this new design. (#10697)
+
+  * Add `reifyConStrictness` to query a data constructor's `DecidedStrictness`
+    values for its fields (#10697)
+
   * TODO: document API changes and important bugfixes
 
 
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs
index e97fdcea9a..d3c85ba9ec 100644
--- a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs
@@ -7,7 +7,10 @@ import Language.Haskell.TH.Syntax
 
 -- Splice in a datatype with field...
 $(return [DataD [] (mkName "R") [] Nothing
-          [RecC (mkName "MkR") [(mkName "foo", NotStrict, ConT ''Int)]] []])
+  [RecC (mkName "MkR") [( mkName "foo"
+                        , Bang NoSourceUnpackedness NoSourceStrictness
+                        , ConT ''Int
+                        )]] []])
 
 -- New TH story means reify only sees R if we do this:
 $(return [])
diff --git a/testsuite/tests/rts/T7919A.hs b/testsuite/tests/rts/T7919A.hs
index 4dc013aeff..ddbdb04750 100644
--- a/testsuite/tests/rts/T7919A.hs
+++ b/testsuite/tests/rts/T7919A.hs
@@ -20,7 +20,9 @@ largeData =
     (dataName)
     []
     Nothing
-    [normalC dataName (replicate size (((,) <$> notStrict) `ap` [t| Int |]))]
+    [normalC dataName
+             (replicate size (((,) <$> bang noSourceUnpackedness
+                                       noSourceStrictness) `ap` [t| Int |]))]
     (cxt [])
 
 conE' :: Name -> [ExpQ] -> ExpQ
diff --git a/testsuite/tests/th/T10697_decided_1.hs b/testsuite/tests/th/T10697_decided_1.hs
new file mode 100644
index 0000000000..241cec3d38
--- /dev/null
+++ b/testsuite/tests/th/T10697_decided_1.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Language.Haskell.TH
+
+data T = T {-# UNPACK #-} !Int !Int Int
+
+$(return [])
+
+main :: IO ()
+main = putStrLn $(reifyConStrictness 'T >>= stringE . show)
diff --git a/testsuite/tests/th/T10697_decided_1.stdout b/testsuite/tests/th/T10697_decided_1.stdout
new file mode 100644
index 0000000000..b0dd4a284a
--- /dev/null
+++ b/testsuite/tests/th/T10697_decided_1.stdout
@@ -0,0 +1 @@
+[DecidedStrict,DecidedStrict,DecidedLazy]
diff --git a/testsuite/tests/th/T10697_decided_2.hs b/testsuite/tests/th/T10697_decided_2.hs
new file mode 100644
index 0000000000..241cec3d38
--- /dev/null
+++ b/testsuite/tests/th/T10697_decided_2.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Language.Haskell.TH
+
+data T = T {-# UNPACK #-} !Int !Int Int
+
+$(return [])
+
+main :: IO ()
+main = putStrLn $(reifyConStrictness 'T >>= stringE . show)
diff --git a/testsuite/tests/th/T10697_decided_2.stdout b/testsuite/tests/th/T10697_decided_2.stdout
new file mode 100644
index 0000000000..c4cfc4ab79
--- /dev/null
+++ b/testsuite/tests/th/T10697_decided_2.stdout
@@ -0,0 +1 @@
+[DecidedStrict,DecidedStrict,DecidedStrict]
diff --git a/testsuite/tests/th/T10697_decided_3.hs b/testsuite/tests/th/T10697_decided_3.hs
new file mode 100644
index 0000000000..241cec3d38
--- /dev/null
+++ b/testsuite/tests/th/T10697_decided_3.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Language.Haskell.TH
+
+data T = T {-# UNPACK #-} !Int !Int Int
+
+$(return [])
+
+main :: IO ()
+main = putStrLn $(reifyConStrictness 'T >>= stringE . show)
diff --git a/testsuite/tests/th/T10697_decided_3.stdout b/testsuite/tests/th/T10697_decided_3.stdout
new file mode 100644
index 0000000000..ae59571a61
--- /dev/null
+++ b/testsuite/tests/th/T10697_decided_3.stdout
@@ -0,0 +1 @@
+[DecidedUnpack,DecidedUnpack,DecidedUnpack]
diff --git a/testsuite/tests/th/T10697_source.hs b/testsuite/tests/th/T10697_source.hs
new file mode 100644
index 0000000000..4dfa410168
--- /dev/null
+++ b/testsuite/tests/th/T10697_source.hs
@@ -0,0 +1,57 @@
+{-# LANGUAGE StrictData, TemplateHaskell #-}
+module Main where
+
+import Language.Haskell.TH
+import T10697_sourceUtil
+
+$([d|data A1 = A1                   Int {- No unpackedness, no strictness -}|])
+$([d|data A2 = A2                  !Int {- No unpackedness, strict        -}|])
+$([d|data A3 = A3                  ~Int {- No unpackedness, lazy          -}|])
+$([d|data A4 = A4 {-# NOUNPACK #-}  Int {- NOUNPACK, no strictness        -}|])
+$([d|data A5 = A5 {-# NOUNPACK #-} !Int {- NOUNPACK, strict               -}|])
+$([d|data A6 = A6 {-# NOUNPACK #-} ~Int {- NOUNPACK, lazy                 -}|])
+$([d|data A7 = A7 {-#   UNPACK #-}  Int {- UNPACK, no strictness          -}|])
+$([d|data A8 = A8 {-#   UNPACK #-} !Int {- UNPACK, strict                 -}|])
+$([d|data A9 = A9 {-#   UNPACK #-} ~Int {- UNPACK, lazy                   -}|])
+
+$(do b1 <- newName "B1"
+     b2 <- newName "B2"
+     b3 <- newName "B3"
+     b4 <- newName "B4"
+     b5 <- newName "B5"
+     b6 <- newName "B6"
+     b7 <- newName "B7"
+     b8 <- newName "B8"
+     b9 <- newName "B9"
+     c1 <- newName "C1"
+     c2 <- newName "C2"
+     c3 <- newName "C3"
+     c4 <- newName "C4"
+     c5 <- newName "C5"
+     c6 <- newName "C6"
+     c7 <- newName "C7"
+     c8 <- newName "C8"
+     c9 <- newName "C9"
+
+     d1 <- makeSimpleDatatype b1 c1 noSourceUnpackedness noSourceStrictness
+     d2 <- makeSimpleDatatype b2 c2 noSourceUnpackedness sourceStrict
+     d3 <- makeSimpleDatatype b3 c3 noSourceUnpackedness sourceLazy
+     d4 <- makeSimpleDatatype b4 c4 sourceNoUnpack       noSourceStrictness
+     d5 <- makeSimpleDatatype b5 c5 sourceNoUnpack       sourceStrict
+     d6 <- makeSimpleDatatype b6 c6 sourceNoUnpack       sourceLazy
+     d7 <- makeSimpleDatatype b7 c7 sourceUnpack         noSourceStrictness
+     d8 <- makeSimpleDatatype b8 c8 sourceUnpack         sourceStrict
+     d9 <- makeSimpleDatatype b9 c9 sourceUnpack         sourceLazy
+     return [d1, d2, d3, d4, d5, d6, d7, d8, d9])
+
+main :: IO ()
+main = mapM_ print [ $(checkBang ''E1 noSourceUnpackedness noSourceStrictness)
+                   , $(checkBang ''E2 noSourceUnpackedness sourceStrict)
+                   , $(checkBang ''E3 noSourceUnpackedness sourceLazy)
+                   , $(checkBang ''E4 sourceNoUnpack       noSourceStrictness)
+                   , $(checkBang ''E5 sourceNoUnpack       sourceStrict)
+                   , $(checkBang ''E6 sourceNoUnpack       sourceLazy)
+                   , $(checkBang ''E7 sourceUnpack         noSourceStrictness)
+                   , $(checkBang ''E8 sourceUnpack         sourceStrict)
+                   , $(checkBang ''E9 sourceUnpack         sourceLazy)
+                   ]
diff --git a/testsuite/tests/th/T10697_source.stdout b/testsuite/tests/th/T10697_source.stdout
new file mode 100644
index 0000000000..c4dc445159
--- /dev/null
+++ b/testsuite/tests/th/T10697_source.stdout
@@ -0,0 +1,9 @@
+True
+True
+True
+True
+True
+True
+True
+True
+True
diff --git a/testsuite/tests/th/T10697_sourceUtil.hs b/testsuite/tests/th/T10697_sourceUtil.hs
new file mode 100644
index 0000000000..048a422b99
--- /dev/null
+++ b/testsuite/tests/th/T10697_sourceUtil.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE StrictData, TemplateHaskell #-}
+module T10697_sourceUtil where
+
+import Language.Haskell.TH
+
+makeSimpleDatatype :: Name
+                   -> Name
+                   -> SourceUnpackednessQ
+                   -> SourceStrictnessQ
+                   -> Q Dec
+makeSimpleDatatype tyName conName srcUpk srcStr =
+  dataD (cxt []) tyName [] Nothing [normalC conName
+    [bangType (bang srcUpk srcStr) (conT ''Int)]] (cxt [])
+
+checkBang :: Name
+          -> SourceUnpackednessQ
+          -> SourceStrictnessQ
+          -> ExpQ
+checkBang n srcUpk1 srcStr1 = do
+  TyConI (DataD _ _ _ _ [NormalC _ [(Bang srcUpk2 srcStr2, _)]] _) <- reify n
+  srcUpk1' <- srcUpk1
+  srcStr1' <- srcStr1
+  if srcUpk1' == srcUpk2 && srcStr1' == srcStr2
+    then [| True |]
+    else [| False |]
+
+data E1 = E1                   Int -- No unpackedness, no strictness
+data E2 = E2                  !Int -- No unpackedness, strict
+data E3 = E3                  ~Int -- No unpackedness, lazy
+data E4 = E4 {-# NOUNPACK #-}  Int -- NOUNPACK, no strictness
+data E5 = E5 {-# NOUNPACK #-} !Int -- NOUNPACK, strict
+data E6 = E6 {-# NOUNPACK #-} ~Int -- NOUNPACK, lazy
+data E7 = E7 {-#   UNPACK #-}  Int -- UNPACK, no strictness
+data E8 = E8 {-#   UNPACK #-} !Int -- UNPACK, strict
+data E9 = E9 {-#   UNPACK #-} ~Int -- UNPACK, lazy
diff --git a/testsuite/tests/th/T10819_Lib.hs b/testsuite/tests/th/T10819_Lib.hs
index 94f352efe7..2be00b4a51 100644
--- a/testsuite/tests/th/T10819_Lib.hs
+++ b/testsuite/tests/th/T10819_Lib.hs
@@ -2,6 +2,6 @@ module T10819_Lib where
 
 import Language.Haskell.TH.Syntax
 
-doSomeTH s tp drv = return [NewtypeD [] n [] Nothing
-                            (NormalC n [(NotStrict, ConT tp)]) drv]
+doSomeTH s tp drv = return [NewtypeD [] n [] Nothing (NormalC n
+    [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) drv]
   where n = mkName s
diff --git a/testsuite/tests/th/T10828.hs b/testsuite/tests/th/T10828.hs
index f01c5b9769..75b852ff07 100644
--- a/testsuite/tests/th/T10828.hs
+++ b/testsuite/tests/th/T10828.hs
@@ -33,16 +33,28 @@ $( return
            [ PlainTV (mkName "a") ]
            (Just StarT)
            [ GadtC [(mkName "MkT")]
-                   [ (NotStrict, VarT (mkName "a"))
-                   , (NotStrict, VarT (mkName "a"))]
+                   [ ( Bang NoSourceUnpackedness NoSourceStrictness
+                     , VarT (mkName "a")
+                     )
+                   , ( Bang NoSourceUnpackedness NoSourceStrictness
+                     , VarT (mkName "a")
+                     )
+                   ]
                    ( mkName "T" )
                    [ VarT (mkName "a") ]
            , ForallC [PlainTV (mkName "a"), PlainTV (mkName "b")]
                      [AppT (AppT EqualityT (VarT $ mkName "a"  ) )
                                            (ConT $ mkName "Int") ] $
              RecGadtC [(mkName "MkC")]
-                  [ (mkName "foo", NotStrict, VarT (mkName "a"))
-                  , (mkName "bar", NotStrict, VarT (mkName "b"))]
+                  [ ( mkName "foo"
+                    , Bang NoSourceUnpackedness NoSourceStrictness
+                    , VarT (mkName "a")
+                    )
+                  , ( mkName "bar"
+                    , Bang NoSourceUnpackedness NoSourceStrictness
+                    , VarT (mkName "b")
+                    )
+                  ]
                   ( mkName "T" )
                   [ ConT (mkName "Int") ] ]
            [] ])
diff --git a/testsuite/tests/th/T10828a.hs b/testsuite/tests/th/T10828a.hs
index 8bf13cfb04..c3108c3e38 100644
--- a/testsuite/tests/th/T10828a.hs
+++ b/testsuite/tests/th/T10828a.hs
@@ -11,7 +11,12 @@ $( return
            [ PlainTV (mkName "a") ]
            (Just StarT)
            [ NormalC (mkName "MkT")
-                   [ (NotStrict, VarT (mkName "a"))
-                   , (NotStrict, VarT (mkName "a"))]
+                   [ ( Bang NoSourceUnpackedness NoSourceStrictness
+                     , VarT (mkName "a")
+                     )
+                   , ( Bang NoSourceUnpackedness NoSourceStrictness
+                     , VarT (mkName "a")
+                     )
+                   ]
            ]
            [] ])
diff --git a/testsuite/tests/th/T10828b.hs b/testsuite/tests/th/T10828b.hs
index 55d8889009..ac4f6a28e5 100644
--- a/testsuite/tests/th/T10828b.hs
+++ b/testsuite/tests/th/T10828b.hs
@@ -10,16 +10,30 @@ $( return
    [ DataD [] (mkName "T")
            [ PlainTV (mkName "a") ]
            (Just StarT)
-           [ NormalC (mkName "MkT")
-                   [ (NotStrict, VarT (mkName "a"))
-                   , (NotStrict, VarT (mkName "a"))]
+           [ NormalC
+               (mkName "MkT")
+               [ ( Bang NoSourceUnpackedness NoSourceStrictness
+                 , VarT (mkName "a")
+                 )
+               , ( Bang NoSourceUnpackedness NoSourceStrictness
+                 , VarT (mkName "a")
+                 )
+               ]
            , ForallC [PlainTV (mkName "a")]
                      [AppT (AppT EqualityT (VarT $ mkName "a"  ) )
                                            (ConT $ mkName "Int") ] $
-             RecGadtC [(mkName "MkC")]
-                  [ (mkName "foo", NotStrict, VarT (mkName "a"))
-                  , (mkName "bar", NotStrict, VarT (mkName "b"))]
-                  ( mkName "T" )
-                  [ ConT (mkName "Int") ]
+             RecGadtC
+                 [ (mkName "MkC")]
+                 [ ( mkName "foo"
+                   , Bang NoSourceUnpackedness NoSourceStrictness
+                   , VarT (mkName "a")
+                   )
+                 , ( mkName "bar"
+                   , Bang NoSourceUnpackedness NoSourceStrictness
+                   , VarT (mkName "b")
+                   )
+                 ]
+                 ( mkName "T" )
+                 [ ConT (mkName "Int") ]
            ]
            [] ])
diff --git a/testsuite/tests/th/T5290.hs b/testsuite/tests/th/T5290.hs
index 50ad2d500c..2215ef1075 100644
--- a/testsuite/tests/th/T5290.hs
+++ b/testsuite/tests/th/T5290.hs
@@ -5,4 +5,5 @@ module T5290 where
 import Language.Haskell.TH
 
 $( let n = mkName "T"
-   in return [DataD [] n [] Nothing [NormalC n [(Unpacked,ConT ''Int)]] []] )
+   in return [DataD [] n [] Nothing
+                [NormalC n [(Bang SourceUnpack SourceStrict,ConT ''Int)]] []] )
diff --git a/testsuite/tests/th/T5290.stderr b/testsuite/tests/th/T5290.stderr
index d6996d0799..19c962a9a0 100644
--- a/testsuite/tests/th/T5290.stderr
+++ b/testsuite/tests/th/T5290.stderr
@@ -1,7 +1,13 @@
-T5290.hs:(7,4)-(8,75): Splicing declarations
+T5290.hs:(7,4)-(9,77): Splicing declarations
     let n = mkName "T"
     in
       return
-        [DataD [] n [] Nothing [NormalC n [(Unpacked, ConT ''Int)]] []]
+        [DataD
+           []
+           n
+           []
+           Nothing
+           [NormalC n [(Bang SourceUnpack SourceStrict, ConT ''Int)]]
+           []]
   ======>
     data T = T {-# UNPACK #-} !Int
diff --git a/testsuite/tests/th/T5665a.hs b/testsuite/tests/th/T5665a.hs
index b34131e974..2b558271b3 100644
--- a/testsuite/tests/th/T5665a.hs
+++ b/testsuite/tests/th/T5665a.hs
@@ -2,6 +2,6 @@ module T5665a where
 
 import Language.Haskell.TH
 
-doSomeTH s tp = return [NewtypeD [] n [] Nothing
-                        (NormalC n [(NotStrict, ConT tp)]) []]
+doSomeTH s tp = return [NewtypeD [] n [] Nothing (NormalC n
+        [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) []]
    where n = mkName s
diff --git a/testsuite/tests/th/T5984_Lib.hs b/testsuite/tests/th/T5984_Lib.hs
index a929086dd2..d8913cd8f3 100644
--- a/testsuite/tests/th/T5984_Lib.hs
+++ b/testsuite/tests/th/T5984_Lib.hs
@@ -5,10 +5,11 @@ module T5984_Lib where
 import Language.Haskell.TH
 
 nt :: Q [Dec]
-nt = return [NewtypeD [] foo [] Nothing
-             (NormalC foo [(NotStrict, ConT ''Int)]) []]
+nt = return [NewtypeD [] foo [] Nothing (NormalC foo
+      [(Bang NoSourceUnpackedness NoSourceStrictness, ConT ''Int)]) []]
   where foo = mkName "Foo"
 
 dt :: Q [Dec]
-dt = return [DataD [] bar [] Nothing [NormalC bar [(NotStrict, ConT ''Int)]] []]
+dt = return [DataD [] bar [] Nothing [NormalC bar
+      [(Bang NoSourceUnpackedness NoSourceStrictness, ConT ''Int)]] []]
   where bar = mkName "Bar"
diff --git a/testsuite/tests/th/T7532.hs b/testsuite/tests/th/T7532.hs
index 3a641ea97a..a7604710f5 100644
--- a/testsuite/tests/th/T7532.hs
+++ b/testsuite/tests/th/T7532.hs
@@ -8,4 +8,4 @@ import T7532a
 instance C Bool where
   data D Bool = MkD
 
-$(bang)
+$(bang')
diff --git a/testsuite/tests/th/T7532.stderr b/testsuite/tests/th/T7532.stderr
index 3e57bb8955..baaf04f3f5 100644
--- a/testsuite/tests/th/T7532.stderr
+++ b/testsuite/tests/th/T7532.stderr
@@ -3,8 +3,8 @@
 instance C Bool where
   data D Bool = T7532.MkD
 
-T7532.hs:11:3-6: Splicing declarations
-    bang
+T7532.hs:11:3-7: Splicing declarations
+    bang'
   ======>
     instance C Int where
       data D Int = T
diff --git a/testsuite/tests/th/T7532a.hs b/testsuite/tests/th/T7532a.hs
index 42976b393c..901e27a1bf 100644
--- a/testsuite/tests/th/T7532a.hs
+++ b/testsuite/tests/th/T7532a.hs
@@ -8,8 +8,8 @@ import Language.Haskell.TH
 class C a where
      data D a
 
-bang :: DecsQ
-bang = return [
+bang' :: DecsQ
+bang' = return [
      InstanceD [] (AppT (ConT ''C) (ConT ''Int)) [
          DataInstD [] ''D [ConT ''Int] Nothing [
              NormalC (mkName "T") []] []]]
diff --git a/testsuite/tests/th/TH_genExLib.hs b/testsuite/tests/th/TH_genExLib.hs
index 5e1ee0bfc0..25091c4ecf 100644
--- a/testsuite/tests/th/TH_genExLib.hs
+++ b/testsuite/tests/th/TH_genExLib.hs
@@ -16,5 +16,6 @@ genAnyClass name decls
   where
     anyName = mkName ("Any" ++ nameBase name ++ "1111")
     constructor = ForallC [PlainTV var_a] [AppT (ConT name) (VarT var_a)] $
-		  NormalC anyName [(NotStrict, VarT var_a)]
+		  NormalC anyName
+			        [(Bang NoSourceUnpackedness NoSourceStrictness, VarT var_a)]
     var_a = mkName "a"
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 5a55b6f0da..9d00d8e856 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -358,6 +358,15 @@ test('T10306', normal, compile, ['-v0'])
 test('T10596', normal, compile, ['-v0'])
 test('T10620', normal, compile_and_run, ['-v0'])
 test('T10638', normal, compile_fail, ['-v0'])
+test('T10697_decided_1', normal, compile_and_run, ['-v0'])
+test('T10697_decided_2', normal, compile_and_run, ['-XStrictData -v0'])
+test('T10697_decided_3', normal,
+                         compile_and_run,
+                         ['-XStrictData -funbox-strict-fields -O2 -v0'])
+test('T10697_source',
+     extra_clean(['T10697_sourceUtil.hi', 'T10697_sourceUtil.o']),
+     multimod_compile_and_run,
+     ['T10697_source', '-w ' + config.ghc_th_way_flags])
 test('T10704',
      extra_clean(['T10704a.o','T10704a.hi']),
      multimod_compile_and_run,