[project @ 2000-10-24 17:09:44 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcDeriv.lhs

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 28a2e24..ac28035 100644 (file)
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -16,9 +16,9 @@ import RnHsSyn                ( RenamedHsBinds, RenamedMonoBinds )
 import CmdLineOpts     ( DynFlag(..), DynFlags )
 
 import TcMonad
-import TcEnv           ( TcEnv, tcSetInstEnv, getTcGST, newDFunName )
+import TcEnv           ( TcEnv, tcSetInstEnv, newDFunName )
 import TcGenDeriv      -- Deriv stuff
-import InstEnv ( InstInfo(..), InstEnv, 
+import InstEnv         ( InstInfo(..), InstEnv, 
                          pprInstInfo, simpleDFunClassTyCon, extendInstEnv )
 import TcSimplify      ( tcSimplifyThetas )
 
@@ -26,33 +26,29 @@ import RnBinds              ( rnMethodBinds, rnTopMonoBinds )
 import RnEnv           ( bindLocatedLocalsRn )
 import RnMonad         ( --RnNameSupply, 
                          renameSourceCode, thenRn, mapRn, returnRn )
-import HscTypes                ( DFunId, GlobalSymbolTable, PersistentRenamerState )
+import HscTypes                ( DFunId, PersistentRenamerState )
 
-import Bag             ( Bag, emptyBag, unionBags, listToBag )
+import BasicTypes      ( Fixity )
 import Class           ( classKey, Class )
 import ErrUtils                ( dumpIfSet_dyn, Message )
 import MkId            ( mkDictFunId )
-import Id              ( mkVanillaId, idType )
+import Id              ( idType )
 import DataCon         ( dataConArgTys, isNullaryDataCon, isExistentialDataCon )
 import PrelInfo                ( needsDataDeclCtxtClassKeys )
 import Maybes          ( maybeToBool, catMaybes )
 import Module          ( Module )
-import Name            ( Name, isLocallyDefined, getSrcLoc, NamedThing(..) )
+import Name            ( Name, isLocallyDefined, getSrcLoc )
 import RdrName         ( RdrName )
---import RnMonad               ( FixityEnv )
 
 import TyCon           ( tyConTyVars, tyConDataCons, tyConDerivings,
                          tyConTheta, maybeTyConSingleCon, isDataTyCon,
-                         isEnumerationTyCon, isAlgTyCon, TyCon
+                         isEnumerationTyCon, TyCon
                        )
 import Type            ( TauType, PredType(..), mkTyVarTys, mkTyConApp,
-                         mkSigmaTy, splitSigmaTy, splitDictTy, mkDictTy, 
-                         isUnboxedType, splitAlgTyConApp, classesToPreds
+                         splitDFunTy, isUnboxedType
                        )
-import TysWiredIn      ( voidTy )
 import Var             ( TyVar )
 import PrelNames
-import Bag             ( bagToList )
 import Util            ( zipWithEqual, sortLt, thenCmp )
 import ListSetOps      ( removeDups,  assoc )
 import Outputable
@@ -188,11 +184,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 +217,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.
@@ -257,8 +254,7 @@ tcDeriving prs mod inst_env_in local_tycons
                   iBinds = binds,
                   iLoc = getSrcLoc dfun, iPrags = [] }
         where
-        (tyvars, theta, tau) = splitSigmaTy (idType dfun)
-        (clas, tys)          = splitDictTy tau
+        (tyvars, theta, clas, tys) = splitDFunTy (idType dfun)
 
     rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'
        -- Ignore the free vars returned
@@ -528,11 +524,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)