[project @ 2000-11-20 14:48:52 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 df2bbd4..841988d 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -1,69 +1,86 @@
 %
 %

-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998

 %
 \section[TcInstDecls]{Typechecking instance declarations}
 
 \begin{code}
 %
 \section[TcInstDecls]{Typechecking instance declarations}
 
 \begin{code}

+module TcInstDcls ( tcInstDecls1, tcInstDecls2, tcAddDeclCtxt ) where
+

 #include "HsVersions.h"
 
 #include "HsVersions.h"
 

-module TcInstDcls (
-       tcInstDecls1, tcInstDecls2,
-       tcSpecInstSigs,
-       buildInstanceEnvs, processInstBinds,
-       mkInstanceRelatedIds,
-       InstInfo(..)
-    ) where

 
 

-IMPORT_Trace           -- ToDo:rm debugging
-import Outputable
-import Pretty
+import CmdLineOpts     ( DynFlag(..), dopt )
+
+import HsSyn           ( HsDecl(..), InstDecl(..), TyClDecl(..), 
+                         MonoBinds(..), HsExpr(..),  HsLit(..), Sig(..), 
+                         andMonoBindList, collectMonoBinders, isClassDecl
+                       )
+import RnHsSyn         ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, RenamedMonoBinds,
+                         RenamedTyClDecl, RenamedHsType, 
+                         extractHsTyVars, maybeGenericMatch
+                       )
+import TcHsSyn         ( TcMonoBinds, mkHsConApp )
+import TcBinds         ( tcSpecSigs )
+import TcClassDcl      ( tcMethodBind, badMethodErr )
+import TcMonad       
+import Inst            ( InstOrigin(..),
+                         newDicts, newClassDicts,
+                         LIE, emptyLIE, plusLIE, plusLIEs )
+import TcDeriv         ( tcDeriving )
+import TcEnv           ( TcEnv, tcExtendGlobalValEnv, 
+                         tcExtendTyVarEnvForMeths, 
+                         tcAddImportedIdInfo, tcInstId, tcLookupClass,
+                         InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, 
+                         newDFunName, tcExtendTyVarEnv
+                       )
+import InstEnv         ( InstEnv, extendInstEnv )
+import TcMonoType      ( tcTyVars, tcHsSigType, kcHsSigType )
+import TcSimplify      ( tcSimplifyAndCheck )
+import TcType          ( zonkTcSigTyVars )
+import HscTypes                ( HomeSymbolTable, DFunId,
+                         ModDetails(..), PackageInstEnv, PersistentRenamerState
+                       )

 
 

-import TcMonad         -- typechecking monad machinery
-import TcMonadFns      ( newDicts, newMethod, newLocalWithGivenTy,
-                         newClassOpLocals, copyTyVars,
-                         applyTcSubstAndCollectTyVars
+import Bag             ( unionManyBags )
+import DataCon         ( classDataCon )
+import Class           ( Class, DefMeth(..), classBigSig )
+import Var             ( idName, idType )
+import Maybes          ( maybeToBool )
+import MkId            ( mkDictFunId )
+import Generics                ( validGenericInstanceType )
+import Module          ( Module, foldModuleEnv )
+import Name            ( getSrcLoc )
+import NameSet         ( emptyNameSet, nameSetToList )
+import PrelInfo                ( eRROR_ID )
+import PprType         ( pprConstraint, pprPred )
+import TyCon           ( TyCon, isSynTyCon )
+import Type            ( splitDFunTy, isTyVarTy,
+                         splitTyConApp_maybe, splitDictTy,
+                         splitForAllTys,
+                         tyVarsOfTypes, mkClassPred, mkTyVarTy,
+                         getClassTys_maybe

                        )
                        )

-import AbsSyn          -- the stuff being typechecked
-
-import AbsUniType
-import BackSubst       ( applyTcSubstToBinds )
-import Bag             ( emptyBag, unitBag, unionBags, bagToList )
-import CE              ( lookupCE, CE(..) )
-import CmdLineOpts     ( GlobalSwitch(..) )
-import GenSpecEtc      ( checkSigTyVars )
-import E               ( mkE, getE_CE, getE_TCE, growE_LVE, tvOfE, LVE(..), E )
-import Errors          ( dupInstErr, derivingWhenInstanceExistsErr,
-                         preludeInstanceErr, nonBoxedPrimCCallErr,
-                         specInstUnspecInstNotFoundErr,
-                         Error(..), UnifyErrContext(..)
+import Subst           ( mkTopTyVarSubst, substClasses )
+import VarSet          ( mkVarSet, varSetElems )
+import TysWiredIn      ( genericTyCons, isFFIArgumentTy, isFFIResultTy )
+import PrelNames       ( cCallableClassKey, cReturnableClassKey, hasKey )
+import Name             ( Name )
+import SrcLoc           ( SrcLoc )
+import VarSet           ( varSetElems )
+import Unique          ( Uniquable(..) )
+import BasicTypes      ( NewOrData(..), Fixity )
+import ErrUtils                ( dumpIfSet_dyn )
+import ListSetOps      ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, 
+                         assocElts, extendAssoc_C,
+                         equivClassesByUniq, minusList

                        )
                        )

-import HsPragmas       -- ****** NEED TO SEE CONSTRUCTORS ******
-import Id              -- lots of things
-import IdInfo          -- ditto
-import Inst            ( Inst, InstOrigin(..) )
-import InstEnv
-import Maybes          ( catMaybes, mkLookupFun, maybeToBool, Maybe(..) )
-import Name            ( getTagFromClassOpName )
-import NameTypes       ( fromPrelude )
-import LIE             ( nullLIE, mkLIE, unMkLIE, plusLIE, LIE )
-import ListSetOps      ( minusList )
-import TCE             ( TCE(..), UniqFM )
-import TVE             ( mkTVE, TVE(..) )
-import Spec            ( specTy )
-import TcContext       ( tcContext )
-import TcGRHSs         ( tcGRHSsAndBinds )
-import TcMatches       ( tcMatchesFun )
-import TcMonoType      ( tcInstanceType )
-import TcPragmas       ( tcDictFunPragmas, tcGenPragmas )
-import TcSimplify      ( tcSimplifyAndCheck, tcSimplifyThetas )
-import Unify           ( unifyTauTy )
-import Unique          ( cCallableClassKey, cReturnableClassKey )
-import Util
+import List             ( partition )
+import Outputable

 \end{code}
 
 Typechecking instance declarations is done in two passes. The first
 \end{code}
 
 Typechecking instance declarations is done in two passes. The first

-pass, made by @tcInstDecls1@,
-collects information to be used in the second pass.
+pass, made by @tcInstDecls1@, collects information to be used in the
+second pass.

 
 This pre-processed info includes the as-yet-unprocessed bindings
 inside the instance declaration.  These are type-checked in the second
 
 This pre-processed info includes the as-yet-unprocessed bindings
 inside the instance declaration.  These are type-checked in the second

@@ -71,33 +88,11 @@ pass, when the class-instance envs and GVE contain all the info from
 all the instance and value decls.  Indeed that's the reason we need
 two passes over the instance decls.
 
 all the instance and value decls.  Indeed that's the reason we need
 two passes over the instance decls.
 

-    instance c => k (t tvs) where b
-
-\begin{code}
-data InstInfo
-  = InstInfo
-      Class            -- Class, k
-      [TyVarTemplate]  -- Type variables, tvs
-      UniType          -- The type at which the class is being
-                       --   instantiated
-      ThetaType                -- inst_decl_theta: the original context from the
-                       --   instance declaration.  It constrains (some of)
-                       --   the TyVarTemplates above
-      ThetaType                -- dfun_theta: the inst_decl_theta, plus one
-                       --   element for each superclass; the "Mark
-                       --   Jones optimisation"
-      Id               -- The dfun id
-      [Id]             -- Constant methods (either all or none)
-      RenamedMonoBinds -- Bindings, b
-      Bool             -- True <=> local instance decl
-      FAST_STRING      -- Name of module where this instance was
-                       -- defined.
-      SrcLoc           -- Source location assoc'd with this instance's defn
-      [RenamedSig]     -- User pragmas recorded for generating specilaised instances
-\end{code}

 
 

+Here is the overall algorithm.
+Assume that we have an instance declaration

 
 

-Here is the overall algorithm. Assume that
+    instance c => k (t tvs) where b

 
 \begin{enumerate}
 \item
 
 \begin{enumerate}
 \item

@@ -156,294 +151,262 @@ Here, Bop1 \ldots Bopn bind the methods op1 \ldots opn,
 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 \end{enumerate}
 
 and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 \end{enumerate}
 

-\begin{code}
-tcInstDecls1 :: E -> CE -> TCE -> [RenamedInstDecl] -> NF_TcM (Bag InstInfo)

 
 

-tcInstDecls1 e ce tce [] = returnNF_Tc emptyBag
+%************************************************************************
+%*                                                                     *
+\subsection{Extracting instance decls}
+%*                                                                     *
+%************************************************************************
+
+Gather up the instance declarations from their various sources
+
+\begin{code}
+tcInstDecls1 :: PackageInstEnv
+            -> PersistentRenamerState  
+            -> HomeSymbolTable         -- Contains instances
+            -> TcEnv                   -- Contains IdInfo for dfun ids
+            -> (Name -> Maybe Fixity)  -- for deriving Show and Read
+            -> Module                  -- Module for deriving
+            -> [RenamedHsDecl]
+            -> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
+
+tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
+  = let
+       inst_decls = [inst_decl | InstD inst_decl <- decls]     
+       tycl_decls = [decl      | TyClD decl <- decls]
+       clas_decls = filter isClassDecl tycl_decls
+    in
+       -- (1) Do the ordinary instance declarations
+    mapNF_Tc (tcInstDecl1 mod unf_env) inst_decls      `thenNF_Tc` \ inst_infos ->
+
+       -- (2) Instances from generic class declarations
+    getGenericInstances mod clas_decls         `thenTc` \ generic_inst_info -> 
+
+       -- Next, construct the instance environment so far, consisting of
+       --      a) cached non-home-package InstEnv (gotten from pcs)    pcs_insts pcs
+       --      b) imported instance decls (not in the home package)    inst_env1
+       --      c) other modules in this package (gotten from hst)      inst_env2
+       --      d) local instance decls                                 inst_env3
+       --      e) generic instances                                    inst_env4
+       -- The result of (b) replaces the cached InstEnv in the PCS
+    let
+       (local_inst_info, imported_inst_info) = partition iLocal (concat inst_infos)

 
 

-tcInstDecls1 e ce tce (inst_decl : rest)
-  = tc_inst_1 inst_decl        `thenNF_Tc` \ infos1 ->
-    tcInstDecls1 e ce tce rest `thenNF_Tc` \ infos2 ->
-    returnNF_Tc (infos1 `unionBags` infos2)
+       imported_dfuns   = map (tcAddImportedIdInfo unf_env . iDFunId) 
+                              imported_inst_info
+       hst_dfuns        = foldModuleEnv ((++) . md_insts) [] hst
+    in
+    addInstDFuns inst_env0 imported_dfuns      `thenNF_Tc` \ inst_env1 ->
+    addInstDFuns inst_env1 hst_dfuns           `thenNF_Tc` \ inst_env2 ->
+    addInstInfos inst_env2 local_inst_info     `thenNF_Tc` \ inst_env3 ->
+    addInstInfos inst_env3 generic_inst_info   `thenNF_Tc` \ inst_env4 ->
+
+       -- (3) Compute instances from "deriving" clauses; 
+       --     note that we only do derivings for things in this module; 
+       --     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 prs mod inst_env4 get_fixity tycl_decls `thenTc` \ (deriv_inst_info, deriv_binds) ->
+    addInstInfos inst_env4 deriv_inst_info             `thenNF_Tc` \ final_inst_env ->
+
+    returnTc (inst_env1, 
+             final_inst_env, 
+             generic_inst_info ++ deriv_inst_info ++ local_inst_info,
+             deriv_binds)
+
+addInstInfos :: InstEnv -> [InstInfo] -> NF_TcM InstEnv
+addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos)
+
+addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv
+addInstDFuns dfuns infos
+  = getDOptsTc                         `thenTc` \ dflags ->
+    extendInstEnv dflags dfuns infos   `bind`   \ (inst_env', errs) ->
+    addErrsTc errs                     `thenNF_Tc_` 
+    returnTc inst_env'

   where
   where

-    tc_inst_1 (InstDecl context class_name ty binds from_here modname imod uprags pragmas src_loc)
-      =
-           -- Prime error recovery and substitution pruning
-       recoverTc emptyBag                      (
-       addSrcLocTc src_loc                     (
-
-       let
-           clas = lookupCE ce class_name -- Renamer ensures this can't fail
-
-           for_ccallable_or_creturnable
-             = class_name == cCallableClass || class_name == cReturnableClass
-             where
-              cCallableClass   = PreludeClass cCallableClassKey   bottom
-              cReturnableClass = PreludeClass cReturnableClassKey bottom
-              bottom           = panic "for_ccallable_etc"
-
-           -- Make some new type variables, named as in the instance type
-           ty_names            = extractMonoTyNames (==) ty
-           (tve,inst_tyvars,_) = mkTVE ty_names
-       in
-           -- Check the instance type, including its syntactic constraints
-       babyTcMtoTcM (tcInstanceType ce tce tve from_here src_loc ty)
-               `thenTc` \ inst_ty ->
-
-           -- DEAL WITH THE INSTANCE CONTEXT
-       babyTcMtoTcM (tcContext ce tce tve context) `thenTc` \ theta ->
-
-           -- SOME BORING AND TURGID CHECKING:
-       let
-           inst_for_function_type = isFunType inst_ty
-               -- sigh; it happens; must avoid tickling inst_tycon
-
-           inst_tycon_maybe = getUniDataTyCon_maybe inst_ty
-
-           inst_tycon = case inst_tycon_maybe of
-                          Just (xx,_,_) -> xx
-                          Nothing       -> panic "tcInstDecls1:inst_tycon"
-       in
-           -------------------------------------------------------------
-           -- It is illegal for a normal user's module to declare an
-           -- instance for a Prelude-class/Prelude-type instance:
-       checkTc (from_here                    -- really an inst decl in this module
-                && fromPreludeCore clas      -- prelude class
-                && (inst_for_function_type   -- prelude type
-                    || fromPreludeCore inst_tycon)
-                && not (fromPrelude modname) -- we aren't compiling a Prelude mod
-               )
-               (preludeInstanceErr clas inst_ty src_loc) `thenTc_`
-
-           -------------------------------------------------------------
-           -- It is obviously illegal to have an explicit instance
-           -- for something that we are also planning to `derive'.
-           -- Note that an instance decl coming in from outside
-           -- is probably just telling us about the derived instance
-           -- (ToDo: actually check, if possible), so we mustn't flag
-           -- it as an error.
-       checkTc (from_here
-                && not inst_for_function_type
-                && clas `derivedFor` inst_tycon)
-               (derivingWhenInstanceExistsErr clas inst_tycon) `thenTc_`
-
-           -------------------------------------------------------------
-           -- A user declaration of a _CCallable/_CReturnable instance
-           -- must be for a "boxed primitive" type.
-        getSwitchCheckerTc     `thenNF_Tc` \ sw_chkr ->
-       checkTc (for_ccallable_or_creturnable
-                && from_here                       -- instance defined here
-                && not (sw_chkr CompilingPrelude)  -- which allows anything
-                && (inst_for_function_type ||      -- a *function*??? hah!
-                 not (maybeToBool (maybeBoxedPrimType inst_ty))))   -- naughty, naughty
-               (nonBoxedPrimCCallErr clas inst_ty src_loc) `thenTc_`
-
-           -- END OF TURGIDITY; back to real fun
-           -------------------------------------------------------------
-
-       if (not inst_for_function_type && clas `derivedFor` inst_tycon) then
-           -- Don't use this InstDecl; tcDeriv will make the
-           -- InstInfo to be used in later processing.
-           returnTc emptyBag
-
-       else
-               -- Make the dfun id and constant-method ids
-           mkInstanceRelatedIds e
-                       from_here pragmas src_loc
-                       clas inst_tyvars inst_ty theta uprags
-                               `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
-
-           returnTc ( unitBag (
-             InstInfo clas inst_tyvars inst_ty theta
-                      dfun_theta dfun_id const_meth_ids 
-                      binds from_here modname src_loc uprags
-           ))
-       ))
-\end{code}
+    bind x f = f x

 
 

+\end{code} 

 
 

-Common bit of code shared with @tcDeriving@:

 \begin{code}
 \begin{code}

-mkInstanceRelatedIds e
-               from_here inst_pragmas locn
-               clas 
-               inst_tyvars inst_ty inst_decl_theta uprags
-  = getUniqueTc                        `thenNF_Tc` \ uniq -> 
-    let     
-       (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas
-
-       super_class_theta = super_classes `zip` (repeat inst_ty)
+tcInstDecl1 :: Module -> TcEnv -> RenamedInstDecl -> NF_TcM [InstInfo]
+-- Deal with a single instance declaration
+tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
+  =    -- Prime error recovery, set source location
+    recoverNF_Tc (returnNF_Tc [])      $
+    tcAddSrcLoc src_loc                        $
+
+       -- Type-check all the stuff before the "where"
+    tcHsSigType poly_ty                        `thenTc` \ poly_ty' ->
+    let
+       (tyvars, theta, clas, inst_tys) = splitDFunTy poly_ty'
+    in

 
 

+    (case maybe_dfun_name of
+       Nothing ->      -- A source-file instance declaration

 
 

-       dfun_theta = case inst_decl_theta of
+               -- Check for respectable instance type, and context
+               -- but only do this for non-imported instance decls.
+               -- Imported ones should have been checked already, and may indeed
+               -- contain something illegal in normal Haskell, notably
+               --      instance CCallable [Char] 
+           scrutiniseInstanceHead clas inst_tys                `thenNF_Tc_`
+           mapNF_Tc scrutiniseInstanceConstraint theta         `thenNF_Tc_`

 
 

-                       []    -> []     -- If inst_decl_theta is empty, then we don't
-                                       -- want to have any dict arguments, so that we can
-                                       -- expose the constant methods.
+               -- Make the dfun id and return it
+           newDFunName mod clas inst_tys src_loc               `thenNF_Tc` \ dfun_name ->
+           returnNF_Tc (True, dfun_name)

 
 

-                       other -> inst_decl_theta ++ super_class_theta
-                                       -- Otherwise we pass the superclass dictionaries to 
-                                       -- the dictionary function; the Mark Jones optimisation.
+       Just dfun_name ->       -- An interface-file instance declaration
+               -- Make the dfun id
+           returnNF_Tc (False, dfun_name)
+    )                                          `thenNF_Tc` \ (is_local, dfun_name) ->

 
 

-       dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
+    let
+       dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta

     in
     in

-    fixNF_Tc ( \ rec_dfun_id ->
-       babyTcMtoNF_TcM (
-           tcDictFunPragmas e dfun_ty rec_dfun_id inst_pragmas
-       )                       `thenNF_Tc` \ dfun_id_info ->
-
-       returnNF_Tc (mkDictFunId uniq clas inst_ty dfun_ty from_here dfun_id_info)
-    ) `thenNF_Tc` \ dfun_id ->
-
-       -- Make the constant-method ids, if there are no type variables involved
-    (if not (null inst_tyvars) -- ToDo: could also do this if theta is null...
-     then
-       returnNF_Tc []
-     else
-       let
-           inline_mes = [ getTagFromClassOpName v | (InlineSig v _ _) <- uprags ]
-
-            mk_const_meth op uniq
-              = mkConstMethodId 
-                        uniq
-                        clas op inst_ty
-                        meth_ty from_here info
-              where
-               is_elem = isIn "mkInstanceRelatedIds"
-
-               info    = if tag `is_elem` inline_mes
-                         then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways)
-                         else noIdInfo
-
-                tenv    = [(class_tyvar, inst_ty)]
-               tag     = getClassOpTag op
-                op_ty   = getClassOpLocalType op
-                meth_ty = instantiateTy tenv op_ty
-                          -- If you move to a null-theta version, you need a 
-                          -- mkForallTy inst_tyvars here
-
-           mk_constm_w_info (op, u, (name, prags)) -- ToDo: chk name?
-             = fixNF_Tc ( \ rec_constm_id ->
-
-                   babyTcMtoNF_TcM (tcGenPragmas e (Just meth_ty) rec_constm_id prags)
-                               `thenNF_Tc` \ id_info ->
-
-                   returnNF_Tc (mkConstMethodId u clas op inst_ty meth_ty
-                                       from_here id_info)
-               )
-             where
-               tenv    = [(class_tyvar, inst_ty)]
-               op_ty   = getClassOpLocalType op
-               meth_ty = instantiateTy tenv op_ty
-
-       in
-       getUniquesTc (length class_ops) `thenNF_Tc` \ constm_uniqs ->
-       (case inst_pragmas of
-          ConstantInstancePragma _ name_pragma_pairs ->
-            mapNF_Tc mk_constm_w_info (zip3 class_ops constm_uniqs name_pragma_pairs)
-
-          other_inst_pragmas ->
-            returnNF_Tc (zipWith mk_const_meth class_ops constm_uniqs)
-       )
-    )          `thenNF_Tc` \ const_meth_ids ->
-
-    returnTc (dfun_id, dfun_theta, const_meth_ids)
+    returnTc [InstInfo { iLocal = is_local, iDFunId = dfun_id, 
+                        iBinds = binds,    iPrags = uprags }]

 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *

-\subsection{Converting instance info into suitable InstEnvs}
+\subsection{Extracting generic instance declaration from class declarations}

 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-\begin{code}
-buildInstanceEnvs :: Bag InstInfo 
-                 -> TcM InstanceMapper
+@getGenericInstances@ extracts the generic instance declarations from a class
+declaration.  For exmaple

 
 

-buildInstanceEnvs info
-  = let
-       cmp :: InstInfo -> InstInfo -> TAG_
-       (InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `cmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
-         = if c1 == c2 then EQ_ else if c1 < c2 then LT_ else GT_
+       class C a where
+         op :: a -> a
+       
+         op{ x+y } (Inl v)   = ...
+         op{ x+y } (Inr v)   = ...
+         op{ x*y } (v :*: w) = ...
+         op{ 1   } Unit      = ...

 
 

-       info_by_class = equivClasses cmp (bagToList info)
-    in
-    mapTc buildInstanceEnv info_by_class    `thenTc` \ inst_env_entries ->
-    let
-       class_lookup_maybe_fn
-           :: Class
-           -> Maybe (ClassInstEnv, (ClassOp -> SpecEnv))
-       class_lookup_fn
-           :: InstanceMapper
-
-       class_lookup_maybe_fn = mkLookupFun (==) inst_env_entries
-
-       class_lookup_fn c
-         = case class_lookup_maybe_fn c of
-             Nothing -> (nullMEnv, \ o -> nullSpecEnv)
-             Just xx -> xx
-    in
-    returnTc class_lookup_fn
-\end{code}
+gives rise to the instance declarations

 
 

-\begin{code}
-buildInstanceEnv :: [InstInfo]         -- Non-empty, and all for same class
-                -> TcM (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
+       instance C (x+y) where
+         op (Inl v)   = ...
+         op (Inr v)   = ...
+       
+       instance C (x*y) where
+         op (v :*: w) = ...

 
 

-buildInstanceEnv inst_infos@(info_for_one@(InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : rest)
-  = let
-       ops       = getClassOps clas
-       no_of_ops = length ops
+       instance C 1 where
+         op Unit      = ...
+
+
+\begin{code}
+getGenericInstances :: Module -> [RenamedTyClDecl] -> TcM [InstInfo] 
+getGenericInstances mod class_decls
+  = mapTc (get_generics mod) class_decls               `thenTc` \ gen_inst_infos ->
+    let
+       gen_inst_info = concat gen_inst_infos

     in
     in

-    foldlTc addClassInstance
-           (nullMEnv, nOfThem no_of_ops nullSpecEnv)
-           inst_infos      `thenTc` \ (class_inst_env, op_inst_envs) ->
+    getDOptsTc                                         `thenTc`  \ dflags ->
+    ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" 
+                     (vcat (map pprInstInfo gen_inst_info)))   
+                                                       `thenNF_Tc_`
+    returnTc gen_inst_info
+
+get_generics mod decl@(ClassDecl context class_name tyvar_names 
+                                fundeps class_sigs def_methods
+                                name_list loc)
+  | null groups                
+  = returnTc [] -- The comon case: 
+               --      no generic default methods, or
+               --      its an imported class decl (=> has no methods at all)
+
+  | otherwise  -- A local class decl with generic default methods
+  = recoverNF_Tc (returnNF_Tc [])                              $
+    tcAddDeclCtxt decl                                         $
+    tcLookupClass class_name                                   `thenTc` \ clas ->
+
+       -- Make an InstInfo out of each group
+    mapTc (mkGenericInstance mod clas loc) groups              `thenTc` \ inst_infos ->
+
+       -- Check that there is only one InstInfo for each type constructor
+       -- The main way this can fail is if you write
+       --      f {| a+b |} ... = ...
+       --      f {| x+y |} ... = ...
+       -- Then at this point we'll have an InstInfo for each

     let
     let

-       class_op_maybe_fn :: ClassOp -> Maybe SpecEnv
-       class_op_fn       :: ClassOp -> SpecEnv
-
-       class_op_maybe_fn = mkLookupFun (==) (ops `zip` op_inst_envs)
-                       -- They compare by ClassOp tags
-       class_op_fn op
-         = case class_op_maybe_fn op of
-             Nothing -> nullSpecEnv
-             Just xx -> xx
+       tc_inst_infos :: [(TyCon, InstInfo)]
+       tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
+
+       bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
+                             length group > 1]
+       get_uniq (tc,_) = getUnique tc

     in
     in

-    returnTc (clas, (class_inst_env, class_op_fn))
-\end{code}
+    mapTc (addErrTc . dupGenericInsts) bad_groups      `thenTc_`

 
 

-\begin{code}
-addClassInstance
-    :: (ClassInstEnv, [SpecEnv])
-    -> InstInfo
-    -> TcM (ClassInstEnv, [SpecEnv])   -- One SpecEnv for each class op
-
-addClassInstance
-    (class_inst_env, op_spec_envs) 
-    (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta dfun_id const_meth_ids _ _ _ src_loc _)
-  =    -- Insert into the class_inst_env first
-    checkMaybeErrTc (addClassInst clas class_inst_env inst_ty dfun_id inst_tyvars dfun_theta src_loc)
-                   dupInstErr          `thenTc` \ class_inst_env' ->
-    let 
-        -- Adding the classop instances can't fail if the class instance itself didn't
-        op_spec_envs' = case const_meth_ids of
-                          []    -> op_spec_envs
-                          other -> zipWith add_const_meth op_spec_envs const_meth_ids
+       -- Check that there is an InstInfo for each generic type constructor
+    let
+       missing = genericTyCons `minusList` [tc | (tc,_) <- tc_inst_infos]

     in
     in

-    returnTc (class_inst_env', op_spec_envs')
+    checkTc (null missing) (missingGenericInstances missing)   `thenTc_`
+
+    returnTc inst_infos
+

   where
   where

-    add_const_meth spec_env meth_id
-      = addOneToSpecEnv spec_env (SpecInfo (Just inst_ty:nothings) 1 meth_id)
-      where
-       (const_meth_tyvars,_) = splitForalls (getIdUniType meth_id)
-       nothings = [Nothing | _ <- const_meth_tyvars]
-       -- This only works if the constant method id only has its local polymorphism.
-       -- If you want to have constant methods for
-       --                              instance Foo (a,b,c) where
-       --                                      op x = ...
-       -- then the constant method will be polymorphic in a,b,c, and
-       -- the SpecInfo will need to be elaborated.
+       -- Group the declarations by type pattern
+       groups :: [(RenamedHsType, RenamedMonoBinds)]
+       groups = assocElts (getGenericBinds def_methods)
+
+
+---------------------------------
+getGenericBinds :: RenamedMonoBinds -> Assoc RenamedHsType RenamedMonoBinds
+  -- Takes a group of method bindings, finds the generic ones, and returns
+  -- them in finite map indexed by the type parameter in the definition.
+
+getGenericBinds EmptyMonoBinds    = emptyAssoc
+getGenericBinds (AndMonoBinds m1 m2) 
+  = plusAssoc_C AndMonoBinds (getGenericBinds m1) (getGenericBinds m2)
+
+getGenericBinds (FunMonoBind id infixop matches loc)
+  = mapAssoc wrap (foldl add emptyAssoc matches)
+       -- Using foldl not foldr is vital, else
+       -- we reverse the order of the bindings!
+  where
+    add env match = case maybeGenericMatch match of
+                     Nothing           -> env
+                     Just (ty, match') -> extendAssoc_C (++) env (ty, [match'])
+
+    wrap ms = FunMonoBind id infixop ms loc
+
+---------------------------------
+mkGenericInstance :: Module -> Class -> SrcLoc
+                 -> (RenamedHsType, RenamedMonoBinds)
+                 -> TcM InstInfo
+
+mkGenericInstance mod clas loc (hs_ty, binds)
+  -- Make a generic instance declaration
+  -- For example:      instance (C a, C b) => C (a+b) where { binds }
+
+  =    -- Extract the universally quantified type variables
+    tcTyVars (nameSetToList (extractHsTyVars hs_ty)) 
+            (kcHsSigType hs_ty)                `thenTc` \ tyvars ->
+    tcExtendTyVarEnv tyvars                                    $
+
+       -- Type-check the instance type, and check its form
+    tcHsSigType hs_ty                          `thenTc` \ inst_ty ->
+    checkTc (validGenericInstanceType inst_ty)
+           (badGenericInstanceType binds)      `thenTc_`
+
+       -- Make the dictionary function.
+    newDFunName mod clas [inst_ty] loc         `thenNF_Tc` \ dfun_name ->
+    let
+       inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
+       inst_tys   = [inst_ty]
+       dfun_id    = mkDictFunId dfun_name clas tyvars inst_tys inst_theta
+    in
+
+    returnTc (InstInfo { iLocal = True, iDFunId = dfun_id, 
+                        iBinds = binds, iPrags = [] })

 \end{code}
 
 
 \end{code}
 
 

@@ -454,30 +417,23 @@ addClassInstance
 %************************************************************************
 
 \begin{code}
 %************************************************************************
 
 \begin{code}

-tcInstDecls2 :: E 
-            -> Bag InstInfo
-            -> NF_TcM (LIE, TypecheckedBinds)
-
-tcInstDecls2 e inst_decls 
-  = let
-       -- Get type variables free in environment. Sadly, there may be
-       -- some, because of the dreaded monomorphism restriction
-       free_tyvars = tvOfE e
-    in
-    tcInstDecls2_help e free_tyvars (bagToList inst_decls)
-
-tcInstDecls2_help e free_tyvars [] = returnNF_Tc (nullLIE, EmptyBinds)
+tcInstDecls2 :: [InstInfo]
+            -> NF_TcM (LIE, TcMonoBinds)

 
 

-tcInstDecls2_help e free_tyvars (inst_decl:inst_decls)
- = tcInstDecl2       e free_tyvars inst_decl   `thenNF_Tc` \ (lie1, binds1) ->
-   tcInstDecls2_help e free_tyvars inst_decls  `thenNF_Tc` \ (lie2, binds2) ->
-   returnNF_Tc (lie1 `plusLIE` lie2, binds1 `ThenBinds` binds2)
+tcInstDecls2 inst_decls
+--  = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls
+  = foldr combine (returnNF_Tc (emptyLIE, EmptyMonoBinds)) 
+          (map tcInstDecl2 inst_decls)
+  where
+    combine tc1 tc2 = tc1      `thenNF_Tc` \ (lie1, binds1) ->
+                     tc2       `thenNF_Tc` \ (lie2, binds2) ->
+                     returnNF_Tc (lie1 `plusLIE` lie2,
+                                  binds1 `AndMonoBinds` binds2)

 \end{code}
 
 \end{code}
 

-

 ======= New documentation starts here (Sept 92)         ==============
 
 ======= New documentation starts here (Sept 92)         ==============
 

-The main purpose of @tcInstDecl2@ is to return a @Binds@ which defines
+The main purpose of @tcInstDecl2@ is to return a @HsBinds@ which defines

 the dictionary function for this instance declaration. For example
 \begin{verbatim}
        instance Foo a => Foo [a] where
 the dictionary function for this instance declaration. For example
 \begin{verbatim}
        instance Foo a => Foo [a] where

@@ -492,41 +448,40 @@ might generate something like
                                   Dict [op1, op2]
 \end{verbatim}
 
                                   Dict [op1, op2]
 \end{verbatim}
 

-HOWEVER, if the instance decl has no type variables, then it returns a
-bigger @Binds@ with declarations for each method.  For example
+HOWEVER, if the instance decl has no context, then it returns a
+bigger @HsBinds@ with declarations for each method.  For example

 \begin{verbatim}
 \begin{verbatim}

-       instance Foo Int where
+       instance Foo [a] where

                op1 x = ...
                op2 y = ...
 \end{verbatim}
 might produce
 \begin{verbatim}
                op1 x = ...
                op2 y = ...
 \end{verbatim}
 might produce
 \begin{verbatim}

-       dfun.Foo.Int = Dict [Foo.op1.Int, Foo.op2.Int]
-       Foo.op1.Int x = ...
-       Foo.op2.Int y = ...
+       dfun.Foo.List a = Dict [Foo.op1.List a, Foo.op2.List a]
+       const.Foo.op1.List a x = ...
+       const.Foo.op2.List a y = ...

 \end{verbatim}
 This group may be mutually recursive, because (for example) there may
 be no method supplied for op2 in which case we'll get
 \begin{verbatim}
 \end{verbatim}
 This group may be mutually recursive, because (for example) there may
 be no method supplied for op2 in which case we'll get
 \begin{verbatim}

-       Foo.op2.Int = default.Foo.op2 dfun.Foo.Int
+       const.Foo.op2.List a = default.Foo.op2 (dfun.Foo.List a)

 \end{verbatim}
 that is, the default method applied to the dictionary at this type.
 
 \end{verbatim}
 that is, the default method applied to the dictionary at this type.
 

-\begin{code}
-tcInstDecl2 :: E
-           -> [TyVar]          -- Free in the environment
-           -> InstInfo 
-           -> NF_TcM (LIE, TypecheckedBinds)
-\end{code}
+What we actually produce in either case is:

 
 

-First comes the easy case of a non-local instance decl.
+       AbsBinds [a] [dfun_theta_dicts]
+                [(dfun.Foo.List, d)] ++ (maybe) [(const.Foo.op1.List, op1), ...]
+                { d = (sd1,sd2, ..., op1, op2, ...)
+                  op1 = ...
+                  op2 = ...
+                }

 
 

-\begin{code}
-tcInstDecl2 e free_tyvars (InstInfo _ _ _ _ _ _ _ _ False{-not this module-} _ _ _)
-  = returnNF_Tc (nullLIE, EmptyBinds)
-\end{code}
+The "maybe" says that we only ask AbsBinds to make global constant methods
+if the dfun_theta is empty.

 
 

-Now the case of a general local instance.  For an instance declaration, say,
+               
+For an instance declaration, say,

 
        instance (C1 a, C2 b) => C (T a b) where
                ...
 
        instance (C1 a, C2 b) => C (T a b) where
                ...

@@ -540,540 +495,295 @@ Notice that we pass it the superclass dictionaries at the instance type; this
 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 is the @dfun_theta@ below.
 
 is the ``Mark Jones optimisation''.  The stuff before the "=>" here
 is the @dfun_theta@ below.
 

-\begin{code}
-tcInstDecl2
-    e free_tyvars 
-    (InstInfo clas template_tyvars inst_ty_tmpl inst_decl_theta dfun_theta
-             dfun_id const_meth_ids monobinds True{-from here-} _ locn _)
-  = let
-       origin = InstanceDeclOrigin locn
-    in
-    recoverTc (nullLIE, EmptyBinds)    (
-    addSrcLocTc locn                   (
-    pruneSubstTc free_tyvars           (
-
-       -- Get the class signature
-    let (class_tyvar, 
-        super_classes, sc_sel_ids,
-        class_ops, op_sel_ids, defm_ids) = getClassBigSig clas
-    in
-        -- Prime error recovery and substitution pruning. Instantiate
-        -- dictionaries from the specified instance context. These
-        -- dicts will be passed into the dictionary-construction
-        -- function.
-    copyTyVars template_tyvars `thenNF_Tc` \ (inst_env, inst_tyvars, inst_tyvar_tys) ->
-    let 
-       inst_ty          = instantiateTy inst_env inst_ty_tmpl
-
-       inst_decl_theta' = instantiateThetaTy inst_env inst_decl_theta
-       dfun_theta'      = instantiateThetaTy inst_env dfun_theta
-       sc_theta'        = super_classes `zip` (repeat inst_ty)
-    in
-    newDicts origin sc_theta'                  `thenNF_Tc` \ sc_dicts' ->
-    newDicts origin dfun_theta'                        `thenNF_Tc` \ dfun_arg_dicts' ->
-    newDicts origin inst_decl_theta'           `thenNF_Tc` \ inst_decl_dicts' ->
-    let
-       sc_dicts'_ids        = map mkInstId sc_dicts'
-       dfun_arg_dicts'_ids = map mkInstId dfun_arg_dicts'
-    in
-       -- Instantiate the dictionary being constructed 
-       -- and the dictionary-construction function
-    newDicts origin [(clas,inst_ty)]           `thenNF_Tc` \ [this_dict] ->
-    let
-       this_dict_id = mkInstId this_dict
-    in
-        -- Instantiate method variables
-    listNF_Tc [ newMethodId sel_id inst_ty origin locn
-             | sel_id <- op_sel_ids
-             ]                                 `thenNF_Tc` \ method_ids ->
-    let 
-       method_insts = catMaybes (map isInstId_maybe method_ids)
-       -- Extract Insts from those method ids which have them (most do)
-       -- See notes on newMethodId
-    in
-        -- Collect available dictionaries
-    let avail_insts =   -- These insts are in scope; quite a few, eh?
-           [this_dict]         ++
-           method_insts        ++
-           dfun_arg_dicts'
-    in
-    processInstBinds e free_tyvars
-        (makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty)
-        inst_tyvars avail_insts method_ids monobinds
-                                        `thenTc` \ (insts_needed, method_mbinds) ->
-        -- Complete the binding group
-    let this_dict_bind
-           = VarMonoBind this_dict_id (Dictionary sc_dicts'_ids method_ids)
-       dict_and_method_binds
-           = this_dict_bind `AndMonoBinds` method_mbinds
-    in
-       -- Check the overloading constraints of the methods and superclasses
-       -- The global tyvars must be a fixed point of the substitution
-    applyTcSubstAndCollectTyVars free_tyvars  `thenNF_Tc` \ real_free_tyvars ->
-    tcSimplifyAndCheck
-                True                           -- Top level
-                real_free_tyvars               -- Global tyvars
-                inst_tyvars                    -- Local tyvars
-                avail_insts
-                (sc_dicts' ++ insts_needed)    -- Need to get defns for all these
-                (BindSigCtxt method_ids)
-                                        `thenTc` \ (const_insts, super_binds) ->
-
-       -- Check that we *could* construct the superclass dictionaries,
-       -- even though we are *actually* going to pass the superclass dicts in;
-       -- the check ensures that the caller will never have a problem building
-       -- them.
-    tcSimplifyAndCheck
-                False                          -- Doesn't matter; more efficient this way
-                real_free_tyvars               -- Global tyvars
-                inst_tyvars                    -- Local tyvars
-                inst_decl_dicts'               -- The instance dictionaries available
-                sc_dicts'                      -- The superclass dicationaries reqd
-                SuperClassSigCtxt
-                                                `thenTc_`
-                                               -- Ignore the result; we're only doing
-                                               -- this to make sure it can be done.
-   
-       -- Create the dictionary function binding itself
-    let inst_binds
-         = AbsBinds 
-                inst_tyvars
-                dfun_arg_dicts'_ids
-                ((this_dict_id,dfun_id) : (method_ids `zip` const_meth_ids))
-                       -- const_meth_ids will often be empty
-                super_binds
-                (RecBind dict_and_method_binds)
-    in
-
-        -- Back-substitute
-    applyTcSubstToBinds inst_binds `thenNF_Tc` \ final_inst_binds ->
-
-    returnTc (mkLIE const_insts, final_inst_binds)
-    )))
-\end{code}
+First comes the easy case of a non-local instance decl.

 
 

-@mkMethodId@ manufactures an id for a local method.
-It's rather turgid stuff, because there are two cases:
+\begin{code}
+tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds)

 
 

-  (a) For methods with no local polymorphism, we can make an Inst of the 
-      class-op selector function and a corresp InstId; 
-      which is good because then other methods which call
-      this one will do so directly.
+tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id, 
+                       iBinds = monobinds, iPrags = uprags })
+  | not is_local
+  = returnNF_Tc (emptyLIE, EmptyMonoBinds)

 
 

-  (b) For methods with local polymorphism, we can't do this.  For example,
+  | otherwise
+  =     -- Prime error recovery
+    recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))  $
+    tcAddSrcLoc (getSrcLoc dfun_id)                       $

 
 

-        class Foo a where
-               op :: (Num b) => a -> b -> a
+       -- Instantiate the instance decl with tc-style type variables
+    tcInstId dfun_id           `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->
+    let
+       (clas, inst_tys') = splitDictTy dict_ty'
+       origin            = InstanceDeclOrigin

 
 

-      Here the type of the class-op-selector is
+        (class_tyvars, sc_theta, _, op_items) = classBigSig clas

 
 

-       forall a b. (Foo a, Num b) => a -> b -> a
+       dm_ids    = [dm_id | (_, DefMeth dm_id) <- op_items]
+       sel_names = [idName sel_id | (sel_id, _) <- op_items]

 
 

-      The locally defined method at (say) type Float will have type
+        -- Instantiate the super-class context with inst_tys
+       sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta

 
 

-       forall b. (Num b) => Float -> b -> Float
+       -- Find any definitions in monobinds that aren't from the class
+       bad_bndrs = collectMonoBinders monobinds `minusList` sel_names

 
 

-      and the one is not an instance of the other.
+       -- The type variable from the dict fun actually scope 
+       -- over the bindings.  They were gotten from
+       -- the original instance declaration
+       (inst_tyvars, _) = splitForAllTys (idType dfun_id)
+    in
+        -- Check that all the method bindings come from this class
+    mapTc (addErrTc . badMethodErr clas) bad_bndrs             `thenNF_Tc_`
+
+        -- Create dictionary Ids from the specified instance contexts.
+    newClassDicts origin sc_theta'             `thenNF_Tc` \ (sc_dicts,        sc_dict_ids) ->
+    newDicts origin dfun_theta'                        `thenNF_Tc` \ (dfun_arg_dicts,  dfun_arg_dicts_ids)  ->
+    newClassDicts origin [(clas,inst_tys')]    `thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
+
+    tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
+       tcExtendGlobalValEnv dm_ids (
+               -- Default-method Ids may be mentioned in synthesised RHSs 
+
+       mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys'
+                                    dfun_theta'
+                                    monobinds uprags True)
+                      op_items
+    ))                 `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
+
+       -- Deal with SPECIALISE instance pragmas by making them
+       -- look like SPECIALISE pragmas for the dfun
+    let
+       dfun_prags = [SpecSig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
+    in
+    tcExtendGlobalValEnv [dfun_id] (
+       tcSpecSigs dfun_prags
+    )                                  `thenTc` \ (prag_binds, prag_lie) ->

 
 

-      So for these we just make a local (non-Inst) id with a suitable type.
+       -- Check the overloading constraints of the methods and superclasses

 
 

-How disgusting.
+       -- tcMethodBind has checked that the class_tyvars havn't
+       -- been unified with each other or another type, but we must
+       -- still zonk them before passing them to tcSimplifyAndCheck
+    zonkTcSigTyVars inst_tyvars'       `thenNF_Tc` \ zonked_inst_tyvars ->
+    let
+        inst_tyvars_set = mkVarSet zonked_inst_tyvars

 
 

-\begin{code}
-newMethodId sel_id inst_ty origin loc
-  = let (sel_tyvars,sel_theta,sel_tau) = splitType (getIdUniType sel_id)
-       (_:meth_theta) = sel_theta      -- The local theta is all except the
-                                       -- first element of the context
-    in 
-       case sel_tyvars of
-       -- Ah! a selector for a class op with no local polymorphism
-       -- Build an Inst for this
-       [clas_tyvar] -> newMethod origin sel_id [inst_ty]       `thenNF_Tc` \ inst ->
-                       returnNF_Tc (mkInstId inst)
-
-       -- Ho! a selector for a class op with local polymorphism.
-       -- Just make a suitably typed local id for this
-       (clas_tyvar:local_tyvars) -> 
-               let
-                   method_ty = instantiateTy [(clas_tyvar,inst_ty)]
-                                   (mkSigmaTy local_tyvars meth_theta sel_tau)
-               in
-               getUniqueTc             `thenNF_Tc` \ uniq -> 
-               returnNF_Tc (mkUserLocal (getOccurrenceName sel_id) uniq method_ty loc)
-\end{code}
+       (meth_lies, meth_ids) = unzip meth_lies_w_ids

 
 

-This function makes a default method which calls the global default method, at
-the appropriate instance type.
+                -- These insts are in scope; quite a few, eh?
+       avail_insts = this_dict                 `plusLIE` 
+                     dfun_arg_dicts            `plusLIE`
+                     sc_dicts                  `plusLIE`
+                     unionManyBags meth_lies

 
 

-See the notes under default decls in TcClassDcl.lhs.
+        methods_lie = plusLIEs insts_needed_s
+    in

 
 

-\begin{code}
-makeInstanceDeclDefaultMethodExpr
-       :: InstOrigin
-       -> Id
-       -> [ClassOp]
-       -> [Id]
-       -> UniType
-       -> Int
-       -> NF_TcM TypecheckedExpr
+       -- Simplify the constraints from methods
+    tcAddErrCtxt methodCtxt (
+      tcSimplifyAndCheck
+                (ptext SLIT("instance declaration context"))
+                inst_tyvars_set                        -- Local tyvars
+                avail_insts
+                methods_lie
+    )                                           `thenTc` \ (const_lie1, lie_binds1) ->
+    
+       -- Figure out bindings for the superclass context
+    tcAddErrCtxt superClassCtxt (
+      tcSimplifyAndCheck
+                (ptext SLIT("instance declaration context"))
+                inst_tyvars_set
+                dfun_arg_dicts         -- NB! Don't include this_dict here, else the sc_dicts
+                                       -- get bound by just selecting from this_dict!!
+                sc_dicts
+    )                                           `thenTc` \ (const_lie2, lie_binds2) ->

        
        

-makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty tag
-  = let
-       (tyvar_tmpls, local_theta, _) = splitType (getClassOpLocalType class_op)
-    in
-    copyTyVars tyvar_tmpls     `thenNF_Tc` \ (inst_env, tyvars, tys) ->
-    let
-       inst_theta = instantiateThetaTy inst_env local_theta
-    in
-    newDicts origin inst_theta `thenNF_Tc` \ local_dict_insts ->
+
+       -- Create the result bindings

     let
     let

-       local_dicts = map mkInstId local_dict_insts
+        dict_constr   = classDataCon clas
+       scs_and_meths = sc_dict_ids ++ meth_ids
+
+       dict_rhs
+         | null scs_and_meths
+         =     -- Blatant special case for CCallable, CReturnable
+               -- If the dictionary is empty then we should never
+               -- select anything from it, so we make its RHS just
+               -- emit an error message.  This in turn means that we don't
+               -- mention the constructor, which doesn't exist for CCallable, CReturnable
+               -- Hardly beautiful, but only three extra lines.
+           HsApp (TyApp (HsVar eRROR_ID) [idType this_dict_id])
+                 (HsLit (HsString msg))
+
+         | otherwise   -- The common case
+         = mkHsConApp dict_constr inst_tys' (map HsVar (sc_dict_ids ++ meth_ids))
+               -- We don't produce a binding for the dict_constr; instead we
+               -- rely on the simplifier to unfold this saturated application
+               -- We do this rather than generate an HsCon directly, because
+               -- it means that the special cases (e.g. dictionary with only one
+               -- member) are dealt with by the common MkId.mkDataConWrapId code rather
+               -- than needing to be repeated here.
+
+         where
+           msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))
+
+       dict_bind    = VarMonoBind this_dict_id dict_rhs
+       method_binds = andMonoBindList method_binds_s
+
+       main_bind
+         = AbsBinds
+                zonked_inst_tyvars
+                dfun_arg_dicts_ids
+                [(inst_tyvars', dfun_id, this_dict_id)] 
+                emptyNameSet           -- No inlines (yet)
+                (lie_binds1    `AndMonoBinds` 
+                 lie_binds2    `AndMonoBinds`
+                 method_binds  `AndMonoBinds`
+                 dict_bind)

     in
     in

-    returnNF_Tc (
-      mkTyLam tyvars (
-       mkDictLam local_dicts (
-         mkDictApp (mkTyApp (Var defm_id)
-                            (inst_ty : tys))
-                   (this_dict_id:local_dicts)))
-    )
- where
-    idx             = tag - 1
-    class_op = class_ops !! idx
-    defm_id  = defm_ids  !! idx
+    returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie,
+             main_bind `AndMonoBinds` prag_binds)

 \end{code}
 
 
 %************************************************************************
 %*                                                                     *
 \end{code}
 
 
 %************************************************************************
 %*                                                                     *

-\subsection{Processing each method}
+\subsection{Checking for a decent instance type}

 %*                                                                     *
 %************************************************************************
 
 %*                                                                     *
 %************************************************************************
 

-@processInstBinds@ returns a @MonoBinds@ which binds 
-all the method ids (which are passed in).  It is used
-       - both for instance decls, 
-       - and to compile the default-method declarations in a class decl.
-
-Any method ids which don't have a binding have a suitable default 
-binding created for them. The actual right-hand side used is 
-created using a function which is passed in, because the right thing to
-do differs between instance and class decls.
-
-\begin{code}
-processInstBinds
-       :: E
-       -> [TyVar]                         -- Free in envt
-
-       -> (Int -> NF_TcM TypecheckedExpr) -- Function to make
-                                          -- default method
-
-       -> [TyVar]                         -- Tyvars for this instance decl
-
-       -> [Inst]                          -- available Insts
-
-       -> [Id]                            -- Local method ids 
-                                          --   (instance tyvars are free 
-                                          --   in their types),
-                                          --   in tag order
-       -> RenamedMonoBinds
-
-       -> TcM ([Inst],                 -- These are required
-               TypecheckedMonoBinds)
+@scrutiniseInstanceHead@ checks the type {\em and} its syntactic constraints:
+it must normally look like: @instance Foo (Tycon a b c ...) ...@

 
 

-processInstBinds e free_tyvars mk_method_expr inst_tyvars
-                avail_insts method_ids monobinds
-  = 
-        -- Process the explicitly-given method bindings
-    processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids monobinds
-        `thenTc` (\ (tags, insts_needed_in_methods, method_binds) ->
+The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
+flag is on, or (2)~the instance is imported (they must have been
+compiled elsewhere). In these cases, we let them go through anyway.

 
 

-        -- Find the methods not handled, and make default method bindings for them.
-    let unmentioned_tags = [1.. length method_ids] `minusList` tags
-    in
-    makeDefaultMethods mk_method_expr unmentioned_tags method_ids
-                                        `thenNF_Tc`    (\ default_monobinds ->
-
-    returnTc (insts_needed_in_methods, 
-             method_binds `AndMonoBinds` default_monobinds)
-    ))
-\end{code}
+We can also have instances for functions: @instance Foo (a -> b) ...@.

 
 \begin{code}
 
 \begin{code}

-processInstBinds1
-       :: E
-       -> [TyVar]              -- Global free tyvars
-       -> [TyVar]              -- Tyvars for this instance decl
-       -> [Inst]               -- available Insts
-       -> [Id]                 -- Local method ids (instance tyvars are free),
-                               --      in tag order
-       -> RenamedMonoBinds 
-       -> TcM ([Int],          -- Class-op tags accounted for
-               [Inst],         -- These are required
-               TypecheckedMonoBinds)
-
-processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids EmptyMonoBinds
-  = returnTc ([], [], EmptyMonoBinds)
-
-processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2)
-  = processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mb1
-                                `thenTc`       \ (op_tags1,dicts1,method_binds1) ->
-    processInstBinds1 e free_tyvars inst_tyvars avail_insts method_ids mb2
-                                `thenTc`       \ (op_tags2,dicts2,method_binds2) ->
-    returnTc (op_tags1 ++ op_tags2,
-             dicts1 ++ dicts2,
-             AndMonoBinds method_binds1 method_binds2)
-\end{code}
+scrutiniseInstanceConstraint pred
+  = getDOptsTc `thenTc` \ dflags -> case () of
+    () 
+     |  dopt Opt_AllowUndecidableInstances dflags
+     -> returnNF_Tc ()
+
+     |  Just (clas,tys) <- getClassTys_maybe pred,
+        all isTyVarTy tys
+     -> returnNF_Tc ()
+
+     |  otherwise
+     -> addErrTc (instConstraintErr pred)
+
+scrutiniseInstanceHead clas inst_taus
+  = getDOptsTc `thenTc` \ dflags -> case () of
+    () 
+     | -- CCALL CHECK
+       -- A user declaration of a CCallable/CReturnable instance
+       -- must be for a "boxed primitive" type.
+        (clas `hasKey` cCallableClassKey   
+            && not (ccallable_type dflags first_inst_tau)) 
+        ||
+        (clas `hasKey` cReturnableClassKey 
+            && not (creturnable_type first_inst_tau))
+     -> addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
+
+       -- Allow anything for AllowUndecidableInstances
+     |  dopt Opt_AllowUndecidableInstances dflags
+     -> returnNF_Tc ()
+
+       -- If GlasgowExts then check at least one isn't a type variable
+     |  dopt Opt_GlasgowExts dflags
+     -> if   all isTyVarTy inst_taus
+        then addErrTc (instTypeErr clas inst_taus 
+             (text "There must be at least one non-type-variable in the instance head"))
+        else returnNF_Tc ()
+
+       -- WITH HASKELL 1.4, MUST HAVE C (T a b c)
+     |  not (length inst_taus == 1 &&
+             maybeToBool maybe_tycon_app &&    -- Yes, there's a type constuctor
+             not (isSynTyCon tycon) &&         -- ...but not a synonym
+             all isTyVarTy arg_tys &&          -- Applied to type variables
+            length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
+             -- This last condition checks that all the type variables are distinct
+            )
+     ->  addErrTc (instTypeErr clas inst_taus
+                    (text "the instance type must be of form (T a b c)" $$
+                     text "where T is not a synonym, and a,b,c are distinct type variables")
+         )
+
+     |  otherwise
+     -> returnNF_Tc ()

 
 

-\begin{code}
-processInstBinds1 e free_tyvars inst_tyvars 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
-    -- former, it should only bind a single variable, or else we're in
-    -- trouble (I'm not sure what the static semantics of methods
-    -- defined in a pattern binding with multiple patterns is!)
-    -- Renamer has reduced us to these two cases.
-    let
-       (op,locn) = case mbind of
-                     FunMonoBind op _ locn            -> (op, locn)
-                     PatMonoBind (VarPatIn op) _ locn -> (op, locn)
-    
-       origin = InstanceDeclOrigin locn
-    in
-    addSrcLocTc locn                    (
+  where
+    (first_inst_tau : _)       = inst_taus

 
 

-    -- Make a method id for the method
-    let tag       = getTagFromClassOpName op
-        method_id = method_ids !! (tag-1)
-       method_ty = getIdUniType method_id
-    in
-    specTy origin method_ty  `thenNF_Tc` \ (method_tyvars, method_dicts, method_tau) ->
-
-       -- Build the result
-    case (method_tyvars, method_dicts) of
-
-      ([],[]) -> -- The simple case; no local polymorphism or overloading in the method
-
-               -- Type check the method itself
-       tcMethodBind e 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.
-               -- The global tyvars must be a fixed point of the substitution
-       applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars ->
-       checkSigTyVars real_free_tyvars inst_tyvars method_tau method_tau
-                             (MethodSigCtxt op method_tau) `thenTc_`
-
-       returnTc ([tag], unMkLIE lieIop, mbind')
-
-      other -> -- It's a locally-polymorphic and/or overloaded method; UGH!
-
-                -- Make a new id for (a) the local, non-overloaded method
-                -- and               (b) the locally-overloaded method
-                -- The latter is needed just so we can return an AbsBinds wrapped
-                -- up inside a MonoBinds.
-       newLocalWithGivenTy op method_tau       `thenNF_Tc` \ local_meth_id ->
-       newLocalWithGivenTy op method_ty        `thenNF_Tc` \ copy_meth_id ->
-
-               -- Typecheck the method
-       tcMethodBind e local_meth_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.
-               -- The global tyvars must be a fixed point of the substitution
-       applyTcSubstAndCollectTyVars free_tyvars `thenNF_Tc` \ real_free_tyvars ->
-       checkSigTyVars real_free_tyvars (method_tyvars ++ inst_tyvars) method_tau method_tau
-                             (MethodSigCtxt op method_tau) `thenTc_`
-
-               -- Check the overloading part of the signature.
-               -- Simplify everything fully, even though some
-               -- constraints could "really" be left to the next
-               -- level out. The case which forces this is
-               --
-               --      class Foo a where { op :: Bar a => a -> a }
-               --
-               -- Here we must simplify constraints on "a" to catch all
-               -- the Bar-ish things.
-       tcSimplifyAndCheck
-               False                   -- Not top level
-               real_free_tyvars 
-               (inst_tyvars ++ method_tyvars)
-               (method_dicts ++ avail_insts)
-               (unMkLIE lieIop)        
-               (MethodSigCtxt op method_ty)    `thenTc` \ (f_dicts, dict_binds) ->
-
-       returnTc ([tag],
-                 f_dicts,
-                 VarMonoBind method_id
-                        (Let
-                            (AbsBinds
-                               method_tyvars
-                               (map mkInstId method_dicts)
-                               [(local_meth_id, copy_meth_id)]
-                               dict_binds
-                               (NonRecBind mbind'))
-                            (Var copy_meth_id)))
-    )
-\end{code}
+       -- Stuff for algebraic or -> type
+    maybe_tycon_app      = splitTyConApp_maybe first_inst_tau
+    Just (tycon, arg_tys) = maybe_tycon_app

 
 

-\begin{code}
-tcMethodBind :: E -> Id -> UniType -> RenamedMonoBinds 
-           -> TcM (TypecheckedMonoBinds, LIE)
-
-tcMethodBind e meth_id meth_ty (FunMonoBind name matches locn)
-  = addSrcLocTc locn                            (
-    tcMatchesFun e name meth_ty matches `thenTc` \ (rhs', lie) ->
-    returnTc (FunMonoBind meth_id rhs' locn, lie)
-    )
-
-tcMethodBind e meth_id meth_ty (PatMonoBind pat grhss_and_binds locn)
-  -- pat is sure to be a (VarPatIn op)
-  = addSrcLocTc locn                            (
-    tcGRHSsAndBinds e grhss_and_binds  `thenTc` \ (grhss_and_binds', lie, rhs_ty) ->
-    unifyTauTy meth_ty rhs_ty (PatMonoBindsCtxt pat grhss_and_binds) `thenTc_`
-    returnTc (PatMonoBind (VarPat meth_id) grhss_and_binds' locn, lie)
-    )
+    ccallable_type   dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
+    creturnable_type        ty = isFFIResultTy ty

 \end{code}
 
 
 \end{code}
 
 

-Creates bindings for the default methods, being the application of the
-appropriate global default method to the type of this instance decl.
-
-\begin{code}
-makeDefaultMethods 
-       :: (Int -> NF_TcM TypecheckedExpr)      -- Function to make
-                                               -- default method
-       -> [Int]                                -- Tags for methods required
-       -> [Id]                                 -- Method names to bind, in tag order
-       -> NF_TcM TypecheckedMonoBinds
-
-       
-makeDefaultMethods mk_method_expr [] method_ids
-  = returnNF_Tc EmptyMonoBinds
-
-makeDefaultMethods mk_method_expr (tag:tags) method_ids
-  = mk_method_expr tag                               `thenNF_Tc` \ rhs ->
-    makeDefaultMethods mk_method_expr tags method_ids `thenNF_Tc` \ meth_binds ->
-
-    returnNF_Tc ((VarMonoBind method_id rhs) `AndMonoBinds` meth_binds)
-  where
-    method_id = method_ids !! (tag-1)
-\end{code}
-

 %************************************************************************
 %*                                                                     *
 %************************************************************************
 %*                                                                     *

-\subsection{Type-checking specialise instance pragmas}
+\subsection{Error messages}

 %*                                                                     *
 %************************************************************************
 
 \begin{code}
 %*                                                                     *
 %************************************************************************
 
 \begin{code}

-tcSpecInstSigs :: E -> CE -> TCE
-              -> Bag InstInfo                          -- inst decls seen (declared and derived)
-              -> [RenamedSpecialisedInstanceSig]       -- specialise instance upragmas
-              -> TcM (Bag InstInfo)                    -- new, overlapped, inst decls
-
-tcSpecInstSigs e ce tce inst_infos []
-  = returnTc emptyBag
-
-tcSpecInstSigs e ce tce inst_infos sigs
-  = buildInstanceEnvs inst_infos       `thenTc`    \ inst_mapper ->
-    tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ spec_inst_infos ->
-    returnTc spec_inst_infos
-  where
-    tc_inst_spec_sigs inst_mapper []
-      = returnNF_Tc emptyBag
-    tc_inst_spec_sigs inst_mapper (sig:sigs)
-      = tcSpecInstSig e ce tce inst_infos inst_mapper sig      `thenNF_Tc` \ info_sig ->
-        tc_inst_spec_sigs inst_mapper sigs                     `thenNF_Tc` \ info_sigs ->
-        returnNF_Tc (info_sig `unionBags` info_sigs)
-
-tcSpecInstSig :: E -> CE -> TCE
-             -> Bag InstInfo
-             -> InstanceMapper
-             -> RenamedSpecialisedInstanceSig
-             -> NF_TcM (Bag InstInfo)
-
-tcSpecInstSig e ce tce inst_infos inst_mapper (InstSpecSig class_name ty src_loc)
-  = recoverTc emptyBag                 (
-    addSrcLocTc src_loc                        (
-    let
-       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
-       (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
-       tycon = case getUniDataTyCon_maybe inst_ty of 
-                    Just (tc,_,_) -> tc
-                    Nothing       -> panic "tcSpecInstSig:inst_tycon"
-
-       maybe_unspec_inst = lookup_unspec_inst clas tycon inst_infos 
-    in
-       -- Check that we have a local instance declaration to specialise
-    checkMaybeTc maybe_unspec_inst
-           (specInstUnspecInstNotFoundErr clas inst_ty src_loc)  `thenTc_`
-
-       -- Create tvs to substitute for tmpls while simplifying the context
-    copyTyVars inst_tmpls      `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
-    let
-       Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
-                      _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
-
-       subst = case matchTy unspec_inst_ty inst_ty of
-                    Just subst -> subst
-                    Nothing    -> panic "tcSpecInstSig:matchTy"
-
-       subst_theta    = instantiateThetaTy subst unspec_theta
-        subst_tv_theta = instantiateThetaTy tv_e subst_theta
-
-       mk_spec_origin clas ty
-          = InstanceSpecOrigin inst_mapper clas ty src_loc
-    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_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
-    in
-    mkInstanceRelatedIds e True{-from here-} NoInstancePragmas src_loc
-                        clas inst_tmpls inst_ty simpl_theta uprag
-                               `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
-
-    getSwitchCheckerTc         `thenNF_Tc` \ sw_chkr ->
-    (if sw_chkr SpecialiseTrace then
-       pprTrace "Specialised Instance: "
-                (ppAboves [ppCat [if null simpl_theta then ppNil else ppr PprDebug simpl_theta,
-                                  if null simpl_theta then ppNil else ppStr "=>",
-                                  ppr PprDebug clas,
-                                  pprParendUniType 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,
-                                  pprParendUniType PprDebug unspec_inst_ty]])
-     else id) (
-
-    returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
-                               dfun_theta dfun_id const_meth_ids
-                               binds True{-from here-} mod src_loc uprag))
-    )))
-
-
-lookup_unspec_inst clas tycon inst_infos
-  = case filter match_info (bagToList inst_infos) of
-       []       -> Nothing
-       (info:_) -> Just info
+tcAddDeclCtxt decl thing_inside
+  = tcAddSrcLoc loc    $
+    tcAddErrCtxt ctxt  $
+    thing_inside

   where
   where

-    match_info (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
-      = from_here && clas == inst_clas && inst_ty_matches_tycon
-      where
-        inst_ty_matches_tycon = case (getUniDataTyCon_maybe inst_ty) of
-         Just (inst_tc,tys,_) -> tycon == inst_tc && all isTyVarTemplateTy tys
-         Nothing              -> False
+     (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")
+
+     ctxt = hsep [ptext SLIT("In the"), text thing, 
+                 ptext SLIT("declaration for"), quotes (ppr name)]
+\end{code}

 
 

+\begin{code}
+instConstraintErr pred
+  = hang (ptext SLIT("Illegal constraint") <+> 
+         quotes (pprPred pred) <+> 
+         ptext SLIT("in instance context"))
+        4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
+       
+badGenericInstanceType binds
+  = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
+         nest 4 (ppr binds)]
+
+missingGenericInstances missing
+  = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
+         
+
+
+dupGenericInsts tc_inst_infos
+  = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
+         nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
+         ptext SLIT("All the type patterns for a generic type constructor must be identical")
+    ]
+  where 
+    ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
+
+instTypeErr clas tys msg
+  = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
+        nest 4 (parens msg)
+    ]
+
+nonBoxedPrimCCallErr clas inst_ty
+  = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
+        4 (hsep [ ptext SLIT("class"), ppr clas, ptext SLIT("type"),
+                       ppr inst_ty])
+
+methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
+superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration")

 \end{code}
 \end{code}