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

6 files changed, 70 insertions, 0 deletions

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'])