Implement the Strict language extension

Add a new language extension `-XStrict` which turns all bindings strict
as if the programmer had written a `!` before it. This also upgrades
ordinary Haskell to allow recursive and polymorphic strict bindings.

See the wiki[1] and the Note [Desugar Strict binds] in DsBinds for
specification and implementation details.

[1] https://ghc.haskell.org/trac/ghc/wiki/StrictPragma

Reviewers: austin, tibbe, simonpj, bgamari

Reviewed By: tibbe, bgamari

Subscribers: thomie

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

GHC Trac Issues: #8347

18 files changed, 113 insertions, 14 deletions

diff --git a/testsuite/tests/deSugar/should_compile/DsStrictWarn.hs b/testsuite/tests/deSugar/should_compile/DsStrictWarn.hs
new file mode 100644
index 0000000000..81b337d05b
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/DsStrictWarn.hs
@@ -0,0 +1,7 @@
+{-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-}
+{-# LANGUAGE Strict #-}
+module DsStrictWarn where
+
+-- should warn about non-exhaustive pattern match
+w :: String -> String
+w x = let (_:_) = x in "1"
diff --git a/testsuite/tests/deSugar/should_compile/DsStrictWarn.stderr b/testsuite/tests/deSugar/should_compile/DsStrictWarn.stderr
new file mode 100644
index 0000000000..974e51c38c
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/DsStrictWarn.stderr
@@ -0,0 +1,4 @@
+
+DsStrictWarn.hs:7:11: warning:
+    Pattern match(es) are non-exhaustive
+    In a pattern binding: Patterns not matched: []
diff --git a/testsuite/tests/deSugar/should_compile/T5455.hs b/testsuite/tests/deSugar/should_compile/T5455.hs
index b6d44b8bcb..26c1a79384 100644
--- a/testsuite/tests/deSugar/should_compile/T5455.hs
+++ b/testsuite/tests/deSugar/should_compile/T5455.hs
@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -fwarn-incomplete-uni-patterns #-}
 module T5455 where
 
--- No error message for this one: 
+-- No error message for this one:
 -- the pattern will never be demanded
 
 w :: String -> String
diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T
index 543e01e8b3..c6b024f1b9 100644
--- a/testsuite/tests/deSugar/should_compile/all.T
+++ b/testsuite/tests/deSugar/should_compile/all.T
@@ -84,7 +84,7 @@ test('T4870',
 test('T5117', normal, compile, [''])
 test('T5252',
      extra_clean(['T5252a.hi', 'T5252a.o']),
-     run_command, 
+     run_command,
      ['$MAKE -s --no-print-directory T5252'])
 test('T5455', normal, compile, [''])
 test('T5001',
@@ -96,10 +96,11 @@ test('T5001',
 # T5252Take2 failed when compiled *wihtout* optimisation
 test('T5252Take2',
      extra_clean(['T5252Take2a.hi', 'T5252Take2a.o']),
-     run_command, 
+     run_command,
      ['$MAKE -s --no-print-directory T5252Take2'])
 test('T2431', normal, compile, ['-ddump-simpl -dsuppress-uniques'])
 test('T7669', normal, compile, [''])
 test('T8470', normal, compile, [''])
 test('T10251', normal, compile, [''])
 test('T10767', normal, compile, [''])
+test('DsStrictWarn', normal, compile, [''])
diff --git a/testsuite/tests/deSugar/should_fail/DsStrictFail.hs b/testsuite/tests/deSugar/should_fail/DsStrictFail.hs
new file mode 100644
index 0000000000..eadfd517e8
--- /dev/null
+++ b/testsuite/tests/deSugar/should_fail/DsStrictFail.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE Strict #-}
+module Main where
+
+main = let False = True
+       in return ()
diff --git a/testsuite/tests/deSugar/should_fail/DsStrictFail.stderr b/testsuite/tests/deSugar/should_fail/DsStrictFail.stderr
new file mode 100644
index 0000000000..c7135b2a27
--- /dev/null
+++ b/testsuite/tests/deSugar/should_fail/DsStrictFail.stderr
@@ -0,0 +1,2 @@
+DsStrictFail: DsStrictFail.hs:4:12-23: Irrefutable pattern failed for pattern False
+
diff --git a/testsuite/tests/deSugar/should_fail/Makefile b/testsuite/tests/deSugar/should_fail/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/deSugar/should_fail/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/deSugar/should_fail/all.T b/testsuite/tests/deSugar/should_fail/all.T
new file mode 100644
index 0000000000..1a501ba4c3
--- /dev/null
+++ b/testsuite/tests/deSugar/should_fail/all.T
@@ -0,0 +1,6 @@
+# Args to compile_and_run are:
+#	extra compile flags
+#	extra run flags
+#	expected process return value, if not zero
+
+test('DsStrictFail', expect_fail, compile_and_run, [''])
diff --git a/testsuite/tests/deSugar/should_run/DsStrict.hs b/testsuite/tests/deSugar/should_run/DsStrict.hs
new file mode 100644
index 0000000000..ef3f06fd45
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsStrict.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE Strict #-}
+{-# OPTIONS_GHC -fno-warn-unused-binds #-}
+module Main where
+
+import Debug.Trace
+
+f0 a = "fun"
+f0' ~a = "fun2"
+
+f1 ~n =
+  case n of
+    a -> "case"
+f1' ~n =
+  case n of
+    ~a -> "case2"
+
+f2 = \a -> "lamda"
+f2' = \ ~a -> "lambda2"
+
+newtype Age = MkAge Int
+
+f4, f4' :: Age -> String
+f4 (MkAge a) = "newtype"
+f4' ~(MkAge a) = "newtype2"
+
+main :: IO ()
+main = mapM_ (\(what,f) -> putStrLn (f (v what))) fs
+  where fs =
+          [("fun",f0 )
+          ,("fun lazy",f0')
+          ,("case",f1)
+          ,("case lazy",f1')
+          ,("lambda",f2)
+          ,("lambda lazy",f2')
+          ,("newtype",(\ ~i -> f4 (MkAge i)))
+          ,("newtype lazy",(\ ~i -> f4' (MkAge i)))]
+        v n = trace ("evaluated in " ++ n) 1
diff --git a/testsuite/tests/deSugar/should_run/DsStrict.stderr b/testsuite/tests/deSugar/should_run/DsStrict.stderr
new file mode 100644
index 0000000000..0097ca9a43
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsStrict.stderr
@@ -0,0 +1,4 @@
+evaluated in fun
+evaluated in case
+evaluated in lambda
+evaluated in newtype
diff --git a/testsuite/tests/deSugar/should_run/DsStrict.stdout b/testsuite/tests/deSugar/should_run/DsStrict.stdout
new file mode 100644
index 0000000000..7895f2a0cb
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsStrict.stdout
@@ -0,0 +1,8 @@
+fun
+fun2
+case
+case2
+lamda
+lambda2
+newtype
+newtype2
diff --git a/testsuite/tests/deSugar/should_run/DsStrictLet.hs b/testsuite/tests/deSugar/should_run/DsStrictLet.hs
new file mode 100644
index 0000000000..ee515da716
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsStrictLet.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE Strict #-}
+module Main where
+
+import Debug.Trace
+
+main = let False = trace "no binders" False -- evaluated
+
+           a :: a -> a
+           a = trace "polymorphic" id -- evaluated
+
+           f :: Eq a => a -> a -> Bool
+           f = trace "overloaded" (==) -- not evaluated
+
+           xs :: [Int]
+           xs = (trace "recursive" (:) 1 xs) -- evaluated
+       in return ()
diff --git a/testsuite/tests/deSugar/should_run/DsStrictLet.stderr b/testsuite/tests/deSugar/should_run/DsStrictLet.stderr
new file mode 100644
index 0000000000..f0fcb1bc32
--- /dev/null
+++ b/testsuite/tests/deSugar/should_run/DsStrictLet.stderr
@@ -0,0 +1,3 @@
+recursive
+polymorphic
+no binders
diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T
index bc72b01568..cc21ed7248 100644
--- a/testsuite/tests/deSugar/should_run/all.T
+++ b/testsuite/tests/deSugar/should_run/all.T
@@ -50,3 +50,5 @@ test('T9238', normal, compile_and_run, [''])
 test('T9844', normal, compile_and_run, [''])
 test('T10215', normal, compile_and_run, [''])
 test('DsStrictData', normal, compile_and_run, [''])
+test('DsStrict', normal, compile_and_run, [''])
+test('DsStrictLet', normal, compile_and_run, ['-O'])
diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs
index f345ce6b1f..0d9d146d95 100644
--- a/testsuite/tests/driver/T4437.hs
+++ b/testsuite/tests/driver/T4437.hs
@@ -32,7 +32,8 @@ check title expected got
 expectedGhcOnlyExtensions :: [String]
 expectedGhcOnlyExtensions = ["RelaxedLayout",
                              "AlternativeLayoutRule",
-                             "AlternativeLayoutRuleTransitional"]
+                             "AlternativeLayoutRuleTransitional",
+                             "Strict"]
 
 expectedCabalOnlyExtensions :: [String]
 expectedCabalOnlyExtensions = ["Generics",
diff --git a/testsuite/tests/ghci/scripts/T9140.script b/testsuite/tests/ghci/scripts/T9140.script
index 833ea87413..53eb63afa9 100644
--- a/testsuite/tests/ghci/scripts/T9140.script
+++ b/testsuite/tests/ghci/scripts/T9140.script
@@ -1,5 +1,5 @@
-:set -XUnboxedTuples -XBangPatterns
+:set -XUnboxedTuples
 let a = (# 1 #)
 let a = (# 1, 3 #)
-:set -XBangPatterns
-let !a = (# 1, 3 #)
+
+let a = (# 1, 3 #) :: (# Integer, Integer #)
diff --git a/testsuite/tests/ghci/scripts/T9140.stdout b/testsuite/tests/ghci/scripts/T9140.stdout
index d9520c0960..6456067f59 100644
--- a/testsuite/tests/ghci/scripts/T9140.stdout
+++ b/testsuite/tests/ghci/scripts/T9140.stdout
@@ -1,14 +1,14 @@
 
-<interactive>:2:5:
+<interactive>:2:5: error:
     You can't mix polymorphic and unlifted bindings
       a = (# 1 #)
-      Probable fix: use a bang pattern
+      Probable fix: add a type signature
 
-<interactive>:3:5:
+<interactive>:3:5: error:
     You can't mix polymorphic and unlifted bindings
       a = (# 1, 3 #)
-      Probable fix: use a bang pattern
+      Probable fix: add a type signature
 
-<interactive>:1:1:
+<interactive>:1:1: error:
     GHCi can't bind a variable of unlifted type:
       a :: (# Integer, Integer #)
diff --git a/testsuite/tests/typecheck/should_fail/T6078.stderr b/testsuite/tests/typecheck/should_fail/T6078.stderr
index 467dede23f..b45363bdc3 100644
--- a/testsuite/tests/typecheck/should_fail/T6078.stderr
+++ b/testsuite/tests/typecheck/should_fail/T6078.stderr
@@ -1,8 +1,8 @@
 
-T6078.hs:8:10:
+T6078.hs:8:10: error:
     You can't mix polymorphic and unlifted bindings
       ip1p@(Ptr ip1) = Ptr ip0 `plusPtr` len
-      Probable fix: use a bang pattern
+      Probable fix: add a type signature
     In the expression:
       let ip1p@(Ptr ip1) = Ptr ip0 `plusPtr` len in ip1p
     In the expression: