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

24 files changed, 223 insertions, 32 deletions

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,