From 0499865e0ff47ce970030a4d65897a5e2f592605 Mon Sep 17 00:00:00 2001 From: sewardj Date: Mon, 23 Oct 2000 12:55:31 +0000 Subject: [PATCH] [project @ 2000-10-23 12:55:31 by sewardj] 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. --- ghc/compiler/main/HscMain.lhs | 6 ++++-- ghc/compiler/typecheck/TcDeriv.lhs | 15 ++++++------- ghc/compiler/typecheck/TcGenDeriv.lhs | 37 ++++++++++++++++----------------- ghc/compiler/typecheck/TcInstDcls.lhs | 7 ++++--- ghc/compiler/typecheck/TcModule.lhs | 20 +++++++++++++----- 5 files changed, 49 insertions(+), 36 deletions(-) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index f308b8f..5f41edb 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -135,8 +135,10 @@ hscMain flags core_cmds stg_cmds summary maybe_old_iface -------------------------- 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 diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 28a2e24..9c15b24 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -18,7 +18,7 @@ import CmdLineOpts ( DynFlag(..), DynFlags ) 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 ) @@ -188,11 +188,12 @@ context to the instance decl. The "offending classes" are 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 -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 @@ -220,7 +221,7 @@ tcDeriving prs mod inst_env_in local_tycons 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. @@ -528,11 +529,11 @@ the renamer. What a great hack! -- 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 - | 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) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 81b6a89..670db8e 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -47,7 +47,6 @@ import Name ( getOccString, getOccName, getSrcLoc, occNameString, Name, NamedThing(..), isDataSymOcc, isSymOcc ) -import HscTypes ( GlobalSymbolTable, lookupFixityEnv ) import PrelInfo -- Lots of RdrNames import SrcLoc ( generatedSrcLoc, SrcLoc ) @@ -773,9 +772,9 @@ gen_Ix_binds tycon %************************************************************************ \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 @@ -903,7 +902,7 @@ gen_Read_binds gst tycon 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) @@ -916,7 +915,7 @@ gen_Read_binds gst tycon -} 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. @@ -930,9 +929,9 @@ gen_Read_binds gst tycon %************************************************************************ \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 @@ -1003,7 +1002,7 @@ gen_Show_binds gst tycon 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 = @@ -1029,20 +1028,20 @@ gen_Show_binds gst tycon -} paren_prec_limit | not is_infix = fromInt maxPrecedence + 1 - | otherwise = getFixity gst dc_nm + 1 + | otherwise = getFixity get_fixity dc_nm + 1 \end{code} \begin{code} -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. -} - (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 @@ -1055,15 +1054,15 @@ getLRPrecs is_infix gst nm = [lp, rp] | 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) -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) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index a94d11f..73bbe59 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -33,7 +33,7 @@ import TcEnv ( TcEnv, tcExtendGlobalValEnv, 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 ) @@ -170,12 +170,13 @@ Gather up the instance declarations from their various sources 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) -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] @@ -211,7 +212,7 @@ tcInstDecls1 pcs hst unf_env mod local_tycons decls -- 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 -> diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 608511b..cd9aaca 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -33,7 +33,7 @@ import TcRules ( tcRules ) 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 ) @@ -86,10 +86,12 @@ typecheckModule -> Module -> PersistentCompilerState -> HomeSymbolTable + -> HomeIfaceTable + -> PackageIfaceTable -> 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) @@ -101,13 +103,21 @@ typecheckModule dflags this_mod pcs hst (HsModule mod_name _ _ _ decls _ src_loc 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 + -> (Name -> Maybe Fixity) -> Module -> [RenamedHsDecl] -> TcEnv -- The knot-tied environment @@ -120,7 +130,7 @@ tcModule :: PersistentCompilerState -- 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 $ @@ -137,7 +147,7 @@ tcModule pcs hst this_mod decls unf_env 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 $ -- 1.7.10.4