[commit: ghc] ghc-8.0: Fix Show derivation in the presence of RebindableSyntax/OverloadedStrings (d7a1f68)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/d7a1f682af766e6c1529932b24bada9053d5c4da/ghc

>---------------------------------------------------------------

commit d7a1f682af766e6c1529932b24bada9053d5c4da
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Sat Oct 15 11:11:20 2016 -0400

    Fix Show derivation in the presence of RebindableSyntax/OverloadedStrings
    
    Summary:
    To fix this issue, we simply disable `RebindableSyntax` whenever we rename
    the code generated from a deriving clause.
    
    Fixes #12688.
    
    Test Plan: make test TEST=T12688
    
    Reviewers: simonpj, austin, bgamari
    
    Reviewed By: simonpj, bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2591
    
    GHC Trac Issues: #12688
    
    (cherry picked from commit b501709ed79ba03e72518ef9dd101ce2d03db2de)


>---------------------------------------------------------------

d7a1f682af766e6c1529932b24bada9053d5c4da
 compiler/typecheck/TcDeriv.hs                     | 41 ++++++++++++++++++++---
 compiler/typecheck/TcRnMonad.hs                   |  6 +++-
 docs/users_guide/8.0.2-notes.rst                  |  4 +++
 docs/users_guide/glasgow_exts.rst                 | 27 +++++++++++++++
 testsuite/tests/deriving/should_compile/T12688.hs | 15 +++++++++
 testsuite/tests/deriving/should_compile/all.T     |  1 +
 6 files changed, 88 insertions(+), 6 deletions(-)

diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index c72772a..9a84952 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -439,11 +439,17 @@ renameDeriv is_boot inst_infos bagBinds
                  , emptyValBindsOut, usesOnly (plusFVs fvs)) }
 
   | otherwise
-  = discardWarnings $         -- Discard warnings about unused bindings etc
-    setXOptM LangExt.EmptyCase $  -- Derived decls (for empty types) can have
-                                  --    case x of {}
-    setXOptM LangExt.ScopedTypeVariables $  -- Derived decls (for newtype-deriving) can
-    setXOptM LangExt.KindSignatures $       -- used ScopedTypeVariables & KindSignatures
+  = discardWarnings $
+    -- Discard warnings about unused bindings etc
+    setXOptM LangExt.EmptyCase $
+    -- Derived decls (for empty types) can have
+    --    case x of {}
+    setXOptM LangExt.ScopedTypeVariables $
+    setXOptM LangExt.KindSignatures $
+    -- Derived decls (for newtype-deriving) can use ScopedTypeVariables &
+    -- KindSignatures
+    unsetXOptM LangExt.RebindableSyntax $
+    -- See Note [Avoid RebindableSyntax when deriving]
     do  {
         -- Bring the extra deriving stuff into scope
         -- before renaming the instances themselves
@@ -513,6 +519,31 @@ dropped patterns have.
 Also, this technique carries over the kind substitution from deriveTyData
 nicely.
 
+Note [Avoid RebindableSyntax when deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The RebindableSyntax extension interacts awkwardly with the derivation of
+any stock class whose methods require the use of string literals. The Show
+class is a simple example (see Trac #12688):
+
+  {-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
+  newtype Text = Text String
+  fromString :: String -> Text
+  fromString = Text
+
+  data Foo = Foo deriving Show
+
+This will generate code to the effect of:
+
+  instance Show Foo where
+    showsPrec _ Foo = showString "Foo"
+
+But because RebindableSyntax and OverloadedStrings are enabled, the "Foo"
+string literal is now of type Text, not String, which showString doesn't
+accept! This causes the generated Show instance to fail to typecheck.
+
+To avoid this kind of scenario, we simply turn off RebindableSyntax entirely
+in derived code.
+
 ************************************************************************
 *                                                                      *
                 From HsSyn to DerivSpec
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 21035d6..278082e 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -18,7 +18,7 @@ module TcRnMonad(
   setGblEnv, getLclEnv, updLclEnv, setLclEnv,
   getEnvs, setEnvs,
   xoptM, doptM, goptM, woptM,
-  setXOptM, unsetGOptM, unsetWOptM,
+  setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,
   whenDOptM, whenGOptM, whenWOptM, whenXOptM,
   getGhcMode,
   withDoDynamicToo,
@@ -447,6 +447,10 @@ setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 setXOptM flag =
   updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})
 
+unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
+unsetXOptM flag =
+  updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag})
+
 unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
 unsetGOptM flag =
   updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})
diff --git a/docs/users_guide/8.0.2-notes.rst b/docs/users_guide/8.0.2-notes.rst
index 668474a..b1568ae 100644
--- a/docs/users_guide/8.0.2-notes.rst
+++ b/docs/users_guide/8.0.2-notes.rst
@@ -21,6 +21,10 @@ Language
 
 -  TODO FIXME.
 
+-  A bug has been fixed that caused derived ``Show`` instances to fail in the
+   presence of :ghc-flag:`-XRebindableSyntax` and
+   :ghc-flag:`-XOverloadedStrings` (:ghc-ticket:`12688`).
+
 Compiler
 ~~~~~~~~
 
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index d7ba481..5153d07 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -1464,6 +1464,33 @@ Be warned: this is an experimental facility, with fewer checks than
 usual. Use ``-dcore-lint`` to typecheck the desugared program. If Core
 Lint is happy you should be all right.
 
+Things unaffected by :ghc-flag:`-XRebindableSyntax`
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+:ghc-flag:`-XRebindableSyntax` does not apply to any code generated from a
+``deriving`` clause or declaration. To see why, consider the following code: ::
+
+    {-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
+    newtype Text = Text String
+
+    fromString :: String -> Text
+    fromString = Text
+
+    data Foo = Foo deriving Show
+
+This will generate code to the effect of: ::
+
+    instance Show Foo where
+      showsPrec _ Foo = showString "Foo"
+
+But because :ghc-flag:`-XRebindableSyntax` and :ghc-flag:`-XOverloadedStrings`
+are enabled, the ``"Foo"`` string literal would now be of type ``Text``, not
+``String``, which ``showString`` doesn't accept! This causes the generated
+``Show`` instance to fail to typecheck. It's hard to imagine any scenario where
+it would be desirable have :ghc-flag:`-XRebindableSyntax` behavior within
+derived code, so GHC simply ignores :ghc-flag:`-XRebindableSyntax` entirely
+when checking derived code.
+
 .. _postfix-operators:
 
 Postfix operators
diff --git a/testsuite/tests/deriving/should_compile/T12688.hs b/testsuite/tests/deriving/should_compile/T12688.hs
new file mode 100644
index 0000000..0735a81
--- /dev/null
+++ b/testsuite/tests/deriving/should_compile/T12688.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
+module T12688 where
+
+import Prelude (String,Show(..))
+
+newtype Text = Text String
+
+fromString :: String -> Text
+fromString = Text
+
+x :: Text
+x = "x"
+
+newtype Foo = Foo ()
+  deriving (Show)
diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T
index d79aa6d..1261aaa 100644
--- a/testsuite/tests/deriving/should_compile/all.T
+++ b/testsuite/tests/deriving/should_compile/all.T
@@ -74,3 +74,4 @@ test('T11837', normal, compile, [''])
 test('T12399', normal, compile, [''])
 test('T12583', normal, compile, [''])
 test('T12616', normal, compile, [''])
+test('T12688', normal, compile, [''])