[project @ 2000-03-23 17:45:17 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 dffbe4b..0c32116 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -1,71 +1,73 @@
 %
 %

-% (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 ) where
+

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

-module TcInstDcls (
-       tcInstDecls1, tcInstDecls2,
-       tcSpecInstSigs,
-       buildInstanceEnvs, processInstBinds,
-       mkInstanceRelatedIds,
-       InstInfo(..)
-    ) where
+import HsSyn           ( HsDecl(..), InstDecl(..),
+                         HsBinds(..), MonoBinds(..),
+                         HsExpr(..), InPat(..), HsLit(..), Sig(..),
+                         andMonoBindList
+                       )
+import RnHsSyn         ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
+import TcHsSyn         ( TcMonoBinds, mkHsConApp,
+                         maybeBoxedPrimType
+                       )

 
 

-IMPORT_Trace           -- ToDo:rm debugging
-import Outputable
-import Pretty
+import TcBinds         ( tcSpecSigs )
+import TcClassDcl      ( tcMethodBind, checkFromThisClass )
+import TcMonad
+import RnMonad         ( RnNameSupply, Fixities )
+import Inst            ( Inst, InstOrigin(..),
+                         newDicts, newClassDicts,
+                         LIE, emptyLIE, plusLIE, plusLIEs )
+import TcDeriv         ( tcDeriving )
+import TcEnv           ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths,
+                         tcAddImportedIdInfo, tcInstId
+                       )
+import TcInstUtil      ( InstInfo(..), classDataCon )
+import TcMonoType      ( tcHsTopType )
+import TcSimplify      ( tcSimplifyAndCheck )
+import TcType          ( TcTyVar, zonkTcTyVarBndr )

 
 

-import TcMonad         -- typechecking monad machinery
-import TcMonadFns      ( newDicts, newMethod, newLocalWithGivenTy,
-                         newClassOpLocals, copyTyVars,
-                         applyTcSubstAndCollectTyVars
+import Bag             ( emptyBag, unitBag, unionBags, unionManyBags,
+                         foldBag, Bag

                        )
                        )

-import AbsSyn          -- the stuff being typechecked
-import AbsPrel         ( pAT_ERROR_ID )
-import AbsUniType
-import BackSubst       ( applyTcSubstToBinds )
-import Bag             ( emptyBag, unitBag, unionBags, bagToList )
-import CE              ( lookupCE, CE(..) )
-import CmdLineOpts     ( GlobalSwitch(..) )
-import GenSpecEtc      ( checkSigTyVars, SignatureInfo )
-import E               ( mkE, getE_CE, getE_TCE, growE_LVE, tvOfE, LVE(..), E )
-import Errors          ( dupInstErr, derivingWhenInstanceExistsErr,
-                         preludeInstanceErr, nonBoxedPrimCCallErr,
-                         specInstUnspecInstNotFoundErr,
-                         Error(..), UnifyErrContext(..)
+import CmdLineOpts     ( opt_GlasgowExts, opt_AllowUndecidableInstances )
+import Class           ( classBigSig, Class )
+import Var             ( idName, idType, Id, TyVar )
+import DataCon         ( isNullaryDataCon, splitProductType_maybe )
+import Maybes          ( maybeToBool, catMaybes, expectJust )
+import MkId            ( mkDictFunId )
+import Module          ( ModuleName )
+import Name            ( isLocallyDefined, NamedThing(..)      )
+import NameSet         ( emptyNameSet )
+import PrelInfo                ( eRROR_ID )
+import PprType         ( pprConstraint )
+import SrcLoc          ( SrcLoc )
+import TyCon           ( isSynTyCon, isDataTyCon, tyConDerivings )
+import Type            ( Type, isUnLiftedType, mkTyVarTys,
+                         splitSigmaTy, isTyVarTy,
+                         splitTyConApp_maybe, splitDictTy_maybe,
+                         getClassTys_maybe, splitAlgTyConApp_maybe,
+                         classesToPreds, classesOfPreds,
+                         unUsgTy, tyVarsOfTypes

                        )
                        )

-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 PlainCore       ( escErrorMsg )
-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 TcBinds         ( tcSigs, doSpecPragma )
-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 Subst           ( mkTopTyVarSubst, substClasses )
+import VarSet          ( mkVarSet, varSetElems )
+import TysPrim         ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
+import TysWiredIn      ( stringTy )
+import Unique          ( Unique, cCallableClassKey, cReturnableClassKey, Uniquable(..) )
+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

@@ -73,33 +75,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 specialised methods
-\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

@@ -159,312 +139,74 @@ and $dbinds_super$ bind the superclass dictionaries sd1 \ldots sdm.
 \end{enumerate}
 
 \begin{code}
 \end{enumerate}
 
 \begin{code}

-tcInstDecls1 :: E -> CE -> TCE -> [RenamedInstDecl] -> NF_TcM (Bag InstInfo)
-
-tcInstDecls1 e ce tce [] = returnNF_Tc emptyBag
-
-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)
-  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 modname 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}
-
-
-Common bit of code shared with @tcDeriving@:
-\begin{code}
-mkInstanceRelatedIds e
-               from_here modname 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)
-
-
-       dfun_theta = case inst_decl_theta of
-
-                       []    -> []     -- If inst_decl_theta is empty, then we don't
-                                       -- want to have any dict arguments, so that we can
-                                       -- expose the constant methods.
-
-                       other -> inst_decl_theta ++ super_class_theta
-                                       -- Otherwise we pass the superclass dictionaries to 
-                                       -- the dictionary function; the Mark Jones optimisation.
+tcInstDecls1 :: ValueEnv               -- Contains IdInfo for dfun ids
+            -> [RenamedHsDecl]
+            -> ModuleName                      -- module name for deriving
+            -> Fixities
+            -> RnNameSupply                    -- for renaming derivings
+            -> TcM s (Bag InstInfo,
+                      RenamedHsBinds)
+
+tcInstDecls1 unf_env decls mod_name fixs rn_name_supply
+  =    -- Do the ordinary instance declarations
+    mapNF_Tc (tcInstDecl1 unf_env) 
+            [inst_decl | InstD inst_decl <- decls]     `thenNF_Tc` \ inst_info_bags ->
+    let
+       decl_inst_info = unionManyBags inst_info_bags
+    in
+       -- Handle "derived" instances; note that we only do derivings
+       -- for things in this module; we ignore deriving decls from
+       -- interfaces!
+    tcDeriving mod_name fixs rn_name_supply decl_inst_info
+                       `thenTc` \ (deriv_inst_info, deriv_binds) ->

 
 

-       dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
+    let
+       full_inst_info = deriv_inst_info `unionBags` decl_inst_info

     in
     in

-    fixNF_Tc ( \ rec_dfun_id ->
-       babyTcMtoNF_TcM (
-           tcDictFunPragmas e dfun_ty rec_dfun_id inst_pragmas
-       )                       `thenNF_Tc` \ dfun_pragma_info ->
-       let
-           dfun_specenv = mkInstSpecEnv clas inst_ty inst_tyvars dfun_theta
-           dfun_info = dfun_pragma_info `addInfo` dfun_specenv
-       in
-       returnNF_Tc (mkDictFunId uniq clas inst_ty dfun_ty from_here modname dfun_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 modname 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 modname 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)
-\end{code}
+    returnTc (full_inst_info, deriv_binds)

 
 
 
 

-%************************************************************************
-%*                                                                     *
-\subsection{Converting instance info into suitable InstEnvs}
-%*                                                                     *
-%************************************************************************
+tcInstDecl1 :: ValueEnv -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)

 
 

-\begin{code}
-buildInstanceEnvs :: Bag InstInfo 
-                 -> TcM InstanceMapper
-
-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_
+tcInstDecl1 unf_env (InstDecl poly_ty binds uprags dfun_name src_loc)
+  =    -- Prime error recovery, set source location
+    recoverNF_Tc (returnNF_Tc emptyBag)        $
+    tcAddSrcLoc src_loc                        $

 
 

-       info_by_class = equivClasses cmp (bagToList info)
-    in
-    mapTc buildInstanceEnv info_by_class    `thenTc` \ inst_env_entries ->
+       -- Type-check all the stuff before the "where"
+    tcHsTopType poly_ty                        `thenTc` \ poly_ty' ->

     let
     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
+       (tyvars, theta, dict_ty) = splitSigmaTy poly_ty'
+       constr                   = classesOfPreds theta
+       (clas, inst_tys)         = case splitDictTy_maybe dict_ty of
+                                    Just ct -> ct
+                                    Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty)

     in
     in

-    returnTc class_lookup_fn
-\end{code}

 
 

-\begin{code}
-buildInstanceEnv :: [InstInfo]         -- Non-empty, and all for same class
-                -> TcM (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
+       -- 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] 
+    (if isLocallyDefined dfun_name then
+       scrutiniseInstanceHead clas inst_tys    `thenNF_Tc_`
+       mapNF_Tc scrutiniseInstanceConstraint constr
+     else
+       returnNF_Tc []
+     )                                         `thenNF_Tc_`

 
 

-buildInstanceEnv inst_infos@(info_for_one@(InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : rest)
-  = let
-       ops       = getClassOps clas
-       no_of_ops = length ops
-    in
-    foldlTc addClassInstance
-           (nullMEnv, nOfThem no_of_ops nullSpecEnv)
-           inst_infos      `thenTc` \ (class_inst_env, op_inst_envs) ->
+       -- Make the dfun id

     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
+       dfun_id = mkDictFunId dfun_name clas tyvars inst_tys constr
+
+       -- Add info from interface file
+       final_dfun_id = tcAddImportedIdInfo unf_env dfun_id

     in
     in

-    returnTc (clas, (class_inst_env, class_op_fn))
+    returnTc (unitBag (InstInfo clas tyvars inst_tys constr
+                               final_dfun_id
+                               binds src_loc uprags))

 \end{code}
 
 \end{code}
 

-\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 _)
-  = getSwitchCheckerTc         `thenNF_Tc` \ sw_chkr ->
-       -- We anly add specialised/overlapped instances
-       -- if we are specialising the overloading
---
--- ToDo ... This causes getConstMethodId errors!
---
---    if is_plain_instance inst_ty || sw_chkr SpecialiseOverloaded
---    then
-
-       -- 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
-       in
-       returnTc (class_inst_env', op_spec_envs')
-
---    else
---     -- Drop this specialised/overlapped instance
---     returnTc (class_inst_env, op_spec_envs) 
-
-  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.
-
-\end{code}

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

@@ -473,30 +215,22 @@ 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 :: Bag InstInfo
+            -> NF_TcM s (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
+  where
+    combine tc1 tc2 = tc1      `thenNF_Tc` \ (lie1, binds1) ->
+                     tc2       `thenNF_Tc` \ (lie2, binds2) ->
+                     returnNF_Tc (lie1 `plusLIE` lie2,
+                                  binds1 `AndMonoBinds` binds2)

 \end{code}
 
 
 ======= New documentation starts here (Sept 92)         ==============
 
 \end{code}
 
 
 ======= 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

@@ -511,41 +245,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
                ...

@@ -559,624 +292,336 @@ 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.
 

+First comes the easy case of a non-local instance decl.
+

 \begin{code}
 \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-} inst_mod locn uprags)
-  = 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
-    getSwitchCheckerTc                 `thenNF_Tc` \ sw_chkr ->
-    let
-       mk_method_expr
-         = if sw_chkr OmitDefaultInstanceMethods then
-               makeInstanceDeclNoDefaultExpr origin clas method_ids defm_ids inst_mod inst_ty
-           else
-               makeInstanceDeclDefaultMethodExpr origin this_dict_id class_ops defm_ids inst_ty
-    in
-    processInstBinds e free_tyvars mk_method_expr
-       inst_tyvars avail_insts method_ids monobinds
-                                        `thenTc` \ (insts_needed, method_mbinds) ->
+tcInstDecl2 :: InstInfo -> NF_TcM s (LIE, TcMonoBinds)
+
+tcInstDecl2 (InstInfo clas inst_tyvars inst_tys
+                     inst_decl_theta
+                     dfun_id monobinds
+                     locn uprags)
+  | not (isLocallyDefined dfun_id)
+  = returnNF_Tc (emptyLIE, EmptyMonoBinds)
+
+{-
+  -- I deleted this "optimisation" because when importing these
+  -- instance decls the renamer would look for the dfun bindings and they weren't there.
+  -- This would be fixable, but it seems simpler just to produce a tiny void binding instead,
+  -- even though it's never used.
+
+       -- This case deals with CCallable etc, which don't need any bindings
+  | isNoDictClass clas                 
+  = returnNF_Tc (emptyLIE, EmptyBinds)
+-}
+
+  | otherwise
+  =     -- Prime error recovery
+    recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds))  $
+    tcAddSrcLoc locn                                      $
+
+       -- Instantiate the instance decl with tc-style type variables
+    tcInstId dfun_id           `thenNF_Tc` \ (inst_tyvars', dfun_theta', dict_ty') ->

     let
     let

-       -- Create the dict and method binds
-       dict_bind
-           = VarMonoBind this_dict_id (Dictionary sc_dicts'_ids method_ids)
+       (clas, inst_tys')       = expectJust "tcInstDecl2" (splitDictTy_maybe dict_ty')

 
 

-       dict_and_method_binds
-           = 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) ->
+       origin                  = InstanceDeclOrigin

 
 

-       -- 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.
+        (class_tyvars, sc_theta, _, op_items) = classBigSig clas

 
 

-       -- Now process any SPECIALIZE pragmas for the methods
-    let
-       spec_sigs = [ s | s@(SpecSig _ _ _ _) <- uprags ]
+       dm_ids = [dm_id | (_, dm_id, _) <- op_items]

 
 

-       get_const_method_id name
-         = const_meth_ids !! ((getTagFromClassOpName name) - 1)
+       -- Instantiate the theta found in the original instance decl
+       inst_decl_theta' = substClasses (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars'))
+                                       inst_decl_theta
+
+         -- Instantiate the super-class context with inst_tys
+       sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta

     in
     in

-    tcSigs e [] spec_sigs              `thenTc` \ sig_info ->
-
-    mapAndUnzipTc (doSpecPragma e get_const_method_id) sig_info
-                                       `thenTc` \ (spec_binds_s, spec_lie_s) ->
-    let 
-       spec_lie   = foldr plusLIE nullLIE spec_lie_s
-       spec_binds = foldr AndMonoBinds EmptyMonoBinds spec_binds_s
-
-       -- Complete the binding group, adding any spec_binds
-        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)
-           
-           `ThenBinds`
-           SingleBind (NonRecBind spec_binds)
+        -- 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 inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) ->
+    newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict,       [this_dict_id]) ->
+
+        -- Check that all the method bindings come from this class
+    checkFromThisClass clas op_items monobinds         `thenNF_Tc_`
+
+    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'
+                                    (classesToPreds inst_decl_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
     in

-        -- Back-substitute
-    applyTcSubstToBinds inst_binds `thenNF_Tc` \ final_inst_binds ->
-
-    returnTc (mkLIE const_insts `plusLIE` spec_lie,
-             final_inst_binds)
-    )))
-\end{code}
-
-@mkMethodId@ manufactures an id for a local method.
-It's rather turgid stuff, because there are two cases:
-
-  (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.
-
-  (b) For methods with local polymorphism, we can't do this.  For example,
-
-        class Foo a where
-               op :: (Num b) => a -> b -> a
-
-      Here the type of the class-op-selector is
-
-       forall a b. (Foo a, Num b) => a -> b -> a
+    tcExtendGlobalValEnv [dfun_id] (
+       tcSpecSigs dfun_prags
+    )                                  `thenTc` \ (prag_binds, prag_lie) ->

 
 

-      The locally defined method at (say) type Float will have type
-
-       forall b. (Num b) => Float -> b -> Float
-
-      and the one is not an instance of the other.
+       -- Check the overloading constraints of the methods and superclasses

 
 

-      So for these we just make a local (non-Inst) id with a suitable type.
+       -- tcMethodBind has checked that the class_tyvars havn't
+       -- been unified with each other or another type, but we must
+       -- still zonk them
+    mapNF_Tc zonkTcTyVarBndr inst_tyvars'      `thenNF_Tc` \ zonked_inst_tyvars ->
+    let
+        inst_tyvars_set = mkVarSet zonked_inst_tyvars

 
 

-How disgusting.
+       (meth_lies, meth_ids) = unzip meth_lies_w_ids

 
 

-\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}
+                -- These insts are in scope; quite a few, eh?
+       avail_insts = this_dict                 `plusLIE` 
+                     dfun_arg_dicts            `plusLIE`
+                     sc_dicts                  `plusLIE`
+                     unionManyBags meth_lies

 
 

-This function makes a default method which calls the global default method, at
-the appropriate instance type.
+        methods_lie = plusLIEs insts_needed_s
+    in

 
 

-See the notes under default decls in TcClassDcl.lhs.
+       -- Ditto method bindings
+    tcAddErrCtxt methodCtxt (
+      tcSimplifyAndCheck
+                (ptext SLIT("instance declaration context"))
+                inst_tyvars_set                        -- Local tyvars
+                avail_insts
+                methods_lie
+    )                                           `thenTc` \ (const_lie1, lie_binds1) ->
+    
+       -- 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.
+    tcAddErrCtxt superClassCtxt (
+      tcSimplifyAndCheck
+                (ptext SLIT("instance declaration context"))
+                inst_tyvars_set                -- Local tyvars
+                inst_decl_dicts                -- The instance dictionaries available
+                sc_dicts                       -- The superclass dicationaries reqd
+    )                                  `thenTc` \ _ -> 
+                                               -- Ignore the result; we're only doing
+                                               -- this to make sure it can be done.

 
 

-\begin{code}
-makeInstanceDeclDefaultMethodExpr
-       :: InstOrigin
-       -> Id
-       -> [ClassOp]
-       -> [Id]
-       -> UniType
-       -> Int
-       -> NF_TcM TypecheckedExpr
+       -- Now do the simplification again, this time to get the
+       -- bindings; this time we use an enhanced "avails"
+       -- Ignore errors because they come from the *previous* tcSimplify
+    discardErrsTc (
+       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) [(unUsgTy . idType) this_dict_id])
+                 (HsLitOut (HsString msg) stringTy)
+
+         | 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
-
-
-makeInstanceDeclNoDefaultExpr
-       :: InstOrigin
-       -> Class
-       -> [Id]
-       -> [Id]
-       -> FAST_STRING
-       -> UniType
-       -> Int
-       -> NF_TcM TypecheckedExpr
-       
-makeInstanceDeclNoDefaultExpr origin clas method_ids defm_ids inst_mod inst_ty tag
-  = specTy origin (getIdUniType method_id) `thenNF_Tc` \ (tyvars, dicts, tau) ->
-
-    (if not err_defm then
-        pprTrace "Warning: "
-        (ppCat [ppStr "Omitted default method for",
-                ppr PprForUser clas_op, ppStr "in instance",
-                ppPStr clas_name, pprParendUniType PprForUser inst_ty])
-    else id) (
-
-    returnNF_Tc (mkTyLam tyvars (
-                mkDictLam (map mkInstId dicts) (
-                App (mkTyApp (Var pAT_ERROR_ID) [tau])
-                    (Lit (StringLit (_PK_ error_msg))))))
-    )
-  where
-    idx              = tag - 1
-    clas_op   = (getClassOps clas) !! idx
-    method_id = method_ids  !! idx
-    defm_id   = defm_ids  !! idx
-
-    Just (_, _, err_defm) = isDefaultMethodId_maybe defm_id
-
-    error_msg = "%E"   -- => No explicit method for \"
-               ++ escErrorMsg error_str
-
-    error_str = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "."
-               ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
-               ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
-
-    (_, clas_name) = getOrigName clas
+    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)
-
-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) ->
-
-        -- 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}
-
-\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}
+@scrutiniseInstanceHead@ checks the type {\em and} its syntactic constraints:
+it must normally look like: @instance Foo (Tycon a b c ...) ...@

 
 

-\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                    (
+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.

 
 

-    -- 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}
+We can also have instances for functions: @instance Foo (a -> b) ...@.

 
 \begin{code}
 
 \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)
+scrutiniseInstanceConstraint (clas, tys)
+  |  all isTyVarTy tys 
+  || opt_AllowUndecidableInstances = returnNF_Tc ()
+  | otherwise                     = addErrTc (instConstraintErr clas tys)
+
+scrutiniseInstanceHead clas inst_taus
+  |    -- CCALL CHECK (a).... urgh!
+       -- To verify that a user declaration of a CCallable/CReturnable 
+       -- instance is OK, we must be able to see the constructor(s)
+       -- of the instance type (see next guard.)
+       --  
+        -- We flag this separately to give a more precise error msg.
+        --
+     (getUnique clas == cCallableClassKey || getUnique clas == cReturnableClassKey)
+  && is_alg_tycon_app && not constructors_visible
+  = addErrTc (invisibleDataConPrimCCallErr clas first_inst_tau)
+
+  |    -- CCALL CHECK (b) 
+       -- A user declaration of a CCallable/CReturnable instance
+       -- must be for a "boxed primitive" type.
+    (getUnique clas == cCallableClassKey   && not (ccallable_type   first_inst_tau)) ||
+    (getUnique clas == cReturnableClassKey && not (creturnable_type first_inst_tau))
+  = addErrTc (nonBoxedPrimCCallErr clas first_inst_tau)
+
+       -- DERIVING CHECK
+       -- It is obviously illegal to have an explicit instance
+       -- for something that we are also planning to `derive'
+  | maybeToBool alg_tycon_app_maybe && clas `elem` (tyConDerivings alg_tycon)
+  = addErrTc (derivingWhenInstanceExistsErr clas first_inst_tau)
+          -- Kind check will have ensured inst_taus is of length 1
+
+       -- Allow anything for AllowUndecidableInstances
+  | opt_AllowUndecidableInstances
+  = returnNF_Tc ()
+
+       -- If GlasgowExts then check at least one isn't a type variable
+  | opt_GlasgowExts 
+  = 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")

     )
 
     )
 

-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)
-    )
-\end{code}
+  | otherwise
+  = returnNF_Tc ()

 
 

+  where
+    (first_inst_tau : _)       = inst_taus

 
 

-Creates bindings for the default methods, being the application of the
-appropriate global default method to the type of this instance decl.
+       -- Stuff for algebraic or -> type
+    maybe_tycon_app      = splitTyConApp_maybe first_inst_tau
+    Just (tycon, arg_tys) = maybe_tycon_app

 
 

-\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
+       -- Stuff for an *algebraic* data type
+    alg_tycon_app_maybe                   = splitAlgTyConApp_maybe first_inst_tau
+                                       -- The "Alg" part looks through synonyms
+    is_alg_tycon_app              = maybeToBool alg_tycon_app_maybe
+    Just (alg_tycon, _, data_cons) = alg_tycon_app_maybe

 
 

-       
-makeDefaultMethods mk_method_expr [] method_ids
-  = returnNF_Tc EmptyMonoBinds
+    constructors_visible = not (null data_cons)
+ 

 
 

-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 ->
+-- These conditions come directly from what the DsCCall is capable of.
+-- Totally grotesque.  Green card should solve this.

 
 

-    returnNF_Tc ((VarMonoBind method_id rhs) `AndMonoBinds` meth_binds)
+ccallable_type   ty = isUnLiftedType ty ||                             -- Allow CCallable Int# etc
+                      maybeToBool (maybeBoxedPrimType ty) ||   -- Ditto Int etc
+                     ty == stringTy ||
+                     byte_arr_thing

   where
   where

-    method_id = method_ids !! (tag-1)
+    byte_arr_thing = case splitProductType_maybe ty of
+                       Just (tycon, ty_args, data_con, [data_con_arg_ty1, data_con_arg_ty2, data_con_arg_ty3]) ->
+                               maybeToBool maybe_arg3_tycon &&
+                               (arg3_tycon == byteArrayPrimTyCon ||
+                                arg3_tycon == mutableByteArrayPrimTyCon)
+                            where
+                               maybe_arg3_tycon    = splitTyConApp_maybe data_con_arg_ty3
+                               Just (arg3_tycon,_) = maybe_arg3_tycon
+
+                       other -> False
+
+creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
+                       -- Or, a data type with a single nullary constructor
+                     case (splitAlgTyConApp_maybe ty) of
+                       Just (tycon, tys_applied, [data_con])
+                               -> isNullaryDataCon data_con
+                       other -> False

 \end{code}
 
 \end{code}
 

-%************************************************************************
-%*                                                                     *
-\subsection{Type-checking specialise instance pragmas}
-%*                                                                     *
-%************************************************************************
-

 \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
-       maybe_tycon = case getUniDataTyCon_maybe inst_ty of 
-                        Just (tc,_,_) -> Just tc
-                        Nothing       -> Nothing
-
-       maybe_unspec_inst = lookup_unspec_inst clas maybe_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-} mod 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 maybe_tycon inst_infos
-  = case filter (match_info match_inst_ty) (bagToList inst_infos) of
-       []       -> Nothing
-       (info:_) -> Just info
-  where
-    match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _)
-      = from_here && clas == inst_clas &&
-        match_ty inst_ty && is_plain_instance inst_ty
-
-    match_inst_ty = case maybe_tycon of
-                     Just tycon -> match_tycon tycon
-                     Nothing    -> match_fun
-
-    match_tycon tycon inst_ty = case (getUniDataTyCon_maybe inst_ty) of
-         Just (inst_tc,_,_) -> tycon == inst_tc
-         Nothing            -> False
-
-    match_fun inst_ty = isFunType inst_ty
-
-
-is_plain_instance inst_ty
-  = case (getUniDataTyCon_maybe inst_ty) of
-      Just (_,tys,_) -> all isTyVarTemplateTy tys
-      Nothing       -> case maybeUnpackFunTy inst_ty of
-                         Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res
-                         Nothing         -> error "TcInstDecls:is_plain_instance"
+instConstraintErr clas tys
+  = hang (ptext SLIT("Illegal constraint") <+> 
+         quotes (pprConstraint clas tys) <+> 
+         ptext SLIT("in instance context"))
+        4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
+       
+instTypeErr clas tys msg
+  = sep [ptext SLIT("Illegal instance declaration for") <+> quotes (pprConstraint clas tys),
+        nest 4 (parens msg)
+    ]
+
+derivingWhenInstanceExistsErr clas tycon
+  = hang (hsep [ptext SLIT("Deriving class"), 
+                      quotes (ppr clas), 
+                      ptext SLIT("type"), quotes (ppr tycon)])
+         4 (ptext SLIT("when an explicit instance exists"))
+
+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])
+
+{-
+  Declaring CCallable & CReturnable instances in a module different
+  from where the type was defined. Caused by importing data type
+  abstractly (either programmatically or by the renamer being over-eager
+  in its pruning.)
+-}
+invisibleDataConPrimCCallErr clas inst_ty
+  = hang (hsep [ptext SLIT("Constructors for"), quotes (ppr inst_ty),
+               ptext SLIT("not visible when checking"),
+                quotes (ppr clas), ptext SLIT("instance")])
+        4 (hsep [text "(Try either importing", ppr inst_ty, 
+                text "non-abstractly or compile using -fno-prune-tydecls ..)"])
+
+methodCtxt     = ptext SLIT("When checking the methods of an instance declaration")
+superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration")

 \end{code}
 \end{code}