[commit: ghc] ghc-7.10: Fix #10596 by looking up 'Int' not 'Maybe Int' in the map. (024d7c3)

[git at git.haskell.org]

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

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/024d7c33ea3f8eec9703c5de256f80de09a23578/ghc

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

commit 024d7c33ea3f8eec9703c5de256f80de09a23578
Author: Edward Z. Yang <ezyang at cs.stanford.edu>
Date:   Tue Jul 7 21:19:54 2015 +0200

    Fix #10596 by looking up 'Int' not 'Maybe Int' in the map.
    
    Test Plan: validate
    
    Reviewers: goldfire, austin, simonpj, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: simonpj, rwbarton, thomie, bgamari
    
    Differential Revision: https://phabricator.haskell.org/D1026
    
    GHC Trac Issues: #10596


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

024d7c33ea3f8eec9703c5de256f80de09a23578
 compiler/typecheck/TcSplice.hs   | 15 +++++++++++----
 testsuite/tests/th/T10596.hs     | 11 +++++++++++
 testsuite/tests/th/T10596.stderr |  1 +
 testsuite/tests/th/all.T         |  1 +
 4 files changed, 24 insertions(+), 4 deletions(-)

diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 6c62060..d14d114 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -6,7 +6,11 @@
 TcSplice: Template Haskell splices
 -}
 
-{-# LANGUAGE CPP, FlexibleInstances, MagicHash, ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module TcSplice(
@@ -106,7 +110,7 @@ import GHC.Desugar      ( AnnotationWrapper(..) )
 
 import qualified Data.Map as Map
 import Data.Dynamic  ( fromDynamic, toDyn )
-import Data.Typeable ( typeOf )
+import Data.Typeable ( typeOf, Typeable )
 import Data.Data (Data)
 import GHC.Exts         ( unsafeCoerce# )
 #endif
@@ -949,11 +953,14 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv
       updTcRef th_modfinalizers_var (\fins -> fin:fins)
 
+  qGetQ :: forall a. Typeable a => IOEnv (Env TcGblEnv TcLclEnv) (Maybe a)
   qGetQ = do
       th_state_var <- fmap tcg_th_state getGblEnv
       th_state <- readTcRef th_state_var
-      let x = Map.lookup (typeOf x) th_state >>= fromDynamic
-      return x
+      -- See #10596 for why we use a scoped type variable here.
+      -- ToDo: convert @undefined :: a@ to @proxy :: Proxy a@ when
+      -- we drop support for GHC 7.6.
+      return (Map.lookup (typeOf (undefined :: a)) th_state >>= fromDynamic)
 
   qPutQ x = do
       th_state_var <- fmap tcg_th_state getGblEnv
diff --git a/testsuite/tests/th/T10596.hs b/testsuite/tests/th/T10596.hs
new file mode 100644
index 0000000..c861156
--- /dev/null
+++ b/testsuite/tests/th/T10596.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T10596 where
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+do
+  putQ (100 :: Int)
+  x <- (getQ :: Q (Maybe Int))
+
+  -- It should print "Just 100"
+  runIO $ print x
+  return []
diff --git a/testsuite/tests/th/T10596.stderr b/testsuite/tests/th/T10596.stderr
new file mode 100644
index 0000000..4b58162
--- /dev/null
+++ b/testsuite/tests/th/T10596.stderr
@@ -0,0 +1 @@
+Just 100
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index bc6ca5d..ff0bc9b 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -360,3 +360,4 @@ test('T8624', normal, run_command, ['$MAKE -s --no-print-directory T8624'])
 test('TH_Lift', normal, compile, ['-v0'])
 test('T10019', normal, ghci_script, ['T10019.script'])
 test('T10279', normal, compile_fail, ['-v0'])
+test('T10596', normal, compile, ['-v0'])