Plumb a function :: Name -> Maybe Fixity into the depths of the deriver
for deriving Show and Read. This information is in the ModIFaces, not
the ModDetails, and we don't want to send complete ModIFaces into the
typechecker.
-------------------------- Typechecking ----------------
show_pass "TypeCheck" >>
_scc_ "TypeCheck"
-------------------------- Typechecking ----------------
show_pass "TypeCheck" >>
_scc_ "TypeCheck"
- typecheckModule tc_uniqs rn_name_supply
- fixity_env rn_mod >>= \ maybe_tc_stuff ->
+ typecheckModule dflags mod pcs hst hit pit rn_mod
+ -- tc_uniqs rn_name_supply
+ -- fixity_env rn_mod
+ >>= \ maybe_tc_stuff ->
case maybe_tc_stuff of {
Nothing -> ghcExit 1; -- Type checker failed
case maybe_tc_stuff of {
Nothing -> ghcExit 1; -- Type checker failed
import TcMonad
import TcEnv ( TcEnv, tcSetInstEnv, getTcGST, newDFunName )
import TcGenDeriv -- Deriv stuff
import TcMonad
import TcEnv ( TcEnv, tcSetInstEnv, getTcGST, newDFunName )
import TcGenDeriv -- Deriv stuff
-import InstEnv ( InstInfo(..), InstEnv,
+import InstEnv ( InstInfo(..), InstEnv,
pprInstInfo, simpleDFunClassTyCon, extendInstEnv )
import TcSimplify ( tcSimplifyThetas )
pprInstInfo, simpleDFunClassTyCon, extendInstEnv )
import TcSimplify ( tcSimplifyThetas )
tcDeriving :: PersistentRenamerState
-> Module -- name of module under scrutiny
-> InstEnv -- What we already know about instances
tcDeriving :: PersistentRenamerState
-> Module -- name of module under scrutiny
-> InstEnv -- What we already know about instances
+ -> (Name -> Maybe Fixity) -- used in deriving Show and Read
-> [TyCon] -- "local_tycons" ???
-> TcM ([InstInfo], -- The generated "instance decls".
RenamedHsBinds) -- Extra generated bindings
-> [TyCon] -- "local_tycons" ???
-> TcM ([InstInfo], -- The generated "instance decls".
RenamedHsBinds) -- Extra generated bindings
-tcDeriving prs mod inst_env_in local_tycons
+tcDeriving prs mod inst_env_in get_fixity local_tycons
= recoverTc (returnTc ([], EmptyBinds)) $
-- Fish the "deriving"-related information out of the TcEnv
= recoverTc (returnTc ([], EmptyBinds)) $
-- Fish the "deriving"-related information out of the TcEnv
let
extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
let
extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
- method_binds_s = map (gen_bind (getTcGST env)) new_dfuns
+ method_binds_s = map (gen_bind get_fixity) new_dfuns
mbinders = collectLocatedMonoBinders extra_mbinds
-- Rename to get RenamedBinds.
mbinders = collectLocatedMonoBinders extra_mbinds
-- Rename to get RenamedBinds.
-- Generate the method bindings for the required instance
-- (paired with class name, as we need that when generating dict
-- names.)
-- Generate the method bindings for the required instance
-- (paired with class name, as we need that when generating dict
-- names.)
-gen_bind :: GlobalSymbolTable -> DFunId -> RdrNameMonoBinds
-gen_bind fixities dfun
+gen_bind :: (Name -> Maybe Fixity) -> DFunId -> RdrNameMonoBinds
+gen_bind get_fixity dfun
| not (isLocallyDefined tycon) = EmptyMonoBinds
| not (isLocallyDefined tycon) = EmptyMonoBinds
- | clas `hasKey` showClassKey = gen_Show_binds fixities tycon
- | clas `hasKey` readClassKey = gen_Read_binds fixities tycon
+ | clas `hasKey` showClassKey = gen_Show_binds get_fixity tycon
+ | clas `hasKey` readClassKey = gen_Read_binds get_fixity tycon
| otherwise
= assoc "gen_bind:bad derived class"
[(eqClassKey, gen_Eq_binds)
| otherwise
= assoc "gen_bind:bad derived class"
[(eqClassKey, gen_Eq_binds)
Name, NamedThing(..),
isDataSymOcc, isSymOcc
)
Name, NamedThing(..),
isDataSymOcc, isSymOcc
)
-import HscTypes ( GlobalSymbolTable, lookupFixityEnv )
import PrelInfo -- Lots of RdrNames
import SrcLoc ( generatedSrcLoc, SrcLoc )
import PrelInfo -- Lots of RdrNames
import SrcLoc ( generatedSrcLoc, SrcLoc )
%************************************************************************
\begin{code}
%************************************************************************
\begin{code}
-gen_Read_binds :: GlobalSymbolTable -> TyCon -> RdrNameMonoBinds
+gen_Read_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds
-gen_Read_binds gst tycon
+gen_Read_binds get_fixity tycon
= reads_prec `AndMonoBinds` read_list
where
tycon_loc = getSrcLoc tycon
= reads_prec `AndMonoBinds` read_list
where
tycon_loc = getSrcLoc tycon
then d_Expr
else HsVar (last bs_needed)] Boxed
then d_Expr
else HsVar (last bs_needed)] Boxed
- [lp,rp] = getLRPrecs is_infix gst dc_nm
+ [lp,rp] = getLRPrecs is_infix get_fixity dc_nm
quals
| is_infix = let (h:t) = field_quals in (h:con_qual:t)
quals
| is_infix = let (h:t) = field_quals in (h:con_qual:t)
-}
paren_prec_limit
| not is_infix = fromInt maxPrecedence
-}
paren_prec_limit
| not is_infix = fromInt maxPrecedence
- | otherwise = getFixity gst dc_nm
+ | otherwise = getFixity get_fixity dc_nm
read_paren_arg -- parens depend on precedence...
| nullary_con = false_Expr -- it's optional.
read_paren_arg -- parens depend on precedence...
| nullary_con = false_Expr -- it's optional.
%************************************************************************
\begin{code}
%************************************************************************
\begin{code}
-gen_Show_binds :: GlobalSymbolTable -> TyCon -> RdrNameMonoBinds
+gen_Show_binds :: (Name -> Maybe Fixity) -> TyCon -> RdrNameMonoBinds
-gen_Show_binds gst tycon
+gen_Show_binds get_fixity tycon
= shows_prec `AndMonoBinds` show_list
where
tycon_loc = getSrcLoc tycon
= shows_prec `AndMonoBinds` show_list
where
tycon_loc = getSrcLoc tycon
mk_showString_app str = HsApp (HsVar showString_RDR)
(HsLit (mkHsString str))
mk_showString_app str = HsApp (HsVar showString_RDR)
(HsLit (mkHsString str))
- prec_cons = getLRPrecs is_infix gst dc_nm
+ prec_cons = getLRPrecs is_infix get_fixity dc_nm
real_show_thingies
| is_infix =
real_show_thingies
| is_infix =
-}
paren_prec_limit
| not is_infix = fromInt maxPrecedence + 1
-}
paren_prec_limit
| not is_infix = fromInt maxPrecedence + 1
- | otherwise = getFixity gst dc_nm + 1
+ | otherwise = getFixity get_fixity dc_nm + 1
-getLRPrecs :: Bool -> GlobalSymbolTable -> Name -> [Integer]
-getLRPrecs is_infix gst nm = [lp, rp]
+getLRPrecs :: Bool -> (Name -> Maybe Fixity) -> Name -> [Integer]
+getLRPrecs is_infix get_fixity nm = [lp, rp]
where
{-
Figuring out the fixities of the arguments to a constructor,
cf. Figures 16-18 in Haskell 1.1 report.
-}
where
{-
Figuring out the fixities of the arguments to a constructor,
cf. Figures 16-18 in Haskell 1.1 report.
-}
- (con_left_assoc, con_right_assoc) = isLRAssoc gst nm
- paren_con_prec = getFixity gst nm
+ (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm
+ paren_con_prec = getFixity get_fixity nm
maxPrec = fromInt maxPrecedence
lp
maxPrec = fromInt maxPrecedence
lp
| con_right_assoc = paren_con_prec
| otherwise = paren_con_prec + 1
| con_right_assoc = paren_con_prec
| otherwise = paren_con_prec + 1
-getFixity :: GlobalSymbolTable -> Name -> Integer
-getFixity gst nm
- = case lookupFixityEnv gst nm of
+getFixity :: (Name -> Maybe Fixity) -> Name -> Integer
+getFixity get_fixity nm
+ = case get_fixity nm of
Just (Fixity x _) -> fromInt x
other -> pprPanic "TcGenDeriv.getFixity" (ppr nm)
Just (Fixity x _) -> fromInt x
other -> pprPanic "TcGenDeriv.getFixity" (ppr nm)
-isLRAssoc :: GlobalSymbolTable -> Name -> (Bool, Bool)
-isLRAssoc fixs_assoc nm =
- case lookupFixityEnv fixs_assoc nm of
+isLRAssoc :: (Name -> Maybe Fixity) -> Name -> (Bool, Bool)
+isLRAssoc get_fixity nm =
+ case get_fixity nm of
Just (Fixity _ InfixN) -> (False, False)
Just (Fixity _ InfixR) -> (False, True)
Just (Fixity _ InfixL) -> (True, False)
Just (Fixity _ InfixN) -> (False, False)
Just (Fixity _ InfixR) -> (False, True)
Just (Fixity _ InfixL) -> (True, False)
tcAddImportedIdInfo, tcInstId, tcLookupClass,
newDFunName, tcExtendTyVarEnv
)
tcAddImportedIdInfo, tcInstId, tcLookupClass,
newDFunName, tcExtendTyVarEnv
)
-import InstEnv ( InstInfo(..), InstEnv, pprInstInfo, classDataCon,
+import InstEnv ( InstInfo(..), InstEnv, pprInstInfo, classDataCon,
simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst,
extendInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, tcHsType, kcHsSigType )
simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst,
extendInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, tcHsType, kcHsSigType )
tcInstDecls1 :: PersistentCompilerState
-> HomeSymbolTable -- Contains instances
-> TcEnv -- Contains IdInfo for dfun ids
tcInstDecls1 :: PersistentCompilerState
-> HomeSymbolTable -- Contains instances
-> TcEnv -- Contains IdInfo for dfun ids
+ -> (Name -> Maybe Fixity) -- for deriving Show and Read
-> Module -- Module for deriving
-> [TyCon]
-> [RenamedHsDecl]
-> TcM (PersistentCompilerState, InstEnv, [InstInfo], RenamedHsBinds)
-> Module -- Module for deriving
-> [TyCon]
-> [RenamedHsDecl]
-> TcM (PersistentCompilerState, InstEnv, [InstInfo], RenamedHsBinds)
-tcInstDecls1 pcs hst unf_env mod local_tycons decls
+tcInstDecls1 pcs hst unf_env get_fixity mod local_tycons decls
= let
inst_decls = [inst_decl | InstD inst_decl <- decls]
clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl clas_decl]
= let
inst_decls = [inst_decl | InstD inst_decl <- decls]
clas_decls = [clas_decl | TyClD clas_decl <- decls, isClassDecl clas_decl]
-- we ignore deriving decls from interfaces!
-- This stuff computes a context for the derived instance decl, so it
-- needs to know about all the instances possible; hecne inst_env4
-- we ignore deriving decls from interfaces!
-- This stuff computes a context for the derived instance decl, so it
-- needs to know about all the instances possible; hecne inst_env4
- tcDeriving (pcs_PRS pcs) mod inst_env4 local_tycons
+ tcDeriving (pcs_PRS pcs) mod inst_env4 get_fixity local_tycons
`thenTc` \ (deriv_inst_info, deriv_binds) ->
addInstInfos inst_env4 deriv_inst_info
`thenNF_Tc` \ final_inst_env ->
`thenTc` \ (deriv_inst_info, deriv_binds) ->
addInstInfos inst_env4 deriv_inst_info
`thenNF_Tc` \ final_inst_env ->
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
-import InstEnv ( InstInfo(..) )
+import InstEnv ( InstInfo(..) )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import TcTyDecls ( mkImplicitDataBinds )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import TcTyDecls ( mkImplicitDataBinds )
-> Module
-> PersistentCompilerState
-> HomeSymbolTable
-> Module
-> PersistentCompilerState
-> HomeSymbolTable
+ -> HomeIfaceTable
+ -> PackageIfaceTable
-> RenamedHsModule
-> IO (Maybe (TcEnv, TcResults))
-> RenamedHsModule
-> IO (Maybe (TcEnv, TcResults))
-typecheckModule dflags this_mod pcs hst (HsModule mod_name _ _ _ decls _ src_loc)
+typecheckModule dflags this_mod pcs hst hit pit (HsModule mod_name _ _ _ decls _ src_loc)
= do env <- initTcEnv global_symbol_table
(maybe_result, (errs,warns)) <- initTc dflags env src_loc tc_module
printErrorsAndWarnings (errs,warns)
= do env <- initTcEnv global_symbol_table
(maybe_result, (errs,warns)) <- initTc dflags env src_loc tc_module
printErrorsAndWarnings (errs,warns)
where
global_symbol_table = pcs_PST pcs `plusModuleEnv` hst
where
global_symbol_table = pcs_PST pcs `plusModuleEnv` hst
- tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst this_mod decls unf_env)
+ tc_module = fixTc (\ ~(unf_env ,_)
+ -> tcModule pcs hst get_fixity this_mod decls unf_env)
+
+ get_fixity :: Name -> Maybe Fixity
+ get_fixity nm
+ = case lookupFixityEnv hit nm of
+ Just f -> Just f
+ Nothing -> lookupFixityEnv pit nm
\end{code}
The internal monster:
\begin{code}
tcModule :: PersistentCompilerState
-> HomeSymbolTable
\end{code}
The internal monster:
\begin{code}
tcModule :: PersistentCompilerState
-> HomeSymbolTable
+ -> (Name -> Maybe Fixity)
-> Module
-> [RenamedHsDecl]
-> TcEnv -- The knot-tied environment
-> Module
-> [RenamedHsDecl]
-> TcEnv -- The knot-tied environment
-- unf_env is also used to get the pragama info
-- for imported dfuns and default methods
-- unf_env is also used to get the pragama info
-- for imported dfuns and default methods
-tcModule pcs hst this_mod decls unf_env
+tcModule pcs hst get_fixity this_mod decls unf_env
= -- Type-check the type and class decls
tcTyAndClassDecls unf_env decls `thenTc` \ env ->
tcSetEnv env $
= -- Type-check the type and class decls
tcTyAndClassDecls unf_env decls `thenTc` \ env ->
tcSetEnv env $
in
-- Typecheck the instance decls, includes deriving
in
-- Typecheck the instance decls, includes deriving
- tcInstDecls1 pcs hst unf_env this_mod
+ tcInstDecls1 pcs hst unf_env get_fixity this_mod
local_tycons decls `thenTc` \ (pcs_with_insts, inst_env, inst_info, deriv_binds) ->
tcSetInstEnv inst_env $
local_tycons decls `thenTc` \ (pcs_with_insts, inst_env, inst_info, deriv_binds) ->
tcSetInstEnv inst_env $