projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 1996-07-19 18:36:04 by partain]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcInstDcls.lhs
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 2f75b9d..df32170 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -13,70 +13,77 @@ module TcInstDcls (
     ) where
 
 
     ) where
 
 
-import Ubiq
+IMP_Ubiq()
 
 import HsSyn           ( InstDecl(..), FixityDecl, Sig(..),
                          SpecInstSig(..), HsBinds(..), Bind(..),
                          MonoBinds(..), GRHSsAndBinds, Match, 
                          InPat(..), OutPat(..), HsExpr(..), HsLit(..),
 
 import HsSyn           ( InstDecl(..), FixityDecl, Sig(..),
                          SpecInstSig(..), HsBinds(..), Bind(..),
                          MonoBinds(..), GRHSsAndBinds, Match, 
                          InPat(..), OutPat(..), HsExpr(..), HsLit(..),
-                         Stmt, Qual, ArithSeqInfo, Fake,
+                         Stmt, Qualifier, ArithSeqInfo, Fake,
                          PolyType(..), MonoType )
                          PolyType(..), MonoType )
-import RnHsSyn         ( RenamedHsBinds(..), RenamedMonoBinds(..),
+import RnHsSyn         ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
                          RenamedInstDecl(..), RenamedFixityDecl(..),
                          RenamedInstDecl(..), RenamedFixityDecl(..),
-                         RenamedSig(..), RenamedSpecInstSig(..) )
-import TcHsSyn         ( TcIdOcc(..), TcHsBinds(..),
-                         TcMonoBinds(..), TcExpr(..),
+                         RenamedSig(..), RenamedSpecInstSig(..),
+                         RnName(..){-incl instance Outputable-}
+                       )
+import TcHsSyn         ( TcIdOcc(..), SYN_IE(TcHsBinds),
+                         SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
                          mkHsTyLam, mkHsTyApp,
                          mkHsDictLam, mkHsDictApp )
 
 
                          mkHsTyLam, mkHsTyApp,
                          mkHsDictLam, mkHsDictApp )
 
 
-import TcMonad
-import GenSpecEtc      ( checkSigTyVars, specTy )
-import Inst            ( Inst, InstOrigin(..), InstanceMapper(..),
-                         newDicts, newMethod, LIE(..), emptyLIE, plusLIE )
+import TcMonad         hiding ( rnMtoTcM )
+import GenSpecEtc      ( checkSigTyVars )
+import Inst            ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
+                         newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
 import TcBinds         ( tcPragmaSigs )
 import TcDeriv         ( tcDeriving )
 import TcBinds         ( tcPragmaSigs )
 import TcDeriv         ( tcDeriving )
-import TcEnv           ( tcLookupClass, tcTyVarScope, newLocalIds )
+import TcEnv           ( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars )
+import SpecEnv         ( SpecEnv )
 import TcGRHSs         ( tcGRHSsAndBinds )
 import TcInstUtil      ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
 import TcKind          ( TcKind, unifyKind )
 import TcMatches       ( tcMatchesFun )
 import TcMonoType      ( tcContext, tcMonoTypeKind )
 import TcGRHSs         ( tcGRHSsAndBinds )
 import TcInstUtil      ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
 import TcKind          ( TcKind, unifyKind )
 import TcMatches       ( tcMatchesFun )
 import TcMonoType      ( tcContext, tcMonoTypeKind )
-import TcSimplify      ( tcSimplifyAndCheck, tcSimplifyThetas )
-import TcType          ( TcType(..), TcTyVar(..),
-                         tcInstTyVar, tcInstType, tcInstTheta )
-import Unify           ( unifyTauTy )
+import TcSimplify      ( tcSimplifyAndCheck )
+import TcType          ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet), 
+                         tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
+                       )
+import Unify           ( unifyTauTy, unifyTauTyLists )
 
 
 import Bag             ( emptyBag, unitBag, unionBags, unionManyBags,
                          concatBag, foldBag, bagToList )
 
 
 import Bag             ( emptyBag, unitBag, unionBags, unionManyBags,
                          concatBag, foldBag, bagToList )
-import CmdLineOpts     ( opt_GlasgowExts, opt_CompilingPrelude,
+import CmdLineOpts     ( opt_GlasgowExts, opt_CompilingGhcInternals,
                          opt_OmitDefaultInstanceMethods,
                          opt_OmitDefaultInstanceMethods,
-                         opt_SpecialiseOverloaded )
+                         opt_SpecialiseOverloaded
+                       )
 import Class           ( GenClass, GenClassOp, 
 import Class           ( GenClass, GenClassOp, 
-                         isCcallishClass, getClassBigSig,
-                         getClassOps, getClassOpLocalType )
-import CoreUtils       ( escErrorMsg )
-import Id              ( idType, isDefaultMethodId_maybe )
+                         isCcallishClass, classBigSig,
+                         classOps, classOpLocalType,
+                         classOpTagByString
+                         )
+import Id              ( GenId, idType, isDefaultMethodId_maybe )
 import ListSetOps      ( minusList )
 import Maybes          ( maybeToBool, expectJust )
 import ListSetOps      ( minusList )
 import Maybes          ( maybeToBool, expectJust )
-import Name            ( Name, getTagFromClassOpName )
-import Outputable
-import PrelInfo                ( pAT_ERROR_ID )
+import Name            ( getLocalName, origName, nameOf, Name{--O only-} )
+import PrelVals                ( nO_EXPLICIT_METHOD_ERROR_ID )
+import PrelMods                ( pRELUDE )
 import PprType         ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
 import PprType         ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
-                         pprParendType )
+                         pprParendGenType
+                       )
 import PprStyle
 import Pretty
 import PprStyle
 import Pretty
-import RnUtils         ( GlobalNameMappers(..), GlobalNameMapper(..) )
-import TyCon           ( derivedFor )
-import Type            ( GenType(..),  ThetaType(..), mkTyVarTy,
-                         splitSigmaTy, splitAppTy, isTyVarTy, matchTy,
-                         getTyCon_maybe, maybeBoxedPrimType )
-import TyVar           ( GenTyVar, tyVarListToSet )
+import RnUtils         ( SYN_IE(RnEnv) )
+import TyCon           ( isSynTyCon, derivedFor )
+import Type            ( GenType(..), SYN_IE(ThetaType), mkTyVarTys,
+                         splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
+                         getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy
+                       )
+import TyVar           ( GenTyVar, SYN_IE(GenTyVarSet), mkTyVarSet, unionTyVarSets )
 import TysWiredIn      ( stringTy )
 import Unique          ( Unique )
 import TysWiredIn      ( stringTy )
 import Unique          ( Unique )
-import Util            ( panic )
-
+import Util            ( zipEqual, panic )
 \end{code}
 
 Typechecking instance declarations is done in two passes. The first
 \end{code}
 
 Typechecking instance declarations is done in two passes. The first
@@ -155,14 +162,14 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 \begin{code}
 tcInstDecls1 :: Bag RenamedInstDecl
             -> [RenamedSpecInstSig]
 \begin{code}
 tcInstDecls1 :: Bag RenamedInstDecl
             -> [RenamedSpecInstSig]
-            -> FAST_STRING             -- module name for deriving
-            -> GlobalNameMappers       -- renamer fns for deriving
+            -> Module                  -- module name for deriving
+            -> RnEnv                   -- for renaming derivings
             -> [RenamedFixityDecl]     -- fixities for deriving
             -> TcM s (Bag InstInfo,
                       RenamedHsBinds,
                       PprStyle -> Pretty)
 
             -> [RenamedFixityDecl]     -- fixities for deriving
             -> TcM s (Bag InstInfo,
                       RenamedHsBinds,
                       PprStyle -> Pretty)
 
-tcInstDecls1 inst_decls specinst_sigs mod_name renamer_name_funs fixities
+tcInstDecls1 inst_decls specinst_sigs mod_name rn_env fixities
   =    -- Do the ordinary instance declarations
     mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls
                        `thenNF_Tc` \ inst_info_bags ->
   =    -- Do the ordinary instance declarations
     mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls
                        `thenNF_Tc` \ inst_info_bags ->
@@ -173,7 +180,7 @@ tcInstDecls1 inst_decls specinst_sigs mod_name renamer_name_funs fixities
        -- for things in this module; we ignore deriving decls from
        -- interfaces! We pass fixities, because they may be used
        -- in deriving Read and Show.
        -- for things in this module; we ignore deriving decls from
        -- interfaces! We pass fixities, because they may be used
        -- in deriving Read and Show.
-    tcDeriving mod_name renamer_name_funs decl_inst_info fixities
+    tcDeriving mod_name rn_env decl_inst_info fixities
                        `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
 
     let
                        `thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
 
     let
@@ -206,8 +213,11 @@ tcInstDecl1 mod_name
        -- Look things up
     tcLookupClass class_name           `thenNF_Tc` \ (clas_kind, clas) ->
 
        -- Look things up
     tcLookupClass class_name           `thenNF_Tc` \ (clas_kind, clas) ->
 
+    let
+       de_rn (RnName n) = n
+    in
        -- Typecheck the context and instance type
        -- Typecheck the context and instance type
-    tcTyVarScope tyvar_names (\ tyvars ->
+    tcTyVarScope (map de_rn tyvar_names) (\ tyvars ->
        tcContext context               `thenTc` \ theta ->
        tcMonoTypeKind inst_ty          `thenTc` \ (tau_kind, tau) ->
        unifyKind clas_kind tau_kind    `thenTc_`
        tcContext context               `thenTc` \ theta ->
        tcMonoTypeKind inst_ty          `thenTc` \ (tau_kind, tau) ->
        unifyKind clas_kind tau_kind    `thenTc_`
@@ -223,7 +233,8 @@ tcInstDecl1 mod_name
     if (not from_here && (clas `derivedFor` inst_tycon)
                      && all isTyVarTy arg_tys)
     then
     if (not from_here && (clas `derivedFor` inst_tycon)
                      && all isTyVarTy arg_tys)
     then
-       if mod_name == inst_mod then
+       if mod_name == inst_mod
+       then
                -- Imported instance came from this module;
                -- discard and derive fresh instance
            returnTc emptyBag           
                -- Imported instance came from this module;
                -- discard and derive fresh instance
            returnTc emptyBag           
@@ -234,7 +245,7 @@ tcInstDecl1 mod_name
     else
 
        -- Make the dfun id and constant-method ids
     else
 
        -- Make the dfun id and constant-method ids
-    mkInstanceRelatedIds from_here inst_mod pragmas
+    mkInstanceRelatedIds from_here src_loc inst_mod pragmas
                         clas inst_tyvars inst_tau inst_theta uprags
                                        `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 
                         clas inst_tyvars inst_tau inst_theta uprags
                                        `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 
@@ -346,19 +357,17 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
     tcAddSrcLoc locn                                   $
 
        -- Get the class signature
     tcAddSrcLoc locn                                   $
 
        -- Get the class signature
-    mapNF_Tc tcInstTyVar inst_tyvars   `thenNF_Tc` \ inst_tyvars' ->
+    tcInstSigTyVars inst_tyvars                `thenNF_Tc` \ (inst_tyvars', _, tenv) ->
     let 
     let 
-       tenv = inst_tyvars `zip` (map mkTyVarTy inst_tyvars')
-
         (class_tyvar,
         super_classes, sc_sel_ids,
         (class_tyvar,
         super_classes, sc_sel_ids,
-        class_ops, op_sel_ids, defm_ids) = getClassBigSig clas
+        class_ops, op_sel_ids, defm_ids) = classBigSig clas
     in
     tcInstType tenv inst_ty            `thenNF_Tc` \ inst_ty' ->
     tcInstTheta tenv dfun_theta                `thenNF_Tc` \ dfun_theta' ->
     tcInstTheta tenv inst_decl_theta   `thenNF_Tc` \ inst_decl_theta' ->
     let
     in
     tcInstType tenv inst_ty            `thenNF_Tc` \ inst_ty' ->
     tcInstTheta tenv dfun_theta                `thenNF_Tc` \ dfun_theta' ->
     tcInstTheta tenv inst_decl_theta   `thenNF_Tc` \ inst_decl_theta' ->
     let
-       sc_theta'        = super_classes `zip` (repeat inst_ty')
+       sc_theta'        = super_classes `zip` repeat inst_ty'
        origin           = InstanceDeclOrigin
        mk_method sel_id = newMethod origin (RealId sel_id) [inst_ty']
     in
        origin           = InstanceDeclOrigin
        mk_method sel_id = newMethod origin (RealId sel_id) [inst_ty']
     in
@@ -373,17 +382,20 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
 
         -- Collect available Insts
     let
 
         -- Collect available Insts
     let
+       inst_tyvars_set' = mkTyVarSet inst_tyvars'
+
        avail_insts      -- These insts are in scope; quite a few, eh?
          = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s) 
 
        mk_method_expr
          = if opt_OmitDefaultInstanceMethods then
        avail_insts      -- These insts are in scope; quite a few, eh?
          = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s) 
 
        mk_method_expr
          = if opt_OmitDefaultInstanceMethods then
-               makeInstanceDeclNoDefaultExpr origin clas meth_ids defm_ids inst_mod inst_ty'
+               makeInstanceDeclNoDefaultExpr     origin meth_ids defm_ids inst_ty' clas inst_mod
            else
            else
-               makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty'
+               makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id 
     in
     in
-    processInstBinds mk_method_expr inst_tyvars' avail_insts meth_ids monobinds
-                                               `thenTc` \ (insts_needed, method_mbinds) ->
+    tcExtendGlobalTyVars inst_tyvars_set' (
+       processInstBinds clas mk_method_expr avail_insts meth_ids monobinds
+    )                                  `thenTc` \ (insts_needed, method_mbinds) ->
     let
        -- Create the dict and method binds
        dict_bind
     let
        -- Create the dict and method binds
        dict_bind
@@ -392,7 +404,6 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
        dict_and_method_binds
            = dict_bind `AndMonoBinds` method_mbinds
 
        dict_and_method_binds
            = dict_bind `AndMonoBinds` method_mbinds
 
-       inst_tyvars_set' = tyVarListToSet inst_tyvars'
     in
        -- Check the overloading constraints of the methods and superclasses
     tcAddErrCtxt (bindSigCtxt meth_ids) (
     in
        -- Check the overloading constraints of the methods and superclasses
     tcAddErrCtxt (bindSigCtxt meth_ids) (
@@ -427,8 +438,8 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
                 inst_tyvars'
                 dfun_arg_dicts_ids
                 ((this_dict_id, RealId dfun_id) 
                 inst_tyvars'
                 dfun_arg_dicts_ids
                 ((this_dict_id, RealId dfun_id) 
-                 : (meth_ids `zip` (map RealId const_meth_ids)))
-                       -- const_meth_ids will often be empty
+                 : (meth_ids `zip` map RealId const_meth_ids))
+                       -- NB: const_meth_ids will often be empty
                 super_binds
                 (RecBind dict_and_method_binds)
 
                 super_binds
                 (RecBind dict_and_method_binds)
 
@@ -439,7 +450,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
     returnTc (const_lie `plusLIE` spec_lie, inst_binds)
 \end{code}
 
     returnTc (const_lie `plusLIE` spec_lie, inst_binds)
 \end{code}
 
-This function makes a default method which calls the global default method, at
+The next function makes a default method which calls the global default method, at
 the appropriate instance type.
 
 See the notes under default decls in TcClassDcl.lhs.
 the appropriate instance type.
 
 See the notes under default decls in TcClassDcl.lhs.
@@ -447,74 +458,54 @@ See the notes under default decls in TcClassDcl.lhs.
 \begin{code}
 makeInstanceDeclDefaultMethodExpr
        :: InstOrigin s
 \begin{code}
 makeInstanceDeclDefaultMethodExpr
        :: InstOrigin s
-       -> TcIdOcc s
-       -> [ClassOp]
+       -> [TcIdOcc s]
        -> [Id]
        -> TcType s
        -> [Id]
        -> TcType s
+       -> TcIdOcc s
        -> Int
        -> NF_TcM s (TcExpr s)
 
        -> Int
        -> NF_TcM s (TcExpr s)
 
-makeInstanceDeclDefaultMethodExpr origin this_dict class_ops defm_ids inst_ty tag
-  = specTy origin (getClassOpLocalType class_op)
-                               `thenNF_Tc` \ (op_tyvars, op_lie, op_tau, op_dicts) ->
-
-       -- def_op_id = /\ op_tyvars -> \ op_dicts ->
-       --                defm_id inst_ty op_tyvars this_dict op_dicts
-
-    returnNF_Tc (
-      mkHsTyLam op_tyvars (
-      mkHsDictLam op_dicts (
-      mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id))
-                            (inst_ty :  map mkTyVarTy op_tyvars))
-                 (this_dict : op_dicts)
-      )))
+makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag
+  =
+       -- def_op_id = defm_id inst_ty this_dict
+    returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict])
  where
  where
-    idx             = tag - 1
-    class_op = class_ops !! idx
-    defm_id  = defm_ids  !! idx
+    idx            = tag - 1
+    meth_id = meth_ids !! idx
+    defm_id = defm_ids  !! idx
 
 makeInstanceDeclNoDefaultExpr
        :: InstOrigin s
 
 makeInstanceDeclNoDefaultExpr
        :: InstOrigin s
-       -> Class
        -> [TcIdOcc s]
        -> [Id]
        -> [TcIdOcc s]
        -> [Id]
-       -> FAST_STRING
        -> TcType s
        -> TcType s
+       -> Class
+       -> Module
        -> Int
        -> NF_TcM s (TcExpr s)
 
        -> Int
        -> NF_TcM s (TcExpr s)
 
-makeInstanceDeclNoDefaultExpr origin clas method_occs defm_ids inst_mod inst_ty tag
-  = let
-       (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType method_id)
-    in
-    newDicts origin op_theta           `thenNF_Tc` \ (op_lie,op_dicts) ->
-
+makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag
+  = 
        -- Produce a warning if the default instance method
        -- has been omitted when one exists in the class
     warnTc (not err_defm_ok)
           (omitDefaultMethodWarn clas_op clas_name inst_ty)
                                        `thenNF_Tc_`
        -- Produce a warning if the default instance method
        -- has been omitted when one exists in the class
     warnTc (not err_defm_ok)
           (omitDefaultMethodWarn clas_op clas_name inst_ty)
                                        `thenNF_Tc_`
-    returnNF_Tc (mkHsTyLam op_tyvars (
-                mkHsDictLam op_dicts (
-                HsApp (mkHsTyApp (HsVar (RealId pAT_ERROR_ID)) [op_tau])
-                    (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
+    returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id])
+                      (HsLitOut (HsString (_PK_ error_msg)) stringTy))
   where
   where
-    idx                   = tag - 1
-    method_occ     = method_occs  !! idx
-    clas_op        = (getClassOps clas) !! idx
-    defm_id        = defm_ids  !! idx
+    idx            = tag - 1
+    meth_id = meth_ids  !! idx
+    clas_op = (classOps clas) !! idx
+    defm_id = defm_ids  !! idx
 
 
-    TcId method_id = method_occ
     Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
 
     Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
 
-    error_msg = "%E"   -- => No explicit method for \"
-               ++ escErrorMsg error_str
-
-    error_str = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "."
+    error_msg = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "."
                ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
                ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
 
                ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
                ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
 
-    (_, clas_name) = getOrigName clas
+    clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas)
 \end{code}
 
 
 \end{code}
 
 
@@ -536,8 +527,8 @@ do differs between instance and class decls.
 
 \begin{code}
 processInstBinds
 
 \begin{code}
 processInstBinds
-       :: (Int -> NF_TcM s (TcExpr s))    -- Function to make default method
-       -> [TcTyVar s]                     -- Tyvars for this instance decl
+       :: Class
+       -> (Int -> NF_TcM s (TcExpr s))    -- Function to make default method
        -> LIE s                           -- available Insts
        -> [TcIdOcc s]                     -- Local method ids in tag order
                                           --   (instance tyvars are free in their types)
        -> LIE s                           -- available Insts
        -> [TcIdOcc s]                     -- Local method ids in tag order
                                           --   (instance tyvars are free in their types)
@@ -545,10 +536,10 @@ processInstBinds
        -> TcM s (LIE s,                   -- These are required
                  TcMonoBinds s)
 
        -> TcM s (LIE s,                   -- These are required
                  TcMonoBinds s)
 
-processInstBinds mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds
+processInstBinds clas mk_default_method_rhs avail_insts method_ids monobinds
   =
         -- Process the explicitly-given method bindings
   =
         -- Process the explicitly-given method bindings
-    processInstBinds1 inst_tyvars avail_insts method_ids monobinds
+    processInstBinds1 clas avail_insts method_ids monobinds
                        `thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
 
         -- Find the methods not handled, and make default method bindings for them.
                        `thenTc` \ (tags, insts_needed_in_methods, method_binds) ->
 
         -- Find the methods not handled, and make default method bindings for them.
@@ -569,7 +560,7 @@ processInstBinds mk_default_method_rhs inst_tyvars avail_insts method_ids monobi
 
 \begin{code}
 processInstBinds1
 
 \begin{code}
 processInstBinds1
-       :: [TcTyVar s]          -- Tyvars for this instance decl
+       :: Class
        -> LIE s                -- available Insts
        -> [TcIdOcc s]          -- Local method ids in tag order (instance tyvars are free),
        -> RenamedMonoBinds
        -> LIE s                -- available Insts
        -> [TcIdOcc s]          -- Local method ids in tag order (instance tyvars are free),
        -> RenamedMonoBinds
@@ -577,13 +568,13 @@ processInstBinds1
                  LIE s,        -- These are required
                  TcMonoBinds s)
 
                  LIE s,        -- These are required
                  TcMonoBinds s)
 
-processInstBinds1 inst_tyvars avail_insts method_ids EmptyMonoBinds
+processInstBinds1 clas avail_insts method_ids EmptyMonoBinds
   = returnTc ([], emptyLIE, EmptyMonoBinds)
 
   = returnTc ([], emptyLIE, EmptyMonoBinds)
 
-processInstBinds1 inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
-  = processInstBinds1 inst_tyvars avail_insts method_ids mb1
+processInstBinds1 clas avail_insts method_ids (AndMonoBinds mb1 mb2)
+  = processInstBinds1 clas avail_insts method_ids mb1
                                 `thenTc`       \ (op_tags1,dicts1,method_binds1) ->
                                 `thenTc`       \ (op_tags1,dicts1,method_binds1) ->
-    processInstBinds1 inst_tyvars avail_insts method_ids mb2
+    processInstBinds1 clas avail_insts method_ids mb2
                                 `thenTc`       \ (op_tags2,dicts2,method_binds2) ->
     returnTc (op_tags1 ++ op_tags2,
              dicts1 `unionBags` dicts2,
                                 `thenTc`       \ (op_tags2,dicts2,method_binds2) ->
     returnTc (op_tags1 ++ op_tags2,
              dicts1 `unionBags` dicts2,
@@ -591,7 +582,7 @@ processInstBinds1 inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}
-processInstBinds1 inst_tyvars avail_insts method_ids mbind
+processInstBinds1 clas avail_insts method_ids mbind
   =
     -- Find what class op is being defined here.  The complication is
     -- that we could have a PatMonoBind or a FunMonoBind.  If the
   =
     -- Find what class op is being defined here.  The complication is
     -- that we could have a PatMonoBind or a FunMonoBind.  If the
@@ -601,23 +592,26 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind
     -- Renamer has reduced us to these two cases.
     let
        (op,locn) = case mbind of
     -- Renamer has reduced us to these two cases.
     let
        (op,locn) = case mbind of
-                     FunMonoBind op _ locn            -> (op, locn)
+                     FunMonoBind op _ _ locn          -> (op, locn)
                      PatMonoBind (VarPatIn op) _ locn -> (op, locn)
 
                      PatMonoBind (VarPatIn op) _ locn -> (op, locn)
 
-        occ    = getOccurrenceName op
+        occ    = getLocalName op
        origin = InstanceDeclOrigin
     in
     tcAddSrcLoc locn                    $
 
     -- Make a method id for the method
        origin = InstanceDeclOrigin
     in
     tcAddSrcLoc locn                    $
 
     -- Make a method id for the method
-    let tag       = getTagFromClassOpName op
+    let
+       tag       = classOpTagByString clas occ
        method_id = method_ids !! (tag-1)
        method_id = method_ids !! (tag-1)
+       method_ty = tcIdType method_id
+    in
 
 
-       TcId method_bndr = method_id
-       method_ty = idType method_bndr
-       (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty
+    tcInstTcType method_ty             `thenNF_Tc` \ (method_tyvars, method_rho) ->
+    let
+       (method_theta, method_tau) = splitRhoTy method_rho
     in
     in
-    newDicts origin method_theta               `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
+    newDicts origin method_theta       `thenNF_Tc` \ (method_dicts,method_dict_ids) ->
 
     case (method_tyvars, method_dict_ids) of
 
 
     case (method_tyvars, method_dict_ids) of
 
@@ -625,12 +619,6 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind
 
                -- Type check the method itself
        tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 
                -- Type check the method itself
        tcMethodBind method_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
-
-               -- Make sure that the instance tyvars havn't been
-               -- unified with each other or with the method tyvars.
-       tcSetErrCtxt (methodSigCtxt op method_tau) (
-         checkSigTyVars inst_tyvars method_tau method_tau
-       )                                       `thenTc_`
        returnTc ([tag], lieIop, mbind')
 
       other -> -- It's a locally-polymorphic and/or overloaded method; UGH!
        returnTc ([tag], lieIop, mbind')
 
       other -> -- It's a locally-polymorphic and/or overloaded method; UGH!
@@ -640,21 +628,23 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind
                -- The latter is needed just so we can return an AbsBinds wrapped
                -- up inside a MonoBinds.
 
                -- The latter is needed just so we can return an AbsBinds wrapped
                -- up inside a MonoBinds.
 
-       newLocalIds [occ,occ] [method_tau,method_ty] `thenNF_Tc` \ new_ids ->
+
+               -- Make the method_tyvars into signature tyvars so they
+               -- won't get unified with anything.
+       tcInstSigTyVars method_tyvars           `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) ->
+       unifyTauTyLists sig_tyvar_tys (mkTyVarTys method_tyvars)        `thenTc_`
+
+       newLocalId occ method_tau               `thenNF_Tc` \ local_id ->
+       newLocalId occ method_ty                `thenNF_Tc` \ copy_id ->
        let
        let
-           [local_id, copy_id] = map TcId new_ids
-           inst_method_tyvars = inst_tyvars ++ method_tyvars
+           sig_tyvar_set = mkTyVarSet sig_tyvars
        in
                -- Typecheck the method
        tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 
        in
                -- Typecheck the method
        tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
 
-               -- Make sure that the instance tyvars haven't been
-               -- unified with each other or with the method tyvars.
-       tcAddErrCtxt (methodSigCtxt op method_tau) (
-         checkSigTyVars inst_method_tyvars method_tau method_tau
-       )                                       `thenTc_`
-
                -- Check the overloading part of the signature.
                -- Check the overloading part of the signature.
+
+       -- =========== POSSIBLE BUT NOT DONE =================
                -- Simplify everything fully, even though some
                -- constraints could "really" be left to the next
                -- level out. The case which forces this is
                -- Simplify everything fully, even though some
                -- constraints could "really" be left to the next
                -- level out. The case which forces this is
@@ -663,13 +653,23 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind
                --
                -- Here we must simplify constraints on "a" to catch all
                -- the Bar-ish things.
                --
                -- Here we must simplify constraints on "a" to catch all
                -- the Bar-ish things.
+
+               -- We don't do this because it's currently illegal Haskell (not sure why),
+               -- and because the local type of the method would have a context at
+               -- the front with no for-all, which confuses the hell out of everything!
+       -- ====================================================
+
        tcAddErrCtxt (methodSigCtxt op method_ty) (
        tcAddErrCtxt (methodSigCtxt op method_ty) (
+           checkSigTyVars
+               sig_tyvars method_tau                           `thenTc_`
+
          tcSimplifyAndCheck
          tcSimplifyAndCheck
-               (tyVarListToSet inst_method_tyvars)
+               sig_tyvar_set
                (method_dicts `plusLIE` avail_insts)
                lieIop
        )                                        `thenTc` \ (f_dicts, dict_binds) ->
 
                (method_dicts `plusLIE` avail_insts)
                lieIop
        )                                        `thenTc` \ (f_dicts, dict_binds) ->
 
+
        returnTc ([tag],
                  f_dicts,
                  VarMonoBind method_id
        returnTc ([tag],
                  f_dicts,
                  VarMonoBind method_id
@@ -687,9 +687,9 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind
 tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
             -> TcM s (TcMonoBinds s, LIE s)
 
 tcMethodBind :: TcIdOcc s -> TcType s -> RenamedMonoBinds
             -> TcM s (TcMonoBinds s, LIE s)
 
-tcMethodBind meth_id meth_ty (FunMonoBind name matches locn)
+tcMethodBind meth_id meth_ty (FunMonoBind name inf matches locn)
   = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
   = tcMatchesFun name meth_ty matches `thenTc` \ (rhs', lie) ->
-    returnTc (FunMonoBind meth_id rhs' locn, lie)
+    returnTc (FunMonoBind meth_id inf rhs' locn, lie)
 
 tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
   -- pat is sure to be a (VarPatIn op)
 
 tcMethodBind meth_id meth_ty pbind@(PatMonoBind pat grhss_and_binds locn)
   -- pat is sure to be a (VarPatIn op)
@@ -741,13 +741,13 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc
        clas = lookupCE ce class_name -- Renamer ensures this can't fail
 
        -- Make some new type variables, named as in the specialised instance type
        clas = lookupCE ce class_name -- Renamer ensures this can't fail
 
        -- Make some new type variables, named as in the specialised instance type
-       ty_names                          = extractMonoTyNames (==) ty
+       ty_names                          = extractMonoTyNames ???is_tyvarish_name??? ty
        (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
     in
     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
                                `thenTc` \ inst_ty ->
     let
        (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
     in
     babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
                                `thenTc` \ inst_ty ->
     let
-       maybe_tycon = case maybeDataTyCon inst_ty of
+       maybe_tycon = case maybeAppDataTyCon inst_ty of
                         Just (tc,_,_) -> Just tc
                         Nothing       -> Nothing
 
                         Just (tc,_,_) -> Just tc
                         Nothing       -> Nothing
 
@@ -772,16 +772,19 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc
 
        mk_spec_origin clas ty
          = InstanceSpecOrigin inst_mapper clas ty src_loc
 
        mk_spec_origin clas ty
          = InstanceSpecOrigin inst_mapper clas ty src_loc
+       -- I'm VERY SUSPICIOUS ABOUT THIS
+       -- the inst-mapper is in a knot at this point so it's no good
+       -- looking at it in tcSimplify...
     in
     tcSimplifyThetas mk_spec_origin subst_tv_theta
                                `thenTc` \ simpl_tv_theta ->
     let
        simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 
     in
     tcSimplifyThetas mk_spec_origin subst_tv_theta
                                `thenTc` \ simpl_tv_theta ->
     let
        simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ]
 
-       tv_tmpl_map = inst_tv_tys `zipEqual` inst_tmpl_tys
+       tv_tmpl_map   = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
        tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
     in
        tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
     in
-    mkInstanceRelatedIds e True{-from here-} mod NoInstancePragmas src_loc
+    mkInstanceRelatedIds e True{-from here-} src_loc mod NoInstancePragmas 
                         clas inst_tmpls inst_ty simpl_theta uprag
                                `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 
                         clas inst_tmpls inst_ty simpl_theta uprag
                                `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 
@@ -791,12 +794,12 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc
        (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
                          if null simpl_theta then ppNil else ppStr "=>",
                          ppr PprDebug clas,
        (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
                          if null simpl_theta then ppNil else ppStr "=>",
                          ppr PprDebug clas,
-                         pprParendType PprDebug inst_ty],
+                         pprParendGenType PprDebug inst_ty],
                   ppCat [ppStr "        derived from:",
                          if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
                          if null unspec_theta then ppNil else ppStr "=>",
                          ppr PprDebug clas,
                   ppCat [ppStr "        derived from:",
                          if null unspec_theta then ppNil else ppr PprDebug unspec_theta,
                          if null unspec_theta then ppNil else ppStr "=>",
                          ppr PprDebug clas,
-                         pprParendType PprDebug unspec_inst_ty]])
+                         pprParendGenType PprDebug unspec_inst_ty]])
     else id) (
 
     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
     else id) (
 
     returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
@@ -818,7 +821,7 @@ lookup_unspec_inst clas maybe_tycon inst_infos
                      Just tycon -> match_tycon tycon
                      Nothing    -> match_fun
 
                      Just tycon -> match_tycon tycon
                      Nothing    -> match_fun
 
-    match_tycon tycon inst_ty = case (maybeDataTyCon inst_ty) of
+    match_tycon tycon inst_ty = case (maybeAppDataTyCon inst_ty) of
          Just (inst_tc,_,_) -> tycon == inst_tc
          Nothing            -> False
 
          Just (inst_tc,_,_) -> tycon == inst_tc
          Nothing            -> False
 
@@ -826,7 +829,7 @@ lookup_unspec_inst clas maybe_tycon inst_infos
 
 
 is_plain_instance inst_ty
 
 
 is_plain_instance inst_ty
-  = case (maybeDataTyCon inst_ty) of
+  = case (maybeAppDataTyCon inst_ty) of
       Just (_,tys,_) -> all isTyVarTemplateTy tys
       Nothing       -> case maybeUnpackFunTy inst_ty of
                          Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
       Just (_,tys,_) -> all isTyVarTemplateTy tys
       Nothing       -> case maybeUnpackFunTy inst_ty of
                          Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
@@ -849,16 +852,15 @@ We can also have instances for functions: @instance Foo (a -> b) ...@.
 \begin{code}
 scrutiniseInstanceType from_here clas inst_tau
        -- TYCON CHECK
 \begin{code}
 scrutiniseInstanceType from_here clas inst_tau
        -- TYCON CHECK
-  | not (maybeToBool inst_tycon_maybe)
+  | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
   = failTc (instTypeErr inst_tau)
 
        -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
   = failTc (instTypeErr inst_tau)
 
        -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
-  | from_here
+  | not from_here
   = returnTc (inst_tycon,arg_tys)
 
        -- TYVARS CHECK
   | not (all isTyVarTy arg_tys ||
   = returnTc (inst_tycon,arg_tys)
 
        -- TYVARS CHECK
   | not (all isTyVarTy arg_tys ||
-         not from_here        ||
         opt_GlasgowExts)
   = failTc (instTypeErr inst_tau)
 
         opt_GlasgowExts)
   = failTc (instTypeErr inst_tau)
 
@@ -872,11 +874,12 @@ scrutiniseInstanceType from_here clas inst_tau
   = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
 
   |    -- CCALL CHECK
   = failTc (derivingWhenInstanceExistsErr clas inst_tycon)
 
   |    -- CCALL CHECK
-       -- A user declaration of a _CCallable/_CReturnable instance
+       -- A user declaration of a CCallable/CReturnable instance
        -- must be for a "boxed primitive" type.
     isCcallishClass clas
        -- must be for a "boxed primitive" type.
     isCcallishClass clas
-    && not opt_CompilingPrelude                -- which allows anything
-    && maybeToBool (maybeBoxedPrimType inst_tau)
+    && not (maybeToBool (maybeBoxedPrimType inst_tau)
+           || opt_CompilingGhcInternals) -- this lets us get up to mischief;
+                                    -- e.g., instance CCallable ()
   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 
   | otherwise
   = failTc (nonBoxedPrimCCallErr clas inst_tau)
 
   | otherwise
@@ -904,7 +907,9 @@ derivingWhenInstanceExistsErr clas tycon sty
 
 derivingWhenInstanceImportedErr inst_mod clas tycon sty
   = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
 
 derivingWhenInstanceImportedErr inst_mod clas tycon sty
   = ppHang (ppBesides [ppStr "Deriving class `", ppr sty clas, ppStr "' type `", ppr sty tycon, ppStr "'"])
-         4 (ppBesides [ppStr "when an instance declared in module `", ppPStr inst_mod, ppStr "' has been imported"])
+         4 (ppBesides [ppStr "when an instance declared in module `", pp_mod, ppStr "' has been imported"])
+  where
+    pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"]
 
 nonBoxedPrimCCallErr clas inst_ty sty
   = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
 
 nonBoxedPrimCCallErr clas inst_ty sty
   = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
@@ -914,7 +919,7 @@ nonBoxedPrimCCallErr clas inst_ty sty
 omitDefaultMethodWarn clas_op clas_name inst_ty sty
   = ppCat [ppStr "Warning: Omitted default method for",
           ppr sty clas_op, ppStr "in instance",
 omitDefaultMethodWarn clas_op clas_name inst_ty sty
   = ppCat [ppStr "Warning: Omitted default method for",
           ppr sty clas_op, ppStr "in instance",
-          ppPStr clas_name, pprParendType sty inst_ty]
+          ppPStr clas_name, pprParendGenType sty inst_ty]
 
 
 patMonoBindsCtxt pbind sty
 
 
 patMonoBindsCtxt pbind sty
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)