[commit: ghc] master: Get the right fixity-env in standalone deriving (Trac #9830) (01f03cb)
git at git.haskell.org
git at git.haskell.org
Thu Nov 27 15:43:39 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/01f03cb30426fad1b848051fa142c04c8816a80c/ghc
>---------------------------------------------------------------
commit 01f03cb30426fad1b848051fa142c04c8816a80c
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Thu Nov 27 15:44:10 2014 +0000
Get the right fixity-env in standalone deriving (Trac #9830)
>---------------------------------------------------------------
01f03cb30426fad1b848051fa142c04c8816a80c
compiler/typecheck/TcDeriv.lhs | 25 +++++++++++++++++++++---
compiler/typecheck/TcGenDeriv.lhs | 13 ++++++------
testsuite/tests/deriving/should_run/T9830.hs | 13 ++++++++++++
testsuite/tests/deriving/should_run/T9830.stdout | 4 ++++
testsuite/tests/deriving/should_run/T9830a.hs | 4 ++++
testsuite/tests/deriving/should_run/all.T | 2 +-
6 files changed, 50 insertions(+), 11 deletions(-)
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 161bb77..76b8423 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 f911d16..dda2cf8 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 0000000..353decc
--- /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 0000000..7d9bbe5
--- /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 0000000..1b2ef17
--- /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 21c1962..58b4903 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'])
More information about the ghc-commits
mailing list