[project @ 2000-10-24 10:36:08 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 73bbe59..12e853d 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -11,15 +11,14 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
 
 import CmdLineOpts     ( DynFlag(..), dopt )
 
-import HsSyn           ( HsDecl(..), InstDecl(..), TyClDecl(..),
-                         MonoBinds(..), HsExpr(..),  HsLit(..), Sig(..),
+import HsSyn           ( HsDecl(..), InstDecl(..), TyClDecl(..), 
+                         MonoBinds(..), HsExpr(..),  HsLit(..), Sig(..), 
                          andMonoBindList, collectMonoBinders, isClassDecl
                        )
-import HsTypes          ( HsType (..), HsTyVarBndr(..), toHsTyVar )
-import HsPat            ( InPat (..) )
-import HsMatches        ( Match (..) )
-import RnHsSyn         ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl,
-                         extractHsTyVars )
+import RnHsSyn         ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds,
+                         RenamedTyClDecl, RenamedHsType, 
+                         extractHsTyVars, maybeGenericMatch
+                       )
 import TcHsSyn         ( TcMonoBinds, mkHsConApp )
 import TcBinds         ( tcSpecSigs )
 import TcClassDcl      ( tcMethodBind, badMethodErr )
@@ -29,25 +28,23 @@ import Inst         ( InstOrigin(..),
                          LIE, emptyLIE, plusLIE, plusLIEs )
 import TcDeriv         ( tcDeriving )
 import TcEnv           ( TcEnv, tcExtendGlobalValEnv, 
-                         tcExtendTyVarEnvForMeths, TyThing (..),
+                         tcExtendTyVarEnvForMeths, 
                          tcAddImportedIdInfo, tcInstId, tcLookupClass,
                          newDFunName, tcExtendTyVarEnv
                        )
 import InstEnv         ( InstInfo(..), InstEnv, pprInstInfo, classDataCon, 
                          simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst,
                          extendInstEnv )
-import TcMonoType      ( tcTyVars, tcHsSigType, tcHsType, kcHsSigType )
+import TcMonoType      ( tcTyVars, tcHsSigType, kcHsSigType )
 import TcSimplify      ( tcSimplifyAndCheck )
 import TcType          ( zonkTcSigTyVars )
 import HscTypes                ( PersistentCompilerState(..), HomeSymbolTable, DFunId,
                          ModDetails(..) )
 
-import Bag             ( emptyBag, unitBag, unionBags, unionManyBags,
-                         foldBag, Bag, listToBag
-                       )
+import Bag             ( unionManyBags )
 import Class           ( Class, DefMeth(..), classBigSig )
 import Var             ( idName, idType )
-import Maybes          ( maybeToBool, expectJust )
+import Maybes          ( maybeToBool )
 import MkId            ( mkDictFunId )
 import Generics                ( validGenericInstanceType )
 import Module          ( Module, foldModuleEnv )
@@ -56,9 +53,9 @@ 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,
-                         splitAlgTyConApp_maybe, classesToPreds, classesOfPreds,
+import Type            ( mkTyVarTys, splitDFunTy, isTyVarTy,
+                         splitTyConApp_maybe, splitDictTy,
+                         splitAlgTyConApp_maybe, 
                          unUsgTy, tyVarsOfTypes, mkClassPred, mkTyVarTy,
                          getClassTys_maybe
                        )
@@ -66,21 +63,17 @@ import Subst                ( mkTopTyVarSubst, substClasses, substTheta )
 import VarSet          ( mkVarSet, varSetElems )
 import TysWiredIn      ( genericTyCons, isFFIArgumentTy, isFFIResultTy )
 import PrelNames       ( cCallableClassKey, cReturnableClassKey, hasKey )
-import Name             ( Name, NameEnv, extendNameEnv_C, emptyNameEnv, 
-                         plusNameEnv_C, nameEnvElts )
-import FiniteMap        ( mapFM )
+import Name             ( Name )
 import SrcLoc           ( SrcLoc )
-import RnHsSyn          -- ( RenamedMonoBinds )
 import VarSet           ( varSetElems )
-import UniqFM           ( mapUFM )
 import Unique          ( Uniquable(..) )
-import BasicTypes      ( NewOrData(..) )
+import BasicTypes      ( NewOrData(..), Fixity )
 import ErrUtils                ( dumpIfSet_dyn )
 import ListSetOps      ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, 
                          assocElts, extendAssoc_C,
                          equivClassesByUniq, minusList
                        )
-import List             ( intersect, (\\), partition )
+import List             ( partition )
 import Outputable
 \end{code}
 
@@ -247,10 +240,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
@@ -324,7 +314,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: 
@@ -521,7 +511,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
@@ -777,10 +767,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)]