[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.

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index f308b8f..5f41edb 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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                      $