[project @ 2000-10-24 07:35:00 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 987d1d5..245e762 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 TcInstUtil      ( InstInfo(..), InstEnv, pprInstInfo, classDataCon, 
+import InstEnv         ( InstInfo(..), InstEnv, pprInstInfo, classDataCon, 
                          simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst,
                          extendInstEnv )
 import TcMonoType      ( tcTyVars, tcHsSigType, tcHsType, kcHsSigType )
@@ -56,8 +56,8 @@ import NameSet                ( emptyNameSet, nameSetToList )
 import PrelInfo                ( eRROR_ID )
 import PprType         ( pprConstraint, pprPred )
 import TyCon           ( TyCon, isSynTyCon, tyConDerivings )
-import Type            ( mkTyVarTys, splitSigmaTy, isTyVarTy,
-                         splitTyConApp_maybe, splitDictTy_maybe,
+import Type            ( mkTyVarTys, splitDFunTy, isTyVarTy,
+                         splitTyConApp_maybe, splitDictTy,
                          splitAlgTyConApp_maybe, classesToPreds, classesOfPreds,
                          unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
                          getClassTys_maybe
@@ -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 ->
@@ -246,10 +247,7 @@ tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
        -- Type-check all the stuff before the "where"
     tcHsSigType poly_ty                        `thenTc` \ poly_ty' ->
     let
-       (tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
-       (clas, inst_tys)         = case splitDictTy_maybe dict_ty of
-                                    Just ct -> ct
-                                    Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)
+       (tyvars, theta, clas, inst_tys) = splitDFunTy poly_ty'
     in
 
     (case maybe_dfun_name of
@@ -323,7 +321,7 @@ getGenericInstances mod class_decls
     returnTc gen_inst_info
 
 get_generics mod decl@(ClassDecl context class_name tyvar_names 
-                                fundeps class_sigs def_methods pragmas 
+                                fundeps class_sigs def_methods
                                 name_list loc)
   | null groups                
   = returnTc [] -- The comon case: 
@@ -520,7 +518,7 @@ tcInstDecl2 (InstInfo { iClass = clas, iTyVars = inst_tyvars, iTys = inst_tys,
        -- Instantiate the instance decl with tc-style type variables
     tcInstId dfun_id           `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
     let
-       (clas, inst_tys') = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty')
+       (clas, inst_tys') = splitDictTy dict_ty'
        origin            = InstanceDeclOrigin
 
         (class_tyvars, sc_theta, _, op_items) = classBigSig clas
@@ -776,10 +774,10 @@ tcAddDeclCtxt decl thing_inside
   where
      (name, loc, thing)
        = case decl of
-           (ClassDecl _ name _ _ _ _ _ _ loc)         -> (name, loc, "class")
-           (TySynonym name _ _ loc)                   -> (name, loc, "type synonym")
-           (TyData NewType  _ name _ _ _ _ _ loc _ _) -> (name, loc, "newtype")
-           (TyData DataType _ name _ _ _ _ _ loc _ _) -> (name, loc, "data type")
+           (ClassDecl _ name _ _ _ _ _ loc)         -> (name, loc, "class")
+           (TySynonym name _ _ loc)                 -> (name, loc, "type synonym")
+           (TyData NewType  _ name _ _ _ _ loc _ _) -> (name, loc, "newtype")
+           (TyData DataType _ name _ _ _ _ loc _ _) -> (name, loc, "data type")
 
      ctxt = hsep [ptext SLIT("In the"), text thing, 
                  ptext SLIT("declaration for"), quotes (ppr name)]