Rework Template Haskell's handling of strictness
authorRyanGlScott <ryan.gl.scott@gmail.com>
Tue, 22 Dec 2015 10:25:59 +0000 (11:25 +0100)
committerBen Gamari <ben@smart-cactus.org>
Tue, 22 Dec 2015 12:22:29 +0000 (13:22 +0100)
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:
compiler/deSugar/DsMeta.hs
compiler/hsSyn/Convert.hs
compiler/prelude/THNames.hs
compiler/typecheck/TcSplice.hs
docs/users_guide/7.12.1-notes.rst
libraries/ghci/GHCi/Message.hs
libraries/ghci/GHCi/TH.hs
libraries/ghci/GHCi/TH/Binary.hs
libraries/template-haskell/Language/Haskell/TH.hs
libraries/template-haskell/Language/Haskell/TH/Lib.hs
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
libraries/template-haskell/changelog.md
testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun04.hs
testsuite/tests/rts/T7919A.hs
testsuite/tests/th/T10697_decided_1.hs [new file with mode: 0644]
testsuite/tests/th/T10697_decided_1.stdout [new file with mode: 0644]
testsuite/tests/th/T10697_decided_2.hs [new file with mode: 0644]
testsuite/tests/th/T10697_decided_2.stdout [new file with mode: 0644]
testsuite/tests/th/T10697_decided_3.hs [new file with mode: 0644]
testsuite/tests/th/T10697_decided_3.stdout [new file with mode: 0644]
testsuite/tests/th/T10697_source.hs [new file with mode: 0644]
testsuite/tests/th/T10697_source.stdout [new file with mode: 0644]
testsuite/tests/th/T10697_sourceUtil.hs [new file with mode: 0644]
testsuite/tests/th/T10819_Lib.hs
testsuite/tests/th/T10828.hs
testsuite/tests/th/T10828a.hs
testsuite/tests/th/T10828b.hs
testsuite/tests/th/T5290.hs
testsuite/tests/th/T5290.stderr
testsuite/tests/th/T5665a.hs
testsuite/tests/th/T5984_Lib.hs
testsuite/tests/th/T7532.hs
testsuite/tests/th/T7532.stderr
testsuite/tests/th/T7532a.hs
testsuite/tests/th/TH_genExLib.hs
testsuite/tests/th/all.T

index 0c72a9f..f56f446 100644 (file)
@@ -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
index 6c35a25..4b79922 100644 (file)
@@ -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)
index d683b1a..392aeda 100644 (file)
@@ -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,
index 9cce515..e3b4fa8 100644 (file)
@@ -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
index 2437abf..caa1d89 100644 (file)
@@ -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
 ~~~~~~~~~~~~~~
index 5406854..37c9f0c 100644 (file)
@@ -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
index 0121da9..f379dbc 100644 (file)
@@ -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)
index 41187fd..6183a3d 100644 (file)
@@ -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
index 66d507c..1988286 100644 (file)
@@ -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
index 737b9d4..ef928e8 100644 (file)
@@ -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
 
index bf240f4..d02ad0a 100644 (file)
@@ -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
index b333b00..d10fb3c 100644 (file)
@@ -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@
index 33419b3..9564e95 100644 (file)
   * 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
 
 
index e97fdce..d3c85ba 100644 (file)
@@ -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 [])
index 4dc013a..ddbdb04 100644 (file)
@@ -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 (file)
index 0000000..241cec3
--- /dev/null
@@ -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 (file)
index 0000000..b0dd4a2
--- /dev/null
@@ -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 (file)
index 0000000..241cec3
--- /dev/null
@@ -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 (file)
index 0000000..c4cfc4a
--- /dev/null
@@ -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 (file)
index 0000000..241cec3
--- /dev/null
@@ -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 (file)
index 0000000..ae59571
--- /dev/null
@@ -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 (file)
index 0000000..4dfa410
--- /dev/null
@@ -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 (file)
index 0000000..c4dc445
--- /dev/null
@@ -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 (file)
index 0000000..048a422
--- /dev/null
@@ -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
index 94f352e..2be00b4 100644 (file)
@@ -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
index f01c5b9..75b852f 100644 (file)
@@ -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") ] ]
            [] ])
index 8bf13cf..c3108c3 100644 (file)
@@ -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")
+                     )
+                   ]
            ]
            [] ])
index 55d8889..ac4f6a2 100644 (file)
@@ -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") ]
            ]
            [] ])
index 50ad2d5..2215ef1 100644 (file)
@@ -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)]] []] )
index d6996d0..19c962a 100644 (file)
@@ -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
index b34131e..2b55827 100644 (file)
@@ -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
index a929086..d8913cd 100644 (file)
@@ -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"
index 3a641ea..a760471 100644 (file)
@@ -8,4 +8,4 @@ import T7532a
 instance C Bool where
   data D Bool = MkD
 
-$(bang)
+$(bang')
index 3e57bb8..baaf04f 100644 (file)
@@ -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
index 42976b3..901e27a 100644 (file)
@@ -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") []] []]]
index 5e1ee0b..25091c4 100644 (file)
@@ -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"
index 5a55b6f..9d00d8e 100644 (file)
@@ -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,