Commit 01f03cb3 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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

parent b61091d3
......@@ -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]
......
......@@ -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
......
{-# 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") ""
Prec 6: "test" :?: "show"
Prec 7: ("test" :?: "show")
Prec 9: ("test" :?: "show")
Prec 10: ("test" :?: "show")
module T9830a where
infixr 6 :?:
data ADT a b = a :?: b deriving (Eq, Ord, Read)
......@@ -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'])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment