Get the right fixity-env in standalone deriving (Trac #9830)

6 files changed, 50 insertions, 11 deletions

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 161bb773e4..76b8423130 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -30,6 +30,8 @@ import FamInstEnv
 import TcHsType
 import TcMType
 import TcSimplify
+import LoadIface( loadInterfaceForName )
+import Module( getModule, isInteractiveModule )
 
 import RnNames( extendGlobalRdrEnvRn )
 import RnBinds
@@ -2091,9 +2093,26 @@ genDerivStuff loc clas dfun_name tycon comaux_maybe
       return (binds, unitBag (DerivFamInst faminst))
 
   | otherwise                      -- Non-monadic generators
-  = do dflags <- getDynFlags
-       fix_env <- getFixityEnv
-       return (genDerivedBinds dflags fix_env clas loc tycon)
+  = do { dflags <- getDynFlags
+       ; fix_env <- getDataConFixityFun tycon
+       ; return (genDerivedBinds dflags fix_env clas loc tycon) }
+
+getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
+-- If the TyCon is locally defined, we want the local fixity env;
+-- but if it is imported (which happens for standalone deriving)
+-- we need to get the fixity env from the interface file
+-- c.f. RnEnv.lookupFixity, and Trac #9830
+getDataConFixityFun tc
+  = do { this_mod <- getModule
+       ; if nameIsLocalOrFrom this_mod name || isInteractiveModule (nameModule name)
+         then do { fix_env <- getFixityEnv
+                 ; return (lookupFixity fix_env) }
+         else do { iface <- loadInterfaceForName doc name
+                            -- Should already be loaded!
+                 ; return (mi_fix_fn iface . nameOccName) } }
+  where
+    name = tyConName tc
+    doc = ptext (sLit "Data con fixities for") <+> ppr name
 \end{code}
 
 Note [Bindings for Generalised Newtype Deriving]
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index f911d16565..dda2cf874c 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -37,7 +37,6 @@ import DataCon
 import Name
 
 import DynFlags
-import HscTypes
 import PrelInfo
 import FamInstEnv( FamInst )
 import MkCore ( eRROR_ID )
@@ -102,7 +101,7 @@ data DerivStuff     -- Please add this auxiliary stuff
 %************************************************************************
 
 \begin{code}
-genDerivedBinds :: DynFlags -> FixityEnv -> Class -> SrcSpan -> TyCon
+genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon
                 -> (LHsBinds RdrName, BagDerivStuff)
 genDerivedBinds dflags fix_env clas loc tycon
   | Just gen_fn <- assocMaybe gen_list (getUnique clas)
@@ -951,7 +950,7 @@ These instances are also useful for Read (Either Int Emp), where
 we want to be able to parse (Left 3) just fine.
 
 \begin{code}
-gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 
 gen_Read_binds get_fixity loc tycon
   = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
@@ -1120,7 +1119,7 @@ Example
                     -- the most tightly-binding operator
 
 \begin{code}
-gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
 
 gen_Show_binds get_fixity loc tycon
   = (listToBag [shows_prec, show_list], emptyBag)
@@ -1216,7 +1215,7 @@ mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString st
 \end{code}
 
 \begin{code}
-getPrec :: Bool -> FixityEnv -> Name -> Integer
+getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
 getPrec is_infix get_fixity nm
   | not is_infix   = appPrecedence
   | otherwise      = getPrecedence get_fixity nm
@@ -1226,9 +1225,9 @@ appPrecedence = fromIntegral maxPrecedence + 1
   -- One more than the precedence of the most
   -- tightly-binding operator
 
-getPrecedence :: FixityEnv -> Name -> Integer
+getPrecedence :: (Name -> Fixity) -> Name -> Integer
 getPrecedence get_fixity nm
-   = case lookupFixity get_fixity nm of
+   = case get_fixity nm of
         Fixity x _assoc -> fromIntegral x
           -- NB: the Report says that associativity is not taken
           --     into account for either Read or Show; hence we
diff --git a/testsuite/tests/deriving/should_run/T9830.hs b/testsuite/tests/deriving/should_run/T9830.hs
new file mode 100644
index 0000000000..353decc347
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T9830.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE StandaloneDeriving #-}
+module Main where
+
+import T9830a
+
+deriving instance (Show a, Show b) => Show (ADT a b)
+
+main :: IO ()
+main = do
+    putStrLn $ "Prec 6:  " ++ showsPrec 6  ("test" :?: "show") ""
+    putStrLn $ "Prec 7:  " ++ showsPrec 7  ("test" :?: "show") ""
+    putStrLn $ "Prec 9:  " ++ showsPrec 9  ("test" :?: "show") ""
+    putStrLn $ "Prec 10: " ++ showsPrec 10 ("test" :?: "show") ""
diff --git a/testsuite/tests/deriving/should_run/T9830.stdout b/testsuite/tests/deriving/should_run/T9830.stdout
new file mode 100644
index 0000000000..7d9bbe5bde
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T9830.stdout
@@ -0,0 +1,4 @@
+Prec 6:  "test" :?: "show"
+Prec 7:  ("test" :?: "show")
+Prec 9:  ("test" :?: "show")
+Prec 10: ("test" :?: "show")
diff --git a/testsuite/tests/deriving/should_run/T9830a.hs b/testsuite/tests/deriving/should_run/T9830a.hs
new file mode 100644
index 0000000000..1b2ef17cbc
--- /dev/null
+++ b/testsuite/tests/deriving/should_run/T9830a.hs
@@ -0,0 +1,4 @@
+module T9830a where
+
+infixr 6 :?:
+data ADT a b = a :?: b deriving (Eq, Ord, Read)
diff --git a/testsuite/tests/deriving/should_run/all.T b/testsuite/tests/deriving/should_run/all.T
index 21c1962ed1..58b4903698 100644
--- a/testsuite/tests/deriving/should_run/all.T
+++ b/testsuite/tests/deriving/should_run/all.T
@@ -37,4 +37,4 @@ test('T5712', normal, compile_and_run, [''])
 test('T7931', normal, compile_and_run, [''])
 test('T8280', normal, compile_and_run, [''])
 test('T9576', exit_code(1), compile_and_run, [''])
-
+test('T9830', normal, multimod_compile_and_run, ['T9830','-v0'])