From d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 Mon Sep 17 00:00:00 2001
From: "simonpj@microsoft.com" <unknown>
Date: Mon, 13 Sep 2010 09:50:48 +0000
Subject: [PATCH] Super-monster patch implementing the new typechecker -- at
 last

This major patch implements the new OutsideIn constraint solving
algorithm in the typecheker, following our JFP paper "Modular type
inference with local assumptions".

Done with major help from Dimitrios Vytiniotis and Brent Yorgey.
---
 compiler/HsVersions.h                              |    2 +-
 compiler/basicTypes/Id.lhs                         |    5 +-
 compiler/basicTypes/MkId.lhs                       |  205 +-
 compiler/basicTypes/Var.lhs                        |   79 +-
 compiler/basicTypes/VarEnv.lhs                     |    7 +-
 compiler/cmm/CmmBuildInfoTables.hs                 |    4 +
 compiler/cmm/CmmCPS.hs                             |    1 +
 compiler/cmm/CmmCPSZ.hs                            |    7 +
 compiler/cmm/CmmSpillReload.hs                     |    3 +
 compiler/cmm/CmmStackLayout.hs                     |    4 +
 compiler/cmm/ZipCfg.hs                             |   17 +-
 compiler/cmm/ZipCfgCmmRep.hs                       |    3 +
 compiler/cmm/ZipDataflow.hs                        |   23 +-
 compiler/coreSyn/CoreArity.lhs                     |    4 +-
 compiler/coreSyn/CoreFVs.lhs                       |    2 +-
 compiler/coreSyn/CoreLint.lhs                      |   29 +-
 compiler/coreSyn/CorePrep.lhs                      |    4 +-
 compiler/coreSyn/CoreSubst.lhs                     |  252 +-
 compiler/coreSyn/CoreSyn.lhs                       |    8 +-
 compiler/coreSyn/CoreTidy.lhs                      |    4 +-
 compiler/coreSyn/CoreUnfold.lhs                    |    2 +-
 compiler/coreSyn/CoreUtils.lhs                     |  107 +-
 compiler/coreSyn/MkCore.lhs                        |   16 +-
 compiler/coreSyn/MkExternalCore.lhs                |    4 +-
 compiler/coreSyn/PprCore.lhs                       |    8 +-
 compiler/deSugar/Coverage.lhs                      |   14 +-
 compiler/deSugar/Desugar.lhs                       |  186 +-
 compiler/deSugar/DsArrows.lhs                      |   21 +-
 compiler/deSugar/DsBinds.lhs                       |  323 +-
 compiler/deSugar/DsExpr.lhs                        |  135 +-
 compiler/deSugar/DsUtils.lhs                       |    7 +-
 compiler/deSugar/Match.lhs                         |    8 +-
 compiler/deSugar/MatchCon.lhs                      |    6 +-
 compiler/ghc.cabal.in                              |    5 +-
 compiler/ghci/ByteCodeGen.lhs                      |    8 +-
 compiler/ghci/Linker.lhs                           |    3 +-
 compiler/ghci/RtClosureInspect.hs                  |   10 +-
 compiler/hsSyn/HsBinds.lhs                         |  224 +-
 compiler/hsSyn/HsDecls.lhs                         |    2 +
 compiler/hsSyn/HsExpr.lhs                          |   39 +-
 compiler/hsSyn/HsPat.lhs                           |   67 +-
 compiler/hsSyn/HsTypes.lhs                         |    4 +-
 compiler/hsSyn/HsUtils.lhs                         |   41 +-
 compiler/iface/BuildTyCl.lhs                       |  138 +-
 compiler/iface/IfaceType.lhs                       |    2 +-
 compiler/iface/LoadIface.lhs                       |    1 -
 compiler/iface/MkIface.lhs                         |   10 +-
 compiler/iface/TcIface.lhs                         |   56 +-
 compiler/main/DynFlags.hs                          |  238 +-
 compiler/main/GHC.hs                               |    5 +-
 compiler/main/HscTypes.lhs                         |    4 +-
 compiler/main/PprTyThing.hs                        |    8 +-
 compiler/main/StaticFlagParser.hs                  |    1 +
 compiler/main/StaticFlags.hs                       |    8 +-
 compiler/main/TidyPgm.lhs                          |    6 +-
 compiler/nativeGen/RegAlloc/Liveness.hs            |   18 +-
 compiler/nativeGen/X86/Instr.hs                    |    2 +
 compiler/parser/Parser.y.pp                        |    4 +-
 compiler/prelude/PrelNames.lhs                     |   14 +-
 compiler/prelude/PrelRules.lhs                     |  183 +-
 compiler/rename/RnBinds.lhs                        |   91 +-
 compiler/rename/RnNames.lhs                        |    5 +-
 compiler/rename/RnSource.lhs                       |    2 +-
 compiler/simplCore/FloatIn.lhs                     |    2 +-
 compiler/simplCore/FloatOut.lhs                    |    2 +-
 compiler/simplCore/OccurAnal.lhs                   |   42 +-
 compiler/simplCore/SetLevels.lhs                   |    4 +-
 compiler/simplCore/SimplCore.lhs                   |  194 +-
 compiler/simplCore/SimplEnv.lhs                    |    2 +-
 compiler/simplCore/SimplUtils.lhs                  |  130 +-
 compiler/simplCore/Simplify.lhs                    |   14 +-
 compiler/specialise/Rules.lhs                      |   20 +-
 compiler/specialise/SpecConstr.lhs                 |    8 +-
 compiler/stgSyn/CoreToStg.lhs                      |    4 +-
 compiler/stranal/DmdAnal.lhs                       |    4 +-
 compiler/stranal/WwLib.lhs                         |    2 +-
 compiler/typecheck/FamInst.lhs                     |   15 +-
 compiler/typecheck/Inst.lhs                        | 1300 ++-----
 compiler/typecheck/TcAnnotations.lhs               |    2 +-
 compiler/typecheck/TcArrows.lhs                    |   41 +-
 compiler/typecheck/TcBinds.lhs                     | 1007 +++--
 compiler/typecheck/TcCanonical.lhs                 |  701 ++++
 compiler/typecheck/TcClassDcl.lhs                  |  104 +-
 compiler/typecheck/TcDefaults.lhs                  |    6 +-
 compiler/typecheck/TcDeriv.lhs                     |  143 +-
 compiler/typecheck/TcEnv.lhs                       |  230 +-
 compiler/typecheck/TcErrors.lhs                    |  704 ++++
 compiler/typecheck/TcExpr.lhs                      | 1124 +++---
 compiler/typecheck/TcExpr.lhs-boot                 |   18 +-
 compiler/typecheck/TcForeign.lhs                   |    4 +-
 compiler/typecheck/TcHsSyn.lhs                     |  258 +-
 compiler/typecheck/TcHsType.lhs                    |   67 +-
 compiler/typecheck/TcInstDcls.lhs                  |  655 ++--
 compiler/typecheck/TcInteract.lhs                  | 1669 +++++++++
 compiler/typecheck/TcMType.lhs                     |  994 ++---
 compiler/typecheck/TcMatches.lhs                   |  225 +-
 compiler/typecheck/TcMatches.lhs-boot              |    6 +-
 compiler/typecheck/TcPat.lhs                       | 1058 +++---
 compiler/typecheck/TcRnDriver.lhs                  |  130 +-
 compiler/typecheck/TcRnMonad.lhs                   |  253 +-
 compiler/typecheck/TcRnTypes.lhs                   |  531 ++-
 compiler/typecheck/TcRules.lhs                     |  101 +-
 compiler/typecheck/TcSMonad.lhs                    |  799 ++++
 compiler/typecheck/TcSimplify.lhs                  | 3958 ++++----------------
 compiler/typecheck/TcSimplify.lhs-old              | 3297 ++++++++++++++++
 compiler/typecheck/TcSplice.lhs                    |   49 +-
 compiler/typecheck/TcSplice.lhs-boot               |    6 +-
 compiler/typecheck/TcTyClsDecls.lhs                |   90 +-
 .../typecheck/{TcTyFuns.lhs => TcTyFuns.lhs-old}   |   13 +-
 compiler/typecheck/TcType.lhs                      |  412 +-
 compiler/typecheck/TcUnify.lhs                     | 2208 ++++-------
 compiler/typecheck/TcUnify.lhs-boot                |    4 +-
 compiler/types/Class.lhs                           |   56 +-
 compiler/types/Coercion.lhs                        |  125 +-
 compiler/types/FamInstEnv.lhs                      |   18 +-
 compiler/types/FunDeps.lhs                         |   19 +-
 compiler/types/InstEnv.lhs                         |    1 -
 compiler/types/TyCon.lhs                           |  219 +-
 compiler/types/Type.lhs                            |  110 +-
 compiler/types/TypeRep.lhs                         |    4 +-
 compiler/utils/Bag.lhs                             |   55 +-
 compiler/utils/Digraph.lhs                         |    2 +-
 compiler/utils/Outputable.lhs                      |    5 +-
 compiler/vectorise/VectMonad.hs                    |  651 ++++
 compiler/vectorise/Vectorise/Monad/InstEnv.hs      |    2 +-
 compiler/vectorise/Vectorise/Type/Env.hs           |    4 +-
 compiler/vectorise/Vectorise/Type/PData.hs         |    1 +
 compiler/vectorise/Vectorise/Type/PRepr.hs         |    1 +
 compiler/vectorise/Vectorise/Type/TyConDecl.hs     |    1 +
 compiler/vectorise/Vectorise/Utils.hs              |    2 +-
 new_tc_notes                                       |  181 +
 131 files changed, 15479 insertions(+), 11287 deletions(-)
 create mode 100644 compiler/typecheck/TcCanonical.lhs
 create mode 100644 compiler/typecheck/TcErrors.lhs
 create mode 100644 compiler/typecheck/TcInteract.lhs
 create mode 100644 compiler/typecheck/TcSMonad.lhs
 create mode 100644 compiler/typecheck/TcSimplify.lhs-old
 rename compiler/typecheck/{TcTyFuns.lhs => TcTyFuns.lhs-old} (99%)
 create mode 100644 compiler/vectorise/VectMonad.hs
 create mode 100644 new_tc_notes

diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h
index aa251f4..ad17189 100644
--- a/compiler/HsVersions.h
+++ b/compiler/HsVersions.h
@@ -56,7 +56,7 @@ name = Util.globalMVar (value);
 #ifdef DEBUG
 #define ASSERT(e)      if (not (e)) then (assertPanic __FILE__ __LINE__) else
 #define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else
-#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg))
+#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $
 #else
 -- We have to actually use all the variables we are given or we may get
 -- unused variable warnings when DEBUG is off.
diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs
index fbf6b4a..1efc273 100644
--- a/compiler/basicTypes/Id.lhs
+++ b/compiler/basicTypes/Id.lhs
@@ -30,7 +30,7 @@ module Id (
 	mkLocalId, mkLocalIdWithInfo, mkExportedLocalId,
 	mkSysLocal, mkSysLocalM, mkUserLocal, mkUserLocalM,
 	mkTemplateLocals, mkTemplateLocalsNum, mkTemplateLocal,
-	mkWorkerId, 
+	mkWorkerId, mkWiredInIdName,
 
 	-- ** Taking an Id apart
 	idName, idType, idUnique, idInfo, idDetails,
@@ -258,6 +258,9 @@ mkUserLocal occ uniq ty loc = mkLocalId (mkInternalName uniq occ loc) ty
 mkUserLocalM :: MonadUnique m => OccName -> Type -> SrcSpan -> m Id
 mkUserLocalM occ ty loc = getUniqueM >>= (\uniq -> return (mkUserLocal occ uniq ty loc))
 
+mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name
+mkWiredInIdName mod fs uniq id
+ = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
 \end{code}
 
 Make some local @Ids@ for a template @CoreExpr@.  These have bogus
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 6d6a835..1984633 100644
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -25,26 +25,22 @@ module MkId (
 
         -- And some particular Ids; see below for why they are wired in
         wiredInIds, ghcPrimIds,
-        unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
-        lazyId, lazyIdKey,
+        unsafeCoerceName, unsafeCoerceId, realWorldPrimId, 
+        voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
 
-        mkRuntimeErrorApp, mkImpossibleExpr,
-        rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
-        nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
-        pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID,
-
-        unsafeCoerceName
+	-- Re-export error Ids
+	module PrelRules
     ) where
 
 #include "HsVersions.h"
 
 import Rules
 import TysPrim
-import TysWiredIn
 import PrelRules
 import Type
 import Coercion
 import TcType
+import MkCore
 import CoreUtils	( exprType, mkCoerce )
 import CoreUnfold
 import Literal
@@ -362,7 +358,8 @@ mkDataConIds wrap_name wkr_name data_con
 
     mkCoVarLocals i []     = ([],i)
     mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
-                                 y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x
+                                 y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) 
+                                                  (fsLit "dc_co")) x
                              in (y:ys,j)
 
     mk_case 
@@ -436,10 +433,12 @@ at the outside.  When dealing with classes it's very convenient to
 recover the original type signature from the class op selector.
 
 \begin{code}
-mkDictSelId :: Bool	-- True <=> don't include the unfolding
-			-- Little point on imports without -O, because the
-			-- dictionary itself won't be visible
- 	    -> Name -> Class -> Id
+mkDictSelId :: Bool	     -- True <=> don't include the unfolding
+			     -- Little point on imports without -O, because the
+			     -- dictionary itself won't be visible
+ 	    -> Name	     -- Name of one of the *value* selectors 
+	       		     -- (dictionary superclass or method)
+            -> Class -> Id
 mkDictSelId no_unf name clas
   = mkGlobalId (ClassOpId clas) name sel_ty info
   where
@@ -474,7 +473,7 @@ mkDictSelId no_unf name clas
     	   	       	 	     occNameFS (getOccName name)
                        , ru_fn    = name
     	               , ru_nargs = n_ty_args + 1
-                       , ru_try   = dictSelRule index n_ty_args }
+                       , ru_try   = dictSelRule val_index n_ty_args n_eq_args }
 
         -- The strictness signature is of the form U(AAAVAAAA) -> T
         -- where the V depends on which item we are selecting
@@ -485,41 +484,45 @@ mkDictSelId no_unf name clas
             | otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
                                      | id <- arg_ids ])
 
-    tycon      = classTyCon clas
-    new_tycon  = isNewTyCon tycon
-    [data_con] = tyConDataCons tycon
-    tyvars     = dataConUnivTyVars data_con
-    arg_tys    = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con
-    eq_theta   = dataConEqTheta data_con
-    index      = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` [0..]) name
-    the_arg_id = arg_ids !! index
+    tycon      	   = classTyCon clas
+    new_tycon  	   = isNewTyCon tycon
+    [data_con] 	   = tyConDataCons tycon
+    tyvars     	   = dataConUnivTyVars data_con
+    arg_tys    	   = dataConRepArgTys data_con	-- Includes the dictionary superclasses
+    eq_theta   	   = dataConEqTheta data_con
+    n_eq_args      = length eq_theta
 
-    pred       = mkClassPred clas (mkTyVarTys tyvars)
-    dict_id    = mkTemplateLocal 1 $ mkPredTy pred
-    (eq_ids,n) = mkCoVarLocals   2 $ mkPredTys eq_theta
-    arg_ids    = mkTemplateLocalsNum n arg_tys
+    -- 'index' is a 0-index into the *value* arguments of the dictionary
+    val_index      = assoc "MkId.mkDictSelId" sel_index_prs name
+    sel_index_prs  = map idName (classAllSelIds clas) `zip` [0..]
 
-    mkCoVarLocals i []     = ([],i)
-    mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
-                                 y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) (fsLit "dc_co")) x
-                             in (y:ys,j)
+    the_arg_id     = arg_ids !! val_index
+    pred       	   = mkClassPred clas (mkTyVarTys tyvars)
+    dict_id    	   = mkTemplateLocal 1 $ mkPredTy pred
+    arg_ids    	   = mkTemplateLocalsNum 2 arg_tys
+    eq_ids     	   = map mkWildEvBinder eq_theta
 
     rhs = mkLams tyvars  (Lam dict_id   rhs_body)
     rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
              | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
                                 [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
 
-dictSelRule :: Int -> Arity -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
+dictSelRule :: Int -> Arity -> Arity 
+            -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
 -- Oh, very clever
---       op_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
---       op_i t1..tk (D t1..tk op1 ... opm) = opi
+--       sel_i t1..tk (df s1..sn d1..dm) = op_i_helper s1..sn d1..dm
+--       sel_i t1..tk (D t1..tk op1 ... opm) = opi
 --
--- NB: the data constructor has the same number of type args as the class op
-
-dictSelRule index n_ty_args id_unf args
+-- NB: the data constructor has the same number of type and 
+--     coercion args as the selector
+--
+-- This only works for *value* superclasses
+-- There are no selector functions for equality superclasses
+dictSelRule val_index n_ty_args n_eq_args id_unf args
   | (dict_arg : _) <- drop n_ty_args args
-  , Just (_, _, val_args) <- exprIsConApp_maybe id_unf dict_arg
-  = Just (val_args !! index)
+  , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
+  , let val_args = drop n_eq_args con_args
+  = Just (val_args !! val_index)
   | otherwise
   = Nothing
 \end{code}
@@ -644,7 +647,7 @@ mkReboxingAlt us con args rhs
 
     -- Type variable case
     go (arg:args) stricts us 
-      | isTyVar arg
+      | isTyCoVar arg
       = let (binds, args') = go args stricts us
         in  (binds, arg:args')
 
@@ -884,31 +887,12 @@ they can unify with both unlifted and lifted types.  Hence we provide
 another gun with which to shoot yourself in the foot.
 
 \begin{code}
-mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name
-mkWiredInIdName mod fs uniq id
- = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
-
-unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name
-lazyIdName, errorName, recSelErrorName, runtimeErrorName :: Name
-irrefutPatErrorName, recConErrorName, patErrorName :: Name
-nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
+lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name
 unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
 nullAddrName     = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#")     nullAddrIdKey      nullAddrId
 seqName          = mkWiredInIdName gHC_PRIM (fsLit "seq")           seqIdKey           seqId
 realWorldName    = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPrimIdKey realWorldPrimId
 lazyIdName       = mkWiredInIdName gHC_BASE (fsLit "lazy")         lazyIdKey           lazyId
-
-errorName                = mkWiredInIdName gHC_ERR (fsLit "error")            errorIdKey eRROR_ID
-recSelErrorName          = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recSelError")     recSelErrorIdKey rEC_SEL_ERROR_ID
-runtimeErrorName         = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "runtimeError")    runtimeErrorIdKey rUNTIME_ERROR_ID
-irrefutPatErrorName      = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
-recConErrorName          = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recConError")     recConErrorIdKey rEC_CON_ERROR_ID
-patErrorName             = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "patError")         patErrorIdKey pAT_ERROR_ID
-noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "noMethodBindingError")
-                                           noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
-nonExhaustiveGuardsErrorName 
-  = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "nonExhaustiveGuardsError") 
-                    nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
 \end{code}
 
 \begin{code}
@@ -974,7 +958,7 @@ lazyId = pcMiscPrelId lazyIdName ty info
 
 Note [seqId magic]
 ~~~~~~~~~~~~~~~~~~
-'GHC.Prim.seq' is special in several ways.  
+'GHC.Prim.seq' is special in several ways. 
 
 a) Its second arg can have an unboxed type
       x `seq` (v +# w)
@@ -986,6 +970,8 @@ c) It has quite a bit of desugaring magic.
 
 d) There is some special rule handing: Note [User-defined RULES for seq]
 
+e) See Note [Typing rule for seq] in TcExpr.
+
 Note [User-defined RULES for seq]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Roman found situations where he had
@@ -1071,81 +1057,6 @@ voidArgId       -- :: State# RealWorld
 \end{code}
 
 
-%************************************************************************
-%*                                                                      *
-\subsection[PrelVals-error-related]{@error@ and friends; @trace@}
-%*                                                                      *
-%************************************************************************
-
-GHC randomly injects these into the code.
-
-@patError@ is just a version of @error@ for pattern-matching
-failures.  It knows various ``codes'' which expand to longer
-strings---this saves space!
-
-@absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
-well shouldn't be yanked on, but if one is, then you will get a
-friendly message from @absentErr@ (rather than a totally random
-crash).
-
-@parError@ is a special version of @error@ which the compiler does
-not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
-templates, but we don't ever expect to generate code for it.
-
-\begin{code}
-mkRuntimeErrorApp 
-        :: Id           -- Should be of type (forall a. Addr# -> a)
-                        --      where Addr# points to a UTF8 encoded string
-        -> Type         -- The type to instantiate 'a'
-        -> String       -- The string to print
-        -> CoreExpr
-
-mkRuntimeErrorApp err_id res_ty err_msg 
-  = mkApps (Var err_id) [Type res_ty, err_string]
-  where
-    err_string = Lit (mkMachString err_msg)
-
-mkImpossibleExpr :: Type -> CoreExpr
-mkImpossibleExpr res_ty
-  = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
-
-rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
-pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
-rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
-rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
-iRREFUT_PAT_ERROR_ID            = mkRuntimeErrorId irrefutPatErrorName
-rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName
-pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
-nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
-nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
-
--- The runtime error Ids take a UTF8-encoded string as argument
-
-mkRuntimeErrorId :: Name -> Id
-mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
-
-runtimeErrorTy :: Type
-runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
-\end{code}
-
-\begin{code}
-eRROR_ID :: Id
-eRROR_ID = pc_bottoming_Id errorName errorTy
-
-errorTy  :: Type
-errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
-    -- Notice the openAlphaTyVar.  It says that "error" can be applied
-    -- to unboxed as well as boxed types.  This is OK because it never
-    -- returns, so the return type is irrelevant.
-\end{code}
-
-
-%************************************************************************
-%*                                                                      *
-\subsection{Utilities}
-%*                                                                      *
-%************************************************************************
-
 \begin{code}
 pcMiscPrelId :: Name -> Type -> IdInfo -> Id
 pcMiscPrelId name ty info
@@ -1155,26 +1066,4 @@ pcMiscPrelId name ty info
     -- random calls to GHCbase.unpackPS__.  If GHCbase is the module
     -- being compiled, then it's just a matter of luck if the definition
     -- will be in "the right place" to be in scope.
-
-pc_bottoming_Id :: Name -> Type -> Id
--- Function of arity 1, which diverges after being given one argument
-pc_bottoming_Id name ty
- = pcMiscPrelId name ty bottoming_info
- where
-    bottoming_info = vanillaIdInfo `setStrictnessInfo` Just strict_sig
-				   `setArityInfo`         1
-			-- Make arity and strictness agree
-
-        -- Do *not* mark them as NoCafRefs, because they can indeed have
-        -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
-        -- which has some CAFs
-        -- In due course we may arrange that these error-y things are
-        -- regarded by the GC as permanently live, in which case we
-        -- can give them NoCaf info.  As it is, any function that calls
-        -- any pc_bottoming_Id will itself have CafRefs, which bloats
-        -- SRTs.
-
-    strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
-        -- These "bottom" out, no matter what their arguments
 \end{code}
-
diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs
index 5fd35ce..a0fa921 100644
--- a/compiler/basicTypes/Var.lhs
+++ b/compiler/basicTypes/Var.lhs
@@ -25,8 +25,8 @@
 -- Global 'Id's and 'Var's are those that are imported or correspond to a data constructor, primitive operation, or record selectors.
 -- Local 'Id's and 'Var's are those bound within an expression (e.g. by a lambda) or at the top level of the module being compiled.
 module Var (
-        -- * The main data type
-	Var,
+        -- * The main data type and synonyms
+	Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
 
 	-- ** Taking 'Var's apart
 	varName, varUnique, varType, 
@@ -41,14 +41,11 @@ module Var (
 	setIdExported, setIdNotExported,
 
         -- ** Predicates
-        isCoVar, isId, isTyVar, isTcTyVar,
+        isCoVar, isId, isTyCoVar, isTyVar, isTcTyVar,
         isLocalVar, isLocalId,
 	isGlobalId, isExportedId,
 	mustHaveLocalBinding,
 
-	-- * Type variable data type
-	TyVar,
-
 	-- ** Constructing 'TyVar's
 	mkTyVar, mkTcTyVar, mkWildCoVar,
 
@@ -58,9 +55,6 @@ module Var (
 	-- ** Modifying 'TyVar's
 	setTyVarName, setTyVarUnique, setTyVarKind,
 
-        -- * Coercion variable data type
-        CoVar,
-
         -- ** Constructing 'CoVar's
         mkCoVar,
 
@@ -68,10 +62,8 @@ module Var (
         coVarName,
 
         -- ** Modifying 'CoVar's
-        setCoVarUnique, setCoVarName,
+        setCoVarUnique, setCoVarName
 
-	-- * 'Var' type synonyms
-	Id, DictId
     ) where
 
 #include "HsVersions.h"
@@ -95,6 +87,30 @@ import Data.Data
 
 %************************************************************************
 %*									*
+                     Synonyms									
+%*									*
+%************************************************************************
+-- These synonyms are here and not in Id because otherwise we need a very
+-- large number of SOURCE imports of Id.hs :-(
+
+\begin{code}
+type EvVar = Var	-- An evidence variable: dictionary or equality constraint
+     	       		-- Could be an DictId or a CoVar
+
+type Id     = Var       -- A term-level identifier
+type DFunId = Id	-- A dictionary function
+type EvId   = Id        -- Term-level evidence: DictId or IpId
+type DictId = EvId	-- A dictionary variable
+type IpId   = EvId      -- A term-level implicit parameter
+
+type TyVar = Var
+type CoVar = TyVar	-- A coercion variable is simply a type 
+			-- variable of kind @ty1 ~ ty2@. Hence its
+			-- 'varType' is always @PredTy (EqPred t1 t2)@
+\end{code}
+
+%************************************************************************
+%*									*
 \subsection{The main data type declarations}
 %*									*
 %************************************************************************
@@ -124,7 +140,7 @@ data Var
 	varName        :: !Name,
 	realUnique     :: FastInt,
 	varType        :: Kind,
-	tcTyVarDetails :: TcTyVarDetails }
+	tc_tv_details  :: TcTyVarDetails }
 
   | Id {
 	varName    :: !Name,
@@ -166,7 +182,7 @@ instance Outputable Var where
 
 ppr_debug :: Var -> SDoc
 ppr_debug (TyVar {})                          = ptext (sLit "tv")
-ppr_debug (TcTyVar {tcTyVarDetails = d})      = pprTcTyVarDetails d
+ppr_debug (TcTyVar {tc_tv_details = d})       = pprTcTyVarDetails d
 ppr_debug (Id { idScope = s, id_details = d }) = ppr_id_scope s <> pprIdDetails d
 
 ppr_id_scope :: IdScope -> SDoc
@@ -229,8 +245,6 @@ setVarType id ty = id { varType = ty }
 %************************************************************************
 
 \begin{code}
-type TyVar = Var
-
 tyVarName :: TyVar -> Name
 tyVarName = varName
 
@@ -262,8 +276,12 @@ mkTcTyVar name kind details
     TcTyVar {	varName    = name,
 		realUnique = getKeyFastInt (nameUnique name),
 		varType  = kind,
-		tcTyVarDetails = details
+		tc_tv_details = details
 	}
+
+tcTyVarDetails :: TyVar -> TcTyVarDetails
+tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details
+tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var)
 \end{code}
 
 %************************************************************************
@@ -273,10 +291,6 @@ mkTcTyVar name kind details
 %************************************************************************
 
 \begin{code}
-type CoVar = TyVar -- A coercion variable is simply a type 
-			-- variable of kind @ty1 ~ ty2@. Hence its
-			-- 'varType' is always @PredTy (EqPred t1 t2)@
-
 coVarName :: CoVar -> Name
 coVarName = varName
 
@@ -307,11 +321,6 @@ mkWildCoVar = mkCoVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "co_wild"))
 %************************************************************************
 
 \begin{code}
--- These synonyms are here and not in Id because otherwise we need a very
--- large number of SOURCE imports of Id.hs :-(
-type Id = Var
-type DictId = Var
-
 idInfo :: Id -> IdInfo
 idInfo (Id { id_info = info }) = info
 idInfo other 	       	       = pprPanic "idInfo" (ppr other)
@@ -375,11 +384,20 @@ setIdNotExported id = ASSERT( isLocalId id )
 %************************************************************************
 
 \begin{code}
-isTyVar :: Var -> Bool		-- True of both type and coercion variables
-isTyVar (TyVar {})   = True
+isTyCoVar :: Var -> Bool	-- True of both type and coercion variables
+isTyCoVar (TyVar {})   = True
+isTyCoVar (TcTyVar {}) = True
+isTyCoVar _            = False
+
+isTyVar :: Var -> Bool		-- True of both type variables only
+isTyVar v@(TyVar {}) = not (isCoercionVar v)
 isTyVar (TcTyVar {}) = True
 isTyVar _            = False
 
+isCoVar :: Var -> Bool		-- Only works after type checking (sigh)
+isCoVar v@(TyVar {}) = isCoercionVar v
+isCoVar _            = False
+
 isTcTyVar :: Var -> Bool
 isTcTyVar (TcTyVar {}) = True
 isTcTyVar _            = False
@@ -392,11 +410,6 @@ isLocalId :: Var -> Bool
 isLocalId (Id { idScope = LocalId _ }) = True
 isLocalId _                            = False
 
-isCoVar :: Var -> Bool
-isCoVar (v@(TyVar {}))             = isCoercionVar v
-isCoVar (TcTyVar {varType = kind}) = isCoercionKind kind  -- used during solving
-isCoVar _                          = False
-
 -- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's
 -- These are the variables that we need to pay attention to when finding free
 -- variables, or doing dependency analysis.
diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs
index 2ee5ea5..bf3f96d 100644
--- a/compiler/basicTypes/VarEnv.lhs
+++ b/compiler/basicTypes/VarEnv.lhs
@@ -27,7 +27,8 @@ module VarEnv (
 	-- ** Operations on InScopeSets
 	emptyInScopeSet, mkInScopeSet, delInScopeSet,
 	extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, 
-	getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, 
+	getInScopeVars, lookupInScope, lookupInScope_Directly, 
+        elemInScopeSet, uniqAway, 
 
 	-- * The RnEnv2 type
 	RnEnv2, 
@@ -114,6 +115,10 @@ elemInScopeSet v (InScope in_scope _) = v `elemVarEnv` in_scope
 -- the variable's identity (unique) to its full value.
 lookupInScope :: InScopeSet -> Var -> Maybe Var
 lookupInScope (InScope in_scope _) v  = lookupVarEnv in_scope v
+
+lookupInScope_Directly :: InScopeSet -> Unique -> Maybe Var
+lookupInScope_Directly (InScope in_scope _) uniq
+  = lookupVarEnv_Directly in_scope uniq
 \end{code}
 
 \begin{code}
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 2cadd8d..c4a16d3 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
 module CmmBuildInfoTables
     ( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo
     , setInfoTableSRT, setInfoTableStackMap
diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index c5bcdc3..17c11ce 100644
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -235,6 +235,7 @@ gatherBlocksIntoContinuation live proc_points blocks start =
       children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
       start_block = lookupWithDefaultBEnv blocks unknown_block start
       children_blocks = map (lookupWithDefaultBEnv blocks unknown_block) (uniqSetToList children)
+      unknown_block :: a    -- Used at more than one type
       unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
       body = start_block : children_blocks
 
diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index 8bcadbb..e72d3f2 100644
--- a/compiler/cmm/CmmCPSZ.hs
+++ b/compiler/cmm/CmmCPSZ.hs
@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
 module CmmCPSZ (
   -- | Converts C-- with full proceedures and parameters
   -- to a CPS transformed C-- with the stack made manifest.
@@ -153,7 +157,10 @@ cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
   where dflags = hsc_dflags hsc_env
         mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
         dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
+
+        run :: FuelMonad a -> IO a
         run = runFuelIO (hsc_OptFuel hsc_env)
+
         dual_rewrite flag txt pass g =
           do dump flag ("Pre " ++ txt)  g
              g <- run $ pass g
diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs
index df05a65..c457383 100644
--- a/compiler/cmm/CmmSpillReload.hs
+++ b/compiler/cmm/CmmSpillReload.hs
@@ -1,3 +1,6 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
 
 module CmmSpillReload
   ( DualLive(..)
diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs
index d9cd411..a62580b 100644
--- a/compiler/cmm/CmmStackLayout.hs
+++ b/compiler/cmm/CmmStackLayout.hs
@@ -1,3 +1,7 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
+
 module CmmStackLayout
     ( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
     , layout, manifestSP, igraph, areaBuilder
diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs
index 376ab3e..1001f23 100644
--- a/compiler/cmm/ZipCfg.hs
+++ b/compiler/cmm/ZipCfg.hs
@@ -461,25 +461,32 @@ postorder_dfs g@(LGraph _ blockenv) =
     let FGraph id eblock _ = entry g in
      zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id)
 
-postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
+postorder_dfs_from_except :: forall m b l. (HavingSuccessors b, LastNode l)
                           => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
-postorder_dfs_from_except blocks b visited =
-  vchildren (get_children b) (\acc _visited -> acc) [] visited
+postorder_dfs_from_except blocks b visited 
+  = vchildren (get_children b) (\acc _visited -> acc) [] visited
   where
-    -- vnode ::
-    --    Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
+    vnode :: Block m l -> ([Block m l] -> BlockSet -> a)
+          -> [Block m l] -> BlockSet -> a
     vnode block@(Block id _) cont acc visited =
         if elemBlockSet id visited then
             cont acc visited
         else
             let cont' acc visited = cont (block:acc) visited in
             vchildren (get_children block) cont' acc (extendBlockSet visited id)
+
+    vchildren :: [Block m l] -> ([Block m l] -> BlockSet -> a)
+              -> [Block m l] -> BlockSet -> a
     vchildren bs cont acc visited =
         let next children acc visited =
                 case children of []     -> cont acc visited
                                  (b:bs) -> vnode b (next bs) acc visited
         in next bs acc visited
+
+    get_children :: HavingSuccessors c => c -> [Block m l]
     get_children block = foldl add_id [] (succs block)
+
+    add_id :: [Block m l] -> BlockId -> [Block m l]
     add_id rst id = case lookupBlockEnv blocks id of
                       Just b -> b : rst
                       Nothing -> rst
diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index 0a494f8..1377e2f 100644
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -1,3 +1,6 @@
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+
 -- This module is pure representation and should be imported only by
 -- clients that need to manipulate representation and know what
 -- they're doing.  Clients that need to create flow graphs should
diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs
index ba8e75a..388d99c 100644
--- a/compiler/cmm/ZipDataflow.hs
+++ b/compiler/cmm/ZipDataflow.hs
@@ -528,8 +528,14 @@ forward_sol check_maybe = forw
                ; b <-  finish
                ; return (b, fuel)
                }
+
        -- The need for both k1 and k2 suggests that maybe there's an opportunity
        -- for improvement here -- in most cases, they're the same...
+       rec_rewrite :: forall t bI bW.
+                      Maybe (AGraph m l) -> t -> DFM a bW
+                   -> (t -> Fuel -> DFM a bI)
+                   -> (bW -> Fuel -> DFM a bI)
+                   -> a -> Fuel -> DFM a bI
        rec_rewrite rewritten analyzed finish k1 k2 in' fuel =
          case check_maybe fuel rewritten of -- fr_first rewrites id idfact of
            Nothing -> k1 analyzed fuel
@@ -589,7 +595,6 @@ forward_rew
         -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
 forward_rew check_maybe = forw
   where
-    solve = forward_sol check_maybe
     forw :: RewritingDepth
          -> BlockEnv a
          -> PassName
@@ -607,7 +612,8 @@ forward_rew check_maybe = forw
            in_fact `seq` g `seq`
             let Graph entry blockenv = g
                 blocks = G.postorder_dfs_from blockenv entry
-            in do { _ <- solve depth name start transfers rewrites in_fact g fuel
+            in do { _ <- forward_sol check_maybe depth name start 
+                                     transfers rewrites in_fact g fuel
                   ; eid <- freshBlockId "temporary entry id"
                   ; (rewritten, fuel) <-
                       rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel
@@ -615,11 +621,18 @@ forward_rew check_maybe = forw
                   ; a <- finish
                   ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
                   }
+
+          don't_rewrite :: forall t.
+                           BlockEnv a -> DFM a t -> a
+                        -> Graph m l -> Fuel
+                        -> DFM a (t, Graph m l, Fuel)
           don't_rewrite facts finish in_fact g fuel =
-              do  { _ <- solve depth name facts transfers rewrites in_fact g fuel
+              do  { _ <- forward_sol check_maybe depth name facts 
+                                     transfers rewrites in_fact g fuel
                   ; a <- finish
                   ; return (a, g, fuel)
                   }
+
           inner_rew :: DFM a f -> a -> Graph m l -> Fuel -> DFM a (f, Graph m l, Fuel)
           inner_rew f i g fu = getAllFacts >>= \facts -> inner_rew' facts f i g fu
               where inner_rew' = case depth of RewriteShallow -> don't_rewrite
@@ -633,6 +646,7 @@ forward_rew check_maybe = forw
                  ; let fp = FFP cfp last_outs
                  ; return (fp, fuel)
                  }
+
 -- JD: WHY AREN'T WE TAKING ANY FUEL HERE?
           rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
                          -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
@@ -1028,8 +1042,9 @@ run dir name do_block blocks b =
      pprFacts depth n env =
          my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
                         (nest 2 $ vcat $ map pprFact $ blockEnvToList env))
-     pprFact  (id, a) = hang (ppr id <> colon) 4 (ppr a)
 
+pprFact :: (Outputable a, Outputable b) => (a,b) -> SDoc
+pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
 
 f4sep :: [SDoc] -> SDoc
 f4sep [] = fsep []
diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index e63d121..666da70 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -612,7 +612,7 @@ etaExpand n orig_expr
       -- Strip off existing lambdas and casts
       -- Note [Eta expansion and SCCs]
     go 0 expr = expr
-    go n (Lam v body) | isTyVar v = Lam v (go n     body)
+    go n (Lam v body) | isTyCoVar v = Lam v (go n     body)
        	              | otherwise = Lam v (go (n-1) body)
     go n (Cast expr co) = Cast (go n expr) co
     go n expr           = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
@@ -655,7 +655,7 @@ etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
 etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) 
   = etaInfoApp subst' e eis
   where
-    subst' | isTyVar v1 = CoreSubst.extendTvSubst subst v1 (mkTyVarTy v2) 
+    subst' | isTyCoVar v1 = CoreSubst.extendTvSubst subst v1 (mkTyVarTy v2) 
     	   | otherwise  = CoreSubst.extendIdSubst subst v1 (Var v2)
 
 etaInfoApp subst (Cast e co1) eis
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index 46c21b2..e5cbfc4 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -395,7 +395,7 @@ idFreeVars id = ASSERT( isId id)
 bndrRuleAndUnfoldingVars ::Var -> VarSet
 -- A 'let' can bind a type variable, and idRuleVars assumes 
 -- it's seeing an Id. This function tests first.
-bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
+bndrRuleAndUnfoldingVars v | isTyCoVar v = emptyVarSet
 	                   | otherwise = idRuleAndUnfoldingVars v
 
 idRuleAndUnfoldingVars :: Id -> VarSet
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index c267c96..119b232 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -229,9 +229,9 @@ lintCoreExpr (Note _ expr)
   = lintCoreExpr expr
 
 lintCoreExpr (Let (NonRec tv (Type ty)) body)
-  =	-- See Note [Type let] in CoreSyn
-    do	{ checkL (isTyVar tv) (mkKindErrMsg tv ty)	-- Not quite accurate
-	; ty' <- lintInTy ty
+  | isTyVar tv
+  =	-- See Note [Linting type lets]
+    do	{ ty' <- addLoc (RhsOf tv) $ lintInTy ty
         ; lintTyBndr tv              $ \ tv' -> 
           addLoc (BodyOfLetRec [tv]) $ 
           extendSubstL tv' ty'       $ do
@@ -240,6 +240,19 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body)
 		-- take advantage of it in the body
         ; lintCoreExpr body } }
 
+  | isCoVar tv
+  = do { co <- applySubst ty
+       ; (s1,s2) <- addLoc (RhsOf tv) $ lintCoercion co
+       ; lintTyBndr tv  $ \ tv' -> 
+         addLoc (BodyOfLetRec [tv]) $ do
+       { let (t1,t2) = coVarKind tv'
+       ; checkTys s1 t1 (mkTyVarLetErr tv ty)
+       ; checkTys s2 t2 (mkTyVarLetErr tv ty)
+       ; lintCoreExpr body } }
+
+  | otherwise
+  = failWithL (mkTyVarLetErr tv ty)	-- Not quite accurate
+
 lintCoreExpr (Let (NonRec bndr rhs) body)
   = do	{ lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
 	; addLoc (BodyOfLetRec [bndr])
@@ -279,7 +292,7 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
          Just (tycon, _)
               | debugIsOn &&
                 isAlgTyCon tycon && 
-		not (isOpenTyCon tycon) &&
+		not (isFamilyTyCon tycon || isAbstractTyCon tycon) &&
                 null (tyConDataCons tycon) -> 
                   pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
 			-- This can legitimately happen for type families
@@ -1081,6 +1094,14 @@ mkNonFunAppMsg fun_ty arg_ty arg
 	      hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
 	      hang (ptext (sLit "Arg:")) 4 (ppr arg)]
 
+mkTyVarLetErr :: TyVar -> Type -> Message
+mkTyVarLetErr tyvar ty
+  = vcat [ptext (sLit "Bad `let' binding for type or coercion variable:"),
+	  hang (ptext (sLit "Type/coercion variable:"))
+		 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
+	  hang (ptext (sLit "Arg type/coercion:"))   
+	         4 (ppr ty)]
+
 mkKindErrMsg :: TyVar -> Type -> Message
 mkKindErrMsg tyvar arg_ty
   = vcat [ptext (sLit "Kinds don't match in type application:"),
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index ba178b5..6a5a251 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -465,7 +465,7 @@ rhsToBody (Cast e co)
 rhsToBody expr@(Lam {})
   | Just no_lam_result <- tryEtaReducePrep bndrs body
   = return (emptyFloats, no_lam_result)
-  | all isTyVar bndrs		-- Type lambdas are ok
+  | all isTyCoVar bndrs		-- Type lambdas are ok
   = return (emptyFloats, expr)
   | otherwise			-- Some value lambdas
   = do { fn <- newVar (exprType expr)
@@ -688,7 +688,7 @@ cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial
 cpe_ExprIsTrivial (Note (SCC _) _)         = False
 cpe_ExprIsTrivial (Note _ e)               = cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
-cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
+cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body
 cpe_ExprIsTrivial _                        = False
 \end{code}
 
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 3578037..4f92b1a 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -28,7 +28,7 @@ module CoreSubst (
 	cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
 
 	-- ** Simple expression optimiser
-	simpleOptExpr
+	simpleOptPgm, simpleOptExpr
     ) where
 
 #include "HsVersions.h"
@@ -36,10 +36,12 @@ module CoreSubst (
 import CoreSyn
 import CoreFVs
 import CoreUtils
-import OccurAnal( occurAnalyseExpr )
+import PprCore
+import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
 
 import qualified Type
 import Type     ( Type, TvSubst(..), TvSubstEnv )
+import Coercion	   ( isIdentityCoercion )
 import OptCoercion ( optCoercion )
 import VarSet
 import VarEnv
@@ -50,6 +52,8 @@ import IdInfo
 import Unique
 import UniqSupply
 import Maybes
+import ErrUtils
+import DynFlags   ( DynFlags, DynFlag(..) )
 import BasicTypes ( isAlwaysActive )
 import Outputable
 import PprCore		()		-- Instances
@@ -203,7 +207,7 @@ extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEn
 -- 'extendIdSubst' and 'extendTvSubst'
 extendSubst :: Subst -> Var -> CoreArg -> Subst
 extendSubst (Subst in_scope ids tvs) tv (Type ty)
-  = ASSERT( isTyVar tv ) Subst in_scope ids (extendVarEnv tvs tv ty)
+  = ASSERT( isTyCoVar tv ) Subst in_scope ids (extendVarEnv tvs tv ty)
 extendSubst (Subst in_scope ids tvs) id expr
   = ASSERT( isId id ) Subst in_scope (extendVarEnv ids id expr) tvs
 
@@ -301,7 +305,11 @@ subst_expr subst expr
     go (Lit lit)       = Lit lit
     go (App fun arg)   = App (go fun) (go arg)
     go (Note note e)   = Note (go_note note) (go e)
-    go (Cast e co)     = Cast (go e) (optCoercion (getTvSubst subst) co)
+    go (Cast e co) 
+      | isIdentityCoercion co' = go e
+      | otherwise              = Cast (go e) co'
+      where
+        co' = optCoercion (getTvSubst subst) co
 	-- Optimise coercions as we go; this is good, for example
 	-- in the RHS of rules, which are only substituted in
 
@@ -385,8 +393,8 @@ preserve occ info in rules.
 -- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
 substBndr :: Subst -> Var -> (Subst, Var)
 substBndr subst bndr
-  | isTyVar bndr  = substTyVarBndr subst bndr
-  | otherwise     = substIdBndr (text "var-bndr") subst subst bndr
+  | isTyCoVar bndr  = substTyVarBndr subst bndr
+  | otherwise       = substIdBndr (text "var-bndr") subst subst bndr
 
 -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
 substBndrs :: Subst -> [Var] -> (Subst, [Var])
@@ -521,7 +529,6 @@ substIdType subst@(Subst _ _ tv_env) id
 
 ------------------
 -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.
--- Always zaps the unfolding, to save substitution work
 substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
 substIdInfo subst new_id info
   | nothing_to_do = Nothing
@@ -601,7 +608,9 @@ substSpec subst new_id (SpecInfo rules rhs_fvs)
 ------------------
 substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
 substRulesForImportedIds subst rules 
-  = map (substRule subst (\name -> name)) rules
+  = map (substRule subst not_needed) rules
+  where
+    not_needed name = pprPanic "substRulesForImportedIds" (ppr name)
 
 ------------------
 substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
@@ -615,9 +624,12 @@ substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
 
 substRule _ _ rule@(BuiltinRule {}) = rule
 substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
-                                       , ru_fn = fn_name, ru_rhs = rhs })
+                                       , ru_fn = fn_name, ru_rhs = rhs
+                                       , ru_local = is_local })
   = rule { ru_bndrs = bndrs', 
-	   ru_fn    = subst_ru_fn fn_name,
+	   ru_fn    = if is_local 
+                      	then subst_ru_fn fn_name 
+                      	else fn_name,
 	   ru_args  = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args,
 	   ru_rhs   = substExpr (text "subst-rule" <+> ppr fn_name) subst' rhs }
   where
@@ -664,7 +676,7 @@ simpleOptExpr :: CoreExpr -> CoreExpr
 
 simpleOptExpr expr
   = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)
-    go init_subst (occurAnalyseExpr expr)
+    simple_opt_expr init_subst (occurAnalyseExpr expr)
   where
     init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
 	-- It's potentially important to make a proper in-scope set
@@ -677,74 +689,173 @@ simpleOptExpr expr
 	-- It's a bit painful to call exprFreeVars, because it makes
 	-- three passes instead of two (occ-anal, and go)
 
-    go subst (Var v)          = lookupIdSubst (text "simpleOptExpr") subst v
-    go subst (App e1 e2)      = App (go subst e1) (go subst e2)
-    go subst (Type ty)        = Type (substTy subst ty)
-    go _     (Lit lit)        = Lit lit
-    go subst (Note note e)    = Note note (go subst e)
-    go subst (Cast e co)      = Cast (go subst e) (substTy subst co)
-    go subst (Let bind body)  = go_let subst bind body
-    go subst (Lam bndr body)  = Lam bndr' (go subst' body)
-		              where
-			        (subst', bndr') = substBndr subst bndr
-
-    go subst (Case e b ty as) = Case (go subst e) b' 
-				     (substTy subst ty)
-				     (map (go_alt subst') as)
-			      where
-			  	 (subst', b') = substBndr subst b
+----------------------
+simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> IO ([CoreBind], [CoreRule])
+simpleOptPgm dflags binds rules
+  = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"
+		       (pprCoreBindings occ_anald_binds);
 
+       ; return (reverse binds', substRulesForImportedIds subst' rules) }
+  where
+    occ_anald_binds  = occurAnalysePgm binds rules
+    (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds
+                       
+    do_one (subst, binds') bind 
+      = case simple_opt_bind subst bind of
+          (subst', Nothing)    -> (subst', binds')
+          (subst', Just bind') -> (subst', bind':binds')
+
+----------------------
+type InVar   = Var
+type OutVar  = Var
+type InId    = Id
+type OutId   = Id
+type InExpr  = CoreExpr
+type OutExpr = CoreExpr
+
+-- In these functions the substitution maps InVar -> OutExpr
+
+----------------------
+simple_opt_expr :: Subst -> InExpr -> OutExpr
+simple_opt_expr subst expr
+  = go expr
+  where
+    go (Var v)          = lookupIdSubst (text "simpleOptExpr") subst v
+    go (App e1 e2)      = App (go e1) (go e2)
+    go (Type ty)        = Type (substTy subst ty)
+    go (Lit lit)        = Lit lit
+    go (Note note e)    = Note note (go e)
+    go (Cast e co)      | isIdentityCoercion co' = go e
+       	                | otherwise              = Cast (go e) co' 
+                        where
+                          co' = substTy subst co
+
+    go (Let bind body)  = maybeLet mb_bind (simple_opt_expr subst' body)
+                        where
+                          (subst', mb_bind) = simple_opt_bind subst bind
+    go lam@(Lam {})     = go_lam [] subst lam
+    go (Case e b ty as) = Case (go e) b' (substTy subst ty)
+       			       (map (go_alt subst') as)
+       		        where
+       		  	  (subst', b') = subst_opt_bndr subst b
 
     ----------------------
-    go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
-				 where
-				   (subst', bndrs') = substBndrs subst bndrs
-
-    ----------------------
-    go_let subst (Rec prs) body
-      = Let (Rec (reverse rev_prs')) (go subst'' body)
+    go_alt subst (con, bndrs, rhs) 
+      = (con, bndrs', simple_opt_expr subst' rhs)
       where
-	(subst', bndrs')    = substRecBndrs subst (map fst prs)
-	(subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
-	do_pr (subst, prs) ((b,r), b') = case go_bind subst b r of
-	      	      	   	       	   Left subst' -> (subst', prs)
-					   Right r'    -> (subst,  (b',r'):prs)
-
-    go_let subst (NonRec b r) body
-      = case go_bind subst b r of
-          Left subst' -> go subst' body
-	  Right r'    -> Let (NonRec b' r') (go subst' body)
-	  	      where
-		         (subst', b') = substBndr subst b
-
+	(subst', bndrs') = subst_opt_bndrs subst bndrs
 
     ----------------------
-    go_bind :: Subst -> Var -> CoreExpr -> Either Subst CoreExpr
-        -- (go_bind subst old_var old_rhs)  
-	--   either extends subst with (old_var -> new_rhs)
-	--   or     return new_rhs for a binding new_var = new_rhs
-    go_bind subst b r
-      | Type ty <- r
-      , isTyVar b 	-- let a::* = TYPE ty in <body>
-      = Left (extendTvSubst subst b (substTy subst ty))
-
-      | isId b		-- let x = e in <body>
-      , safe_to_inline (idOccInfo b) || exprIsTrivial r'
-      , isAlwaysActive (idInlineActivation b)	-- Note [Inline prag in simplOpt]
-      = Left (extendIdSubst subst b r')
-      
-      | otherwise
-      = Right r'
-      where
-        r' = go subst r
+    -- go_lam tries eta reduction
+    go_lam bs' subst (Lam b e) 
+       = go_lam (b':bs') subst' e
+       where
+         (subst', b') = subst_opt_bndr subst b
+    go_lam bs' subst e 
+       | Just etad_e <- tryEtaReduce bs e' = etad_e
+       | otherwise                         = mkLams bs e'
+       where
+         bs = reverse bs'
+         e' = simple_opt_expr subst e
+
+----------------------
+simple_opt_bind :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
+simple_opt_bind subst (Rec prs)
+  = (subst'', Just (Rec (reverse rev_prs')))
+  where
+    (subst', bndrs')    = subst_opt_bndrs subst (map fst prs)
+    (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
+    do_pr (subst, prs) ((b,r), b') = case simple_opt_pair subst b r of
+          	      	   	       Left subst' -> (subst', prs)
+    				       Right r'    -> (subst,  (b2,r'):prs)
+                                           where
+                             	             b2 = add_info subst b b'
+
+simple_opt_bind subst (NonRec b r)
+  = case simple_opt_pair subst b r of
+      Left ext_subst -> (ext_subst, Nothing)
+      Right r'       -> (subst', Just (NonRec b2 r'))
+	  	     where
+		        (subst', b') = subst_opt_bndr subst b
+			b2 = add_info subst' b b'
+
+----------------------
+simple_opt_pair :: Subst -> InVar -> InExpr -> Either Subst OutExpr
+    -- (simple_opt_pair subst in_var in_rhs)  
+    --   either extends subst with (in_var -> out_rhs)
+    --   or     return out_rhs for a binding out_var = out_rhs
+simple_opt_pair subst b r
+  | Type ty <- r 	-- let a::* = TYPE ty in <body>
+  = ASSERT( isTyCoVar b )
+    Left (extendTvSubst subst b (substTy subst ty))
+
+  | isId b		-- let x = e in <body>
+  , safe_to_inline (idOccInfo b) 
+  , isAlwaysActive (idInlineActivation b)	-- Note [Inline prag in simplOpt]
+  , not (isStableUnfolding (idUnfolding b))
+  , not (isExportedId b)
+  = Left (extendIdSubst subst b r')
+  
+  | otherwise
+  = Right r'
+  where
+    r' = simple_opt_expr subst r
 
-    ----------------------
 	-- Unconditionally safe to inline
     safe_to_inline :: OccInfo -> Bool
-    safe_to_inline IAmDead                  = True
-    safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
     safe_to_inline (IAmALoopBreaker {})     = False
-    safe_to_inline NoOccInfo                = False
+    safe_to_inline IAmDead                  = True
+    safe_to_inline (OneOcc in_lam one_br _) = (not in_lam && one_br) || exprIsTrivial r'
+    safe_to_inline NoOccInfo                = exprIsTrivial r'
+
+----------------------
+subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar)
+subst_opt_bndr subst bndr
+  | isTyCoVar bndr  = substTyVarBndr subst bndr
+  | otherwise       = subst_opt_id_bndr subst bndr
+
+subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId)
+-- Nuke all fragile IdInfo, unfolding, and RULES; 
+--    it gets added back later by add_info
+-- Rather like SimplEnv.substIdBndr
+--
+-- It's important to zap fragile OccInfo (which CoreSubst.SubstIdBndr 
+-- carefully does not do) because simplOptExpr invalidates it
+
+subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst) old_id
+  = (Subst new_in_scope new_id_subst tv_subst, new_id)
+  where
+    id1	   = uniqAway in_scope old_id
+    id2    = setIdType id1 (substTy subst (idType old_id))
+    new_id = zapFragileIdInfo id2	-- Zaps rules, worker-info, unfolding
+					-- and fragile OccInfo
+    new_in_scope = in_scope `extendInScopeSet` new_id
+
+	-- Extend the substitution if the unique has changed,
+	-- or there's some useful occurrence information
+	-- See the notes with substTyVarBndr for the delSubstEnv
+    new_id_subst | new_id /= old_id
+	         = extendVarEnv id_subst old_id (Var new_id)
+	         | otherwise 
+	         = delVarEnv id_subst old_id
+
+----------------------
+subst_opt_bndrs :: Subst -> [InVar] -> (Subst, [OutVar])
+subst_opt_bndrs subst bndrs
+  = mapAccumL subst_opt_bndr subst bndrs
+
+----------------------
+add_info :: Subst -> InVar -> OutVar -> OutVar
+add_info subst old_bndr new_bndr 
+ | isTyCoVar old_bndr = new_bndr
+ | otherwise          = maybeModifyIdInfo mb_new_info new_bndr
+ where
+   mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
+
+----------------------
+maybeLet :: Maybe CoreBind -> CoreExpr -> CoreExpr
+maybeLet Nothing  e = e
+maybeLet (Just b) e = Let b e
 \end{code}
 
 Note [Inline prag in simplOpt]
@@ -764,4 +875,5 @@ we don't know what phase we're in.  Here's an example
   bar n = foo n 1
 
 When inlining 'foo' in 'bar' we want the let-binding for 'inner' 
-to remain visible until Phase 1
\ No newline at end of file
+to remain visible until Phase 1
+
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index b7a859f..2ad111f 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -26,7 +26,7 @@ module CoreSyn (
 	mkConApp, mkTyBind,
 	varToCoreExpr, varsToCoreExprs,
 
-        isTyVar, isId, cmpAltCon, cmpAlt, ltAlt,
+        isTyCoVar, isId, cmpAltCon, cmpAlt, ltAlt,
 	
 	-- ** Simple 'Expr' access functions and predicates
 	bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
@@ -87,7 +87,7 @@ import Util
 import Data.Data
 import Data.Word
 
-infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`
+infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`
 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
 \end{code}
 
@@ -100,8 +100,6 @@ infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`
 These data types are the heart of the compiler
 
 \begin{code}
-infixl 8 `App`	-- App brackets to the left
-
 -- | This is the data type that represents GHCs core intermediate language. Currently
 -- GHC uses System FC <http://research.microsoft.com/~simonpj/papers/ext-f/> for this purpose,
 -- which is closely related to the simpler and better known System F <http://en.wikipedia.org/wiki/System_F>.
@@ -975,7 +973,7 @@ collectTyAndValBinders expr
 collectTyBinders expr
   = go [] expr
   where
-    go tvs (Lam b e) | isTyVar b = go (b:tvs) e
+    go tvs (Lam b e) | isTyCoVar b = go (b:tvs) e
     go tvs e			 = (reverse tvs, e)
 
 collectValBinders expr
diff --git a/compiler/coreSyn/CoreTidy.lhs b/compiler/coreSyn/CoreTidy.lhs
index b77186e..c928be4 100644
--- a/compiler/coreSyn/CoreTidy.lhs
+++ b/compiler/coreSyn/CoreTidy.lhs
@@ -17,7 +17,7 @@ import CoreSyn
 import CoreArity
 import Id
 import IdInfo
-import Type
+import TcType( tidyType, tidyTyVarBndr )
 import Var
 import VarEnv
 import UniqFM
@@ -123,7 +123,7 @@ tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v
 -- tidyBndr is used for lambda and case binders
 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
 tidyBndr env var
-  | isTyVar var = tidyTyVarBndr env var
+  | isTyCoVar var = tidyTyVarBndr env var
   | otherwise   = tidyIdBndr env var
 
 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 0a398d1..24d6330 100644
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -1112,7 +1112,7 @@ interestingArg e = go e 0
     go (Note _ a) 	 n = go a n
     go (Cast e _) 	 n = go e n
     go (Lam v e)  	 n 
-       | isTyVar v	   = go e n
+       | isTyCoVar v	   = go e n
        | n>0	 	   = go e (n-1)
        | otherwise	   = ValueArg
     go (Let _ e)  	 n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 05ef9a3..1a21704 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -38,6 +38,9 @@ module CoreUtils (
 	-- * Equality
 	cheapEqExpr, eqExpr, eqExprX,
 
+	-- * Eta reduction
+	tryEtaReduce,
+
 	-- * Manipulating data constructors and types
 	applyTypeToArgs, applyTypeToArg,
         dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
@@ -109,7 +112,7 @@ coreAltType (_,bs,rhs)
   where
     ty           = exprType rhs
     free_tvs     = tyVarsOfType ty
-    bad_binder b = isTyVar b && b `elemVarSet` free_tvs
+    bad_binder b = isTyCoVar b && b `elemVarSet` free_tvs
 
 coreAltsType :: [CoreAlt] -> Type
 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives
@@ -142,10 +145,10 @@ Various possibilities suggest themselves:
    we are doing here.  It's not too expensive, I think.
 
 \begin{code}
-mkPiType  :: Var   -> Type -> Type
+mkPiType  :: EvVar -> Type -> Type
 -- ^ Makes a @(->)@ type or a forall type, depending
 -- on whether it is given a type variable or a term variable.
-mkPiTypes :: [Var] -> Type -> Type
+mkPiTypes :: [EvVar] -> Type -> Type
 -- ^ 'mkPiType' for multiple type or value arguments
 
 mkPiType v ty
@@ -195,7 +198,7 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
 \begin{code}
 -- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
 mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
-mkCoerceI IdCo e = e
+mkCoerceI (IdCo _) e = e
 mkCoerceI (ACo co) e = mkCoerce co e
 
 -- | Wrap the given expression in the coercion safely, coalescing nested coercions
@@ -1077,7 +1080,7 @@ noteSize (SCC cc)       = cc `seq` 1
 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
  
 varSize :: Var -> Int
-varSize b  | isTyVar b = 1
+varSize b  | isTyCoVar b = 1
 	   | otherwise = seqType (idType b)		`seq`
 			 megaSeqIdInfo (idInfo b) 	`seq`
 			 1
@@ -1161,6 +1164,100 @@ hashVar (_,env) v
  = fromIntegral (lookupVarEnv env v `orElse` hashName (idName v))
 \end{code}
 
+
+%************************************************************************
+%*									*
+		Eta reduction
+%*									*
+%************************************************************************
+
+Note [Eta reduction conditions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We try for eta reduction here, but *only* if we get all the way to an
+trivial expression.  We don't want to remove extra lambdas unless we
+are going to avoid allocating this thing altogether.
+
+There are some particularly delicate points here:
+
+* Eta reduction is not valid in general:  
+	\x. bot  /=  bot
+  This matters, partly for old-fashioned correctness reasons but,
+  worse, getting it wrong can yield a seg fault. Consider
+	f = \x.f x
+	h y = case (case y of { True -> f `seq` True; False -> False }) of
+		True -> ...; False -> ...
+
+  If we (unsoundly) eta-reduce f to get f=f, the strictness analyser
+  says f=bottom, and replaces the (f `seq` True) with just
+  (f `cast` unsafe-co).  BUT, as thing stand, 'f' got arity 1, and it
+  *keeps* arity 1 (perhaps also wrongly).  So CorePrep eta-expands 
+  the definition again, so that it does not termninate after all.
+  Result: seg-fault because the boolean case actually gets a function value.
+  See Trac #1947.
+
+  So it's important to to the right thing.
+
+* Note [Arity care]: we need to be careful if we just look at f's
+  arity. Currently (Dec07), f's arity is visible in its own RHS (see
+  Note [Arity robustness] in SimplEnv) so we must *not* trust the
+  arity when checking that 'f' is a value.  Otherwise we will
+  eta-reduce
+      f = \x. f x
+  to
+      f = f
+  Which might change a terminiating program (think (f `seq` e)) to a 
+  non-terminating one.  So we check for being a loop breaker first.
+
+  However for GlobalIds we can look at the arity; and for primops we
+  must, since they have no unfolding.  
+
+* Regardless of whether 'f' is a value, we always want to 
+  reduce (/\a -> f a) to f
+  This came up in a RULE: foldr (build (/\a -> g a))
+  did not match 	  foldr (build (/\b -> ...something complex...))
+  The type checker can insert these eta-expanded versions,
+  with both type and dictionary lambdas; hence the slightly 
+  ad-hoc isDictId
+
+* Never *reduce* arity. For example
+      f = \xy. g x y
+  Then if h has arity 1 we don't want to eta-reduce because then
+  f's arity would decrease, and that is bad
+
+These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
+Alas.
+
+\begin{code}
+tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
+tryEtaReduce bndrs body 
+  = go (reverse bndrs) body
+  where
+    incoming_arity = count isId bndrs
+
+    go (b : bs) (App fun arg) | ok_arg b arg = go bs fun	-- Loop round
+    go []       fun           | ok_fun fun   = Just fun		-- Success!
+    go _        _			     = Nothing		-- Failure!
+
+	-- Note [Eta reduction conditions]
+    ok_fun (App fun (Type ty)) 
+	| not (any (`elemVarSet` tyVarsOfType ty) bndrs)
+	=  ok_fun fun
+    ok_fun (Var fun_id)
+	=  not (fun_id `elem` bndrs)
+	&& (ok_fun_id fun_id || all ok_lam bndrs)
+    ok_fun _fun = False
+
+    ok_fun_id fun = fun_arity fun >= incoming_arity
+
+    fun_arity fun 	      -- See Note [Arity care]
+       | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0
+       | otherwise = idArity fun   	      
+
+    ok_lam v = isTyCoVar v || isDictId v
+
+    ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection{Determining non-updatable right-hand-sides}
diff --git a/compiler/coreSyn/MkCore.lhs b/compiler/coreSyn/MkCore.lhs
index 7714b58..3e0ad62 100644
--- a/compiler/coreSyn/MkCore.lhs
+++ b/compiler/coreSyn/MkCore.lhs
@@ -4,7 +4,8 @@ module MkCore (
         -- * Constructing normal syntax
         mkCoreLet, mkCoreLets,
         mkCoreApp, mkCoreApps, mkCoreConApps,
-        mkCoreLams, mkWildCase, mkWildBinder, mkIfThenElse,
+        mkCoreLams, mkWildCase, mkIfThenElse,
+        mkWildValBinder, mkWildEvBinder,
         
         -- * Constructing boxed literals
         mkWordExpr, mkWordExprWord,
@@ -38,7 +39,7 @@ module MkCore (
 #include "HsVersions.h"
 
 import Id
-import Var      ( setTyVarUnique )
+import Var      ( EvVar, mkWildCoVar, setTyVarUnique )
 
 import CoreSyn
 import CoreUtils        ( exprType, needsCaseBinding, bindNonRec )
@@ -128,7 +129,7 @@ mk_val_app fun arg arg_ty _        -- See Note [CoreSyn let/app invariant]
 mk_val_app fun arg arg_ty res_ty
   = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]
   where
-    arg_id = mkWildBinder arg_ty    
+    arg_id = mkWildValBinder arg_ty    
 	-- Lots of shadowing, but it doesn't matter,
         -- because 'fun ' should not have a free wild-id
 	--
@@ -138,19 +139,22 @@ mk_val_app fun arg arg_ty res_ty
 	-- is if you take apart this case expression, and pass a 
 	-- fragmet of it as the fun part of a 'mk_val_app'.
 
+mkWildEvBinder :: PredType -> EvVar
+mkWildEvBinder pred@(EqPred {}) = mkWildCoVar     (mkPredTy pred)
+mkWildEvBinder pred             = mkWildValBinder (mkPredTy pred)
 
 -- | Make a /wildcard binder/. This is typically used when you need a binder 
 -- that you expect to use only at a *binding* site.  Do not use it at
 -- occurrence sites because it has a single, fixed unique, and it's very
 -- easy to get into difficulties with shadowing.  That's why it is used so little.
-mkWildBinder :: Type -> Id
-mkWildBinder ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty
+mkWildValBinder :: Type -> Id
+mkWildValBinder ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty
 
 mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr
 -- Make a case expression whose case binder is unused
 -- The alts should not have any occurrences of WildId
 mkWildCase scrut scrut_ty res_ty alts 
-  = Case scrut (mkWildBinder scrut_ty) res_ty alts
+  = Case scrut (mkWildValBinder scrut_ty) res_ty alts
 
 mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
 mkIfThenElse guard then_expr else_expr
diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs
index eae4b93..9b9ca5e 100644
--- a/compiler/coreSyn/MkExternalCore.lhs
+++ b/compiler/coreSyn/MkExternalCore.lhs
@@ -145,7 +145,7 @@ make_exp (App e1 e2) = do
    rator <- make_exp e1
    rand <- make_exp e2
    return $ C.App rator rand
-make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> 
+make_exp (Lam v e) | isTyCoVar v = make_exp e >>= (\ b -> 
                                     return $ C.Lam (C.Tb (make_tbind v)) b)
 make_exp (Lam v e) | otherwise = make_exp e >>= (\ b -> 
                                     return $ C.Lam (C.Vb (make_vbind v)) b)
@@ -169,7 +169,7 @@ make_alt (DataAlt dcon, vs, e) = do
            (map make_tbind tbs)
            (map make_vbind vbs)
 	   newE
-	where (tbs,vbs) = span isTyVar vs
+	where (tbs,vbs) = span isTyCoVar vs
 make_alt (LitAlt l,_,e)   = make_exp e >>= (return . (C.Alit (make_lit l)))
 make_alt (DEFAULT,[],e)   = make_exp e >>= (return . C.Adefault)
 -- This should never happen, as the DEFAULT alternative binds no variables,
diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs
index 37e22cf..1908667 100644
--- a/compiler/coreSyn/PprCore.lhs
+++ b/compiler/coreSyn/PprCore.lhs
@@ -247,7 +247,7 @@ instance OutputableBndr Var where
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
-  | isTyVar binder = pprKindedTyVarBndr binder
+  | isTyCoVar binder = pprKindedTyVarBndr binder
   | otherwise      = pprTypedBinder binder $$ 
 		     ppIdInfo binder (idInfo binder)
 
@@ -258,7 +258,7 @@ pprCoreBinder bind_site bndr
 
 pprUntypedBinder :: Var -> SDoc
 pprUntypedBinder binder
-  | isTyVar binder = ptext (sLit "@") <+> ppr binder	-- NB: don't print kind
+  | isTyCoVar binder = ptext (sLit "@") <+> ppr binder	-- NB: don't print kind
   | otherwise      = pprIdBndr binder
 
 pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
@@ -266,7 +266,7 @@ pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
 pprTypedLCBinder bind_site debug_on var
   | not debug_on && isDeadBinder var    = char '_'
   | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
-  | isTyVar var                         = parens (pprKindedTyVarBndr var)
+  | isTyCoVar var                         = parens (pprKindedTyVarBndr var)
   | otherwise = parens (hang (pprIdBndr var) 
                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
               where
@@ -277,7 +277,7 @@ pprTypedLCBinder bind_site debug_on var
 pprTypedBinder :: Var -> SDoc
 -- Print binder with a type or kind signature (not paren'd)
 pprTypedBinder binder
-  | isTyVar binder  = pprKindedTyVarBndr binder
+  | isTyCoVar binder  = pprKindedTyVarBndr binder
   | otherwise	    = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 
 pprKindedTyVarBndr :: TyVar -> SDoc
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 6bdc8a1..f32ce93 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -138,9 +138,9 @@ addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
 addTickLHsBinds binds = mapBagM addTickLHsBind binds
 
 addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
-addTickLHsBind (L pos (AbsBinds abs_tvs abs_dicts abs_exports abs_binds)) = do
-  abs_binds' <- addTickLHsBinds abs_binds
-  return $ L pos $ AbsBinds abs_tvs abs_dicts abs_exports abs_binds'
+addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds })) = do
+  binds' <- addTickLHsBinds binds
+  return $ L pos $ bind { abs_binds = binds' }
 addTickLHsBind (L pos (funBind@(FunBind { fun_id = (L _ id)  }))) = do 
   let name = getOccString id
   decl_path <- getPathEntry
@@ -461,7 +461,7 @@ addTickStmt isGuard stmt@(RecStmt {})
        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)
        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)
-       ; dicts' <- addTickDictBinds (recS_dicts stmt)
+       ; dicts' <- addTickEvBinds (recS_dicts stmt)
        ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'
                       , recS_mfix_fn = mfix', recS_bind_fn = bind'
                       , recS_dicts = dicts' }) }
@@ -507,7 +507,7 @@ addTickHsIPBinds :: HsIPBinds Id -> TM (HsIPBinds Id)
 addTickHsIPBinds (IPBinds ipbinds dictbinds) =
 	liftM2 IPBinds
 		(mapM (liftL (addTickIPBind)) ipbinds)
-		(addTickDictBinds dictbinds)
+		(return dictbinds)
 
 addTickIPBind :: IPBind Id -> TM (IPBind Id)
 addTickIPBind (IPBind nm e) =
@@ -535,8 +535,8 @@ addTickHsCmdTop (HsCmdTop cmd tys ty syntaxtable) =
 addTickLHsCmd ::  LHsCmd Id -> TM (LHsCmd Id)
 addTickLHsCmd x = addTickLHsExpr x
 
-addTickDictBinds :: DictBinds Id -> TM (DictBinds Id)
-addTickDictBinds x = addTickLHsBinds x
+addTickEvBinds :: TcEvBinds -> TM TcEvBinds
+addTickEvBinds x = return x   -- No coverage testing for dictionary binding
 
 addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id)
 addTickHsRecordBinds (HsRecFields fields dd) 
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 64fff0d..9616c62 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -17,6 +17,7 @@ import MkIface
 import Id
 import Name
 import CoreSyn
+import CoreSubst
 import PprCore
 import DsMonad
 import DsExpr
@@ -27,6 +28,7 @@ import DsExpr		()	-- Forces DsExpr to be compiled; DsBinds only
 import Module
 import RdrName
 import NameSet
+import NameEnv
 import Rules
 import CoreMonad	( endPass, CoreToDo(..) )
 import ErrUtils
@@ -35,7 +37,9 @@ import SrcLoc
 import Maybes
 import FastString
 import Coverage
+import Util
 
+import Data.List
 import Data.IORef
 \end{code}
 
@@ -65,6 +69,7 @@ deSugar hsc_env
 	    	    	    tcg_warns        = warns,
 	    	    	    tcg_anns         = anns,
 			    tcg_binds        = binds,
+			    tcg_ev_binds     = ev_binds,
 			    tcg_fords        = fords,
 			    tcg_rules        = rules,
 		    	    tcg_insts        = insts,
@@ -83,42 +88,51 @@ deSugar hsc_env
               <- case target of
 	           HscNothing ->
                        return (emptyMessages,
-                               Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
+                               Just ([], [], [], NoStubs, hpcInfo, emptyModBreaks))
                    _        -> do
                      (binds_cvr,ds_hpc_info, modBreaks)
 			 <- if (opt_Hpc
 				  || target == HscInterpreted)
 			       && (not (isHsBoot hsc_src))
-                              then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds 
+                              then addCoverageTicksToBinds dflags mod mod_loc
+                                                           (typeEnvTyCons type_env) binds 
                               else return (binds, hpcInfo, emptyModBreaks)
                      initDs hsc_env mod rdr_env type_env $ do
+		         ds_ev_binds <- dsEvBinds ev_binds
 		         core_prs <- dsTopLHsBinds auto_scc binds_cvr
 	                 (ds_fords, foreign_prs) <- dsForeigns fords
 	                 let all_prs = foreign_prs ++ core_prs
-		         ds_rules <- mapM dsRule rules
-		         return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks)
+		         mb_rules <- mapM dsRule rules
+		         return (ds_ev_binds, all_prs, mb_rules, ds_fords, ds_hpc_info, modBreaks)
 
 	; case mb_res of {
 	   Nothing -> return (msgs, Nothing) ;
-	   Just (all_prs, ds_rules, ds_fords,ds_hpc_info, modBreaks) -> do
+	   Just (ds_ev_binds, all_prs, mb_rules, ds_fords,ds_hpc_info, modBreaks) -> do
 
 	{ 	-- Add export flags to bindings
 	  keep_alive <- readIORef keep_var
-	; let final_prs = addExportFlags target export_set
-                                 keep_alive all_prs 
-	      ds_binds  = [Rec final_prs]
+	; let (rules_for_locals, rules_for_imps) 
+                   = partition isLocalRule (catMaybes mb_rules)
+              final_prs = addExportFlagsAndRules target
+	      		      export_set keep_alive rules_for_locals all_prs 
+
+              final_pgm = combineEvBinds ds_ev_binds final_prs
 	-- Notice that we put the whole lot in a big Rec, even the foreign binds
 	-- When compiling PrelFloat, which defines data Float = F# Float#
 	-- we want F# to be in scope in the foreign marshalling code!
 	-- You might think it doesn't matter, but the simplifier brings all top-level
 	-- things into the in-scope set before simplifying; so we get no unfolding for F#!
 
-	-- Lint result if necessary
-	; endPass dflags CoreDesugar ds_binds ds_rules
+	-- Lint result if necessary, and print
+        ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $
+               (vcat [ pprCoreBindings final_pgm
+                     , pprRules rules_for_imps ])
+
+	; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps
+	      		 -- The simpleOptPgm gets rid of type 
+			 -- bindings plus any stupid dead code
 
-	-- Dump output
-	; doIfSet (dopt Opt_D_dump_ds dflags) 
-		  (printDump (ppr_ds_rules ds_rules))
+	; endPass dflags CoreDesugar ds_binds ds_rules_for_imps
 
         ; used_names <- mkUsedNames tcg_env
 	; deps <- mkDependencies tcg_env
@@ -139,7 +153,7 @@ deSugar hsc_env
 		mg_fam_insts 	= fam_insts,
 		mg_inst_env     = inst_env,
 		mg_fam_inst_env = fam_inst_env,
-	        mg_rules     	= ds_rules,
+	        mg_rules     	= ds_rules_for_imps,
 		mg_binds     	= ds_binds,
 		mg_foreign   	= ds_fords,
 		mg_hpc_info  	= ds_hpc_info,
@@ -149,6 +163,33 @@ deSugar hsc_env
         ; return (msgs, Just mod_guts)
 	}}}
 
+
+combineEvBinds :: [DsEvBind] -> [(Id,CoreExpr)] -> [CoreBind]
+-- Top-level bindings can include coercion bindings, but not via superclasses
+-- See Note [Top-level evidence]
+combineEvBinds [] val_prs 
+  = [Rec val_prs]
+combineEvBinds (LetEvBind (NonRec b r) : bs) val_prs
+  | isId b    = combineEvBinds bs ((b,r):val_prs)
+  | otherwise = NonRec b r : combineEvBinds bs val_prs
+combineEvBinds (LetEvBind (Rec prs) : bs) val_prs 
+  = combineEvBinds bs (prs ++ val_prs)
+combineEvBinds (CaseEvBind x _ _ : _) _
+  = pprPanic "topEvBindPairs" (ppr x)
+\end{code}
+
+Note [Top-level evidence]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Top-level evidence bindings may be mutually recursive with the top-level value
+bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec
+because the occurrence analyser doesn't teke account of type/coercion variables
+when computing dependencies.  
+
+So we pull out the type/coercion variables (which are in dependency order),
+and Rec the rest.
+
+
+\begin{code}
 mkAutoScc :: DynFlags -> Module -> NameSet -> AutoScc
 mkAutoScc dflags mod exports
   | not opt_SccProfilingOn 	-- No profiling
@@ -187,36 +228,45 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do
         dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
 
         return (msgs, Just expr)
+\end{code}
 
---		addExportFlags
--- Set the no-discard flag if either 
---	a) the Id is exported
---	b) it's mentioned in the RHS of an orphan rule
---	c) it's in the keep-alive set
---
--- It means that the binding won't be discarded EVEN if the binding
--- ends up being trivial (v = w) -- the simplifier would usually just 
--- substitute w for v throughout, but we don't apply the substitution to
--- the rules (maybe we should?), so this substitution would make the rule
--- bogus.
-
--- You might wonder why exported Ids aren't already marked as such;
--- it's just because the type checker is rather busy already and
--- I didn't want to pass in yet another mapping.
-
-addExportFlags :: HscTarget -> NameSet -> NameSet -> [(Id, t)]
-               -> [(Id, t)]
-addExportFlags target exports keep_alive prs
-  = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
+%************************************************************************
+%*									*
+%* 		Add rules and export flags to binders
+%*									*
+%************************************************************************
+
+\begin{code}
+addExportFlagsAndRules 
+    :: HscTarget -> NameSet -> NameSet -> [CoreRule]
+    -> [(Id, t)] -> [(Id, t)]
+addExportFlagsAndRules target exports keep_alive rules prs
+  = mapFst add_one prs
   where
-    add_export bndr
-	| dont_discard bndr = setIdExported bndr
+    add_one bndr = add_rules name (add_export name bndr)
+       where
+         name = idName bndr
+
+    ---------- Rules --------
+	-- See Note [Attach rules to local ids]
+	-- NB: the binder might have some existing rules,
+	-- arising from specialisation pragmas
+    add_rules name bndr
+	| Just rules <- lookupNameEnv rule_base name
+	= bndr `addIdSpecialisations` rules
+	| otherwise
+	= bndr
+    rule_base = extendRuleBaseList emptyRuleBase rules
+
+    ---------- Export flag --------
+    -- See Note [Adding export flags]
+    add_export name bndr
+	| dont_discard name = setIdExported bndr
 	| otherwise	    = bndr
 
-    dont_discard bndr = is_exported name
+    dont_discard :: Name -> Bool
+    dont_discard name = is_exported name
 		     || name `elemNameSet` keep_alive
-		     where
-			name = idName bndr
 
     	-- In interactive mode, we don't want to discard any top-level
     	-- entities at all (eg. do not inline them away during
@@ -228,15 +278,44 @@ addExportFlags target exports keep_alive prs
     is_exported :: Name -> Bool
     is_exported | target == HscInterpreted = isExternalName
 		| otherwise 		   = (`elemNameSet` exports)
-
-ppr_ds_rules :: [CoreRule] -> SDoc
-ppr_ds_rules [] = empty
-ppr_ds_rules rules
-  = blankLine $$ text "-------------- DESUGARED RULES -----------------" $$
-    pprRules rules
 \end{code}
 
 
+Note [Adding export flags]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Set the no-discard flag if either 
+	a) the Id is exported
+	b) it's mentioned in the RHS of an orphan rule
+	c) it's in the keep-alive set
+
+It means that the binding won't be discarded EVEN if the binding
+ends up being trivial (v = w) -- the simplifier would usually just 
+substitute w for v throughout, but we don't apply the substitution to
+the rules (maybe we should?), so this substitution would make the rule
+bogus.
+
+You might wonder why exported Ids aren't already marked as such;
+it's just because the type checker is rather busy already and
+I didn't want to pass in yet another mapping.
+
+Note [Attach rules to local ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Find the rules for locally-defined Ids; then we can attach them
+to the binders in the top-level bindings
+
+Reason
+  - It makes the rules easier to look up
+  - It means that transformation rules and specialisations for
+    locally defined Ids are handled uniformly
+  - It keeps alive things that are referred to only from a rule
+    (the occurrence analyser knows about rules attached to Ids)
+  - It makes sure that, when we apply a rule, the free vars
+    of the RHS are more likely to be in scope
+  - The imported rules are carried in the in-scope set
+    which is extended on each iteration by the new wave of
+    local binders; any rules which aren't on the binding will
+    thereby get dropped
+
 
 %************************************************************************
 %*									*
@@ -250,23 +329,24 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
   = putSrcSpanDs loc $ 
     do	{ let bndrs' = [var | RuleBndr (L _ var) <- vars]
 
-	; lhs'  <- unsetOptM Opt_EnableRewriteRules $
-	           dsLExpr lhs	-- Note [Desugaring RULE lhss]
+	; lhs' <- unsetOptM Opt_EnableRewriteRules $
+	          dsLExpr lhs	-- Note [Desugaring RULE left hand sides]
 
-	; rhs'  <- dsLExpr rhs
+	; rhs' <- dsLExpr rhs
 
 	-- Substitute the dict bindings eagerly,
 	-- and take the body apart into a (f args) form
-	; case decomposeRuleLhs (mkLams bndrs' lhs') of {
+	; case decomposeRuleLhs lhs' of {
 		Nothing -> do { warnDs msg; return Nothing } ;
-		Just (bndrs, fn_id, args) -> do
+		Just (fn_id, args) -> do
 	
 	{ let local_rule = isLocalId fn_id
 		-- NB: isLocalId is False of implicit Ids.  This is good becuase
 		-- we don't want to attach rules to the bindings of implicit Ids, 
 		-- because they don't show up in the bindings until just before code gen
-	      fn_name = idName fn_id
-	      rule    = mkRule local_rule name act fn_name bndrs args rhs' 
+	      fn_name   = idName fn_id
+	      final_rhs = simpleOptExpr rhs'	-- De-crap it
+	      rule      = mkRule local_rule name act fn_name bndrs' args final_rhs
 	; return (Just rule)
 	} } }
   where
@@ -283,3 +363,5 @@ of cons's. We can achieve that slightly indirectly by
 switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 
 That keeps the desugaring of list comprehensions simple too.
+
+
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 63e5cbe..45fbf07 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -40,7 +40,7 @@ import TysWiredIn
 import BasicTypes
 import PrelNames
 import Outputable
-
+import Bag
 import VarSet
 import SrcLoc
 
@@ -1023,20 +1023,20 @@ See comments in HsUtils for why the other version does not include
 these bindings.
 
 \begin{code}
-collectPatBinders :: OutputableBndr a => LPat a -> [a]
+collectPatBinders :: LPat Id -> [Id]
 collectPatBinders pat = collectl pat []
 
-collectPatsBinders :: OutputableBndr a => [LPat a] -> [a]
+collectPatsBinders :: [LPat Id] -> [Id]
 collectPatsBinders pats = foldr collectl [] pats
 
 ---------------------
-collectl :: OutputableBndr a => LPat a -> [a] -> [a]
+collectl :: LPat Id -> [Id] -> [Id]
 -- See Note [Dictionary binders in ConPatOut]
 collectl (L _ pat) bndrs
   = go pat
   where
     go (VarPat var)               = var : bndrs
-    go (VarPatOut var bs)         = var : collectHsBindsBinders bs
+    go (VarPatOut var bs)         = var : collectEvBinders bs
                                     ++ bndrs
     go (WildPat _)                = bndrs
     go (LazyPat pat)              = collectl pat bndrs
@@ -1050,7 +1050,7 @@ collectl (L _ pat) bndrs
 
     go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)
     go (ConPatOut {pat_args=ps, pat_binds=ds}) =
-                                    collectHsBindsBinders ds
+                                    collectEvBinders ds
                                     ++ foldr collectl bndrs (hsConPatArgs ps)
     go (LitPat _)                 = bndrs
     go (NPat _ _ _)               = bndrs
@@ -1062,4 +1062,13 @@ collectl (L _ pat) bndrs
     go (CoPat _ pat _)            = collectl (noLoc pat) bndrs
     go (ViewPat _ pat _)          = collectl pat bndrs
     go p@(QuasiQuotePat {})       = pprPanic "collectl/go" (ppr p)
+
+collectEvBinders :: TcEvBinds -> [Id]
+collectEvBinders (EvBinds bs)   = foldrBag add_ev_bndr [] bs
+collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
+
+add_ev_bndr :: EvBind -> [Id] -> [Id]
+add_ev_bndr (EvBind b _) bs | isId b    = b:bs
+                            | otherwise = bs
+  -- A worry: what about coercion variable binders??
 \end{code}
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 2c6f361..c886c8e 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -11,8 +11,8 @@ lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, 
-		 dsCoercion,
-		 AutoScc(..)
+		 dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, 
+		 DsEvBind(..), AutoScc(..)
   ) where
 
 #include "HsVersions.h"
@@ -32,30 +32,34 @@ import CoreUtils
 import CoreArity ( etaExpand )
 import CoreUnfold
 import CoreFVs
+import Digraph
 
 import TcType
+import Type
 import TysPrim  ( anyTypeOfKind )
 import CostCentre
 import Module
 import Id
+import TyCon	( tyConDataCons )
+import Class
+import DataCon	( dataConRepType )
 import Name	( localiseName )
 import MkId	( seqId )
-import Var	( Var, TyVar, tyVarKind )
-import IdInfo	( vanillaIdInfo )
+import Var
 import VarSet
 import Rules
 import VarEnv
 import Outputable
 import SrcLoc
 import Maybes
+import OrdList
 import Bag
 import BasicTypes hiding ( TopLevel )
 import FastString
-import StaticFlags	( opt_DsMultiTyVar )
-import Util		( count, lengthExceeds )
+-- import StaticFlags	( opt_DsMultiTyVar )
+import Util
 
 import MonadUtils
-import Control.Monad
 \end{code}
 
 %************************************************************************
@@ -66,31 +70,27 @@ import Control.Monad
 
 \begin{code}
 dsTopLHsBinds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsTopLHsBinds auto_scc binds = ds_lhs_binds auto_scc binds
+dsTopLHsBinds auto_scc binds = do { binds' <- ds_lhs_binds auto_scc binds
+                                  ; return (fromOL binds') }
 
 dsLHsBinds :: LHsBinds Id -> DsM [(Id,CoreExpr)]
-dsLHsBinds binds = ds_lhs_binds NoSccs binds
-
+dsLHsBinds binds = do { binds' <- ds_lhs_binds NoSccs binds
+                      ; return (fromOL binds') }
 
 ------------------------
-ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM [(Id,CoreExpr)]
+ds_lhs_binds :: AutoScc -> LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
 
 	 -- scc annotation policy (see below)
-ds_lhs_binds auto_scc binds =  foldM (dsLHsBind auto_scc) [] (bagToList binds)
+ds_lhs_binds auto_scc binds = do { ds_bs <- mapBagM (dsLHsBind auto_scc) binds
+                                 ; return (foldBag appOL id nilOL ds_bs) }
 
-dsLHsBind :: AutoScc
-	 -> [(Id,CoreExpr)]	-- Put this on the end (avoid quadratic append)
-	 -> LHsBind Id
-	 -> DsM [(Id,CoreExpr)] -- Result
-dsLHsBind auto_scc rest (L loc bind)
-  = putSrcSpanDs loc $ dsHsBind auto_scc rest bind
+dsLHsBind :: AutoScc -> LHsBind Id -> DsM (OrdList (Id,CoreExpr))
+dsLHsBind auto_scc (L loc bind)
+  = putSrcSpanDs loc $ dsHsBind auto_scc bind
 
-dsHsBind :: AutoScc
-	 -> [(Id,CoreExpr)]	-- Put this on the end (avoid quadratic append)
-	 -> HsBind Id
-	 -> DsM [(Id,CoreExpr)] -- Result
+dsHsBind :: AutoScc -> HsBind Id -> DsM (OrdList (Id,CoreExpr))
 
-dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
+dsHsBind _ (VarBind { var_id = var, var_rhs = expr, var_inline = inline_regardless })
   = do	{ core_expr <- dsLExpr expr
 
 	        -- Dictionary bindings are always VarBinds,
@@ -99,25 +99,30 @@ dsHsBind _ rest (VarBind { var_id = var, var_rhs = expr, var_inline = inline_reg
 	; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr'
 	      	   | otherwise         = var
 
-	; return ((var', core_expr') : rest) }
+	; return (unitOL (var', core_expr')) }
 
-dsHsBind _ rest 
-	 (FunBind { fun_id = L _ fun, fun_matches = matches, 
-		    fun_co_fn = co_fn, fun_tick = tick, fun_infix = inf }) 
+dsHsBind _ (FunBind { fun_id = L _ fun, fun_matches = matches 
+		    , fun_co_fn = co_fn, fun_tick = tick 
+                    , fun_infix = inf }) 
  = do	{ (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
 	; body'    <- mkOptTickBox tick body
-	; wrap_fn' <- dsCoercion co_fn 
-	; return ((fun, wrap_fn' (mkLams args body')) : rest) }
+	; wrap_fn' <- dsHsWrapper co_fn 
+	; return (unitOL (fun, wrap_fn' (mkLams args body'))) }
 
-dsHsBind _ rest 
-	 (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
+dsHsBind _ (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty })
   = do	{ body_expr <- dsGuarded grhss ty
 	; sel_binds <- mkSelectorBinds pat body_expr
-	; return (sel_binds ++ rest) }
+	; return (toOL sel_binds) }
 
-dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
-  = do	{ core_prs <- ds_lhs_binds NoSccs binds
-	; let env = mkABEnv exports
+{-
+dsHsBind auto_scc (AbsBinds { abs_tvs = [], abs_ev_vars = []
+                       	    , abs_exports = exports, abs_ev_binds = ev_binds
+                       	    , abs_binds = binds })
+  = do	{ bind_prs    <- ds_lhs_binds NoSccs binds
+        ; ds_ev_binds <- dsTcEvBinds ev_binds
+
+	; let core_prs = addEvPairs ds_ev_binds bind_prs
+              env = mkABEnv exports
 	      do_one (lcl_id, rhs) 
 		| Just (_, gbl_id, _, spec_prags) <- lookupVarEnv env lcl_id
 		= do { let rhs' = addAutoScc auto_scc gbl_id rhs
@@ -137,13 +142,19 @@ dsHsBind auto_scc rest (AbsBinds [] [] exports binds)
 		-- because we can rely on the enclosing dsBind to wrap in Rec
 
 
-dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
+dsHsBind auto_scc rest (AbsBinds { abs_tvs = tyvars, abs_ev_vars = []
+                       		 , abs_exports = exports, abs_ev_binds = ev_binds
+                       		 , abs_binds = binds })
   | opt_DsMultiTyVar	-- This (static) debug flag just lets us
 			-- switch on and off this optimisation to
 			-- see if it has any impact; it is on by default
+  , allOL isLazyEvBind ev_binds
   = 	-- Note [Abstracting over tyvars only]
-    do	{ core_prs <- ds_lhs_binds NoSccs binds
-	; let arby_env = mkArbitraryTypeEnv tyvars exports
+    do	{ bind_prs    <- ds_lhs_binds NoSccs binds
+        ; ds_ev_binds <- dsTcEvBinds ev_binds
+
+	; let core_prs = addEvPairs ds_ev_binds bind_prs
+              arby_env = mkArbitraryTypeEnv tyvars exports
 	      bndrs = mkVarSet (map fst core_prs)
 
 	      add_lets | core_prs `lengthExceeds` 10 = add_some
@@ -179,21 +190,25 @@ dsHsBind auto_scc rest (AbsBinds tyvars [] exports binds)
 						  
 	; (_, core_prs') <- fixDs (\ ~(lg_binds, _) -> mapAndUnzipM (do_one lg_binds) core_prs)
 	; return (concat core_prs' ++ rest) }
+-}
 
-	-- Another common case: one exported variable
+	-- A common case: one exported variable
 	-- Non-recursive bindings come through this way
 	-- So do self-recursive bindings, and recursive bindings
 	-- that have been chopped up with type signatures
-dsHsBind auto_scc rest
-     (AbsBinds all_tyvars dicts [(tyvars, global, local, prags)] binds)
+dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
+               		    , abs_exports = [(tyvars, global, local, prags)]
+               		    , abs_ev_binds = ev_binds, abs_binds = binds })
   = ASSERT( all (`elem` tyvars) all_tyvars )
-    do	{ core_prs <- ds_lhs_binds NoSccs binds
+    do	{ bind_prs    <- ds_lhs_binds NoSccs binds
+        ; ds_ev_binds <- dsTcEvBinds ev_binds
 
-	; let	-- Always treat the binds as recursive, because the 
-	        -- typechecker makes rather mixed-up dictionary bindings
-	        core_bind = Rec core_prs
+	; let	core_bind = Rec (fromOL bind_prs)
 	        rhs       = addAutoScc auto_scc global $
-			    mkLams tyvars $ mkLams dicts $ Let core_bind (Var local)
+			    mkLams tyvars $ mkLams dicts $ 
+	                    wrapDsEvBinds ds_ev_binds $
+                            Let core_bind $
+                            Var local
     
 	; (spec_binds, rules) <- dsSpecs global rhs prags
 
@@ -201,22 +216,27 @@ dsHsBind auto_scc rest
 		main_bind = makeCorePair global' (isDefaultMethod prags)
                                          (dictArity dicts) rhs 
     
-	; return (main_bind : spec_binds ++ rest) }
+	; return (main_bind `consOL` spec_binds) }
 
-dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
-  = do	{ core_prs <- ds_lhs_binds NoSccs binds
+dsHsBind auto_scc (AbsBinds { abs_tvs = all_tyvars, abs_ev_vars = dicts
+                            , abs_exports = exports, abs_ev_binds = ev_binds
+                       	    , abs_binds = binds })
+  = do	{ bind_prs    <- ds_lhs_binds NoSccs binds
+        ; ds_ev_binds <- dsTcEvBinds ev_binds
 	; let env = mkABEnv exports
 	      do_one (lcl_id,rhs) | Just (_, gbl_id, _, _prags) <- lookupVarEnv env lcl_id
 			          = (lcl_id, addAutoScc auto_scc gbl_id rhs)
 				  | otherwise = (lcl_id,rhs)
 	       
-		-- Rec because of mixed-up dictionary bindings
-	      core_bind = Rec (map do_one core_prs)
+	      core_bind = Rec (map do_one (fromOL bind_prs))
+	      	-- Monomorphic recursion possible, hence Rec
 
 	      tup_expr     = mkBigCoreVarTup locals
 	      tup_ty	   = exprType tup_expr
 	      poly_tup_rhs = mkLams all_tyvars $ mkLams dicts $
-	 	     	     Let core_bind tup_expr
+	      		     wrapDsEvBinds ds_ev_binds $
+			     Let core_bind $
+	 	     	     tup_expr
 	      locals       = [local | (_, _, local, _) <- exports]
 	      local_tys    = map idType locals
 
@@ -237,7 +257,7 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 					              (Let (NonRec poly_tup_id poly_tup_rhs) rhs)
 				                      spec_prags
 		     ; let global' = addIdSpecialisations global rules
-		     ; return ((global', rhs) : spec_binds) }
+		     ; return ((global', rhs) `consOL` spec_binds) }
 	        where
 	          mk_ty_arg all_tyvar
 			| all_tyvar `elem` tyvars = mkTyVarTy all_tyvar
@@ -246,9 +266,89 @@ dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports binds)
 	; export_binds_s <- mapM mk_bind (exports `zip` [0..])
 	     -- Don't scc (auto-)annotate the tuple itself.
 
-	; return ((poly_tup_id, poly_tup_rhs) : 
-		    (concat export_binds_s ++ rest)) }
+	; return ((poly_tup_id, poly_tup_rhs) `consOL` 
+		    concatOL export_binds_s) }
+
+--------------------------------------
+data DsEvBind 
+  = LetEvBind		-- Dictionary or coercion
+      CoreBind		-- recursive or non-recursive
 
+  | CaseEvBind		-- Coercion binding by superclass selection
+    			-- Desugars to case d of d { K _ g _ _ _ -> ... } 			
+      DictId 		   -- b   The dictionary
+      AltCon 		   -- K   Its constructor
+      [CoreBndr] 	   -- _ g _ _ _   The binders in the alternative
+
+wrapDsEvBinds :: [DsEvBind] -> CoreExpr -> CoreExpr
+wrapDsEvBinds ds_ev_binds body = foldr wrap_one body ds_ev_binds
+  where
+    body_ty = exprType body
+    wrap_one (LetEvBind b)       body = Let b body
+    wrap_one (CaseEvBind x k xs) body = Case (Var x) x body_ty [(k,xs,body)]
+
+dsTcEvBinds :: TcEvBinds -> DsM [DsEvBind]
+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"	-- Zonker has got rid of this
+dsTcEvBinds (EvBinds bs)   = dsEvBinds bs
+
+dsEvBinds :: Bag EvBind -> DsM [DsEvBind]
+dsEvBinds bs = return (map dsEvGroup sccs)
+  where
+    sccs :: [SCC EvBind]
+    sccs = stronglyConnCompFromEdgedVertices edges
+
+    edges :: [(EvBind, EvVar, [EvVar])]
+    edges = foldrBag ((:) . mk_node) [] bs 
+
+    mk_node :: EvBind -> (EvBind, EvVar, [EvVar])
+    mk_node b@(EvBind var term) = (b, var, free_vars_of term)
+
+    free_vars_of :: EvTerm -> [EvVar]
+    free_vars_of (EvId v)           = [v]
+    free_vars_of (EvCast v co)      = v : varSetElems (tyVarsOfType co)
+    free_vars_of (EvCoercion co)    = varSetElems (tyVarsOfType co)
+    free_vars_of (EvDFunApp _ _ vs) = vs
+    free_vars_of (EvSuperClass d _) = [d]
+
+dsEvGroup :: SCC EvBind -> DsEvBind
+dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
+  | isCoVar co_var	 -- An equality superclass
+  = ASSERT( null other_data_cons )
+    CaseEvBind dict (DataAlt data_con) bndrs
+  where
+    (cls, tys) = getClassPredTys (evVarPred dict)
+    (data_con:other_data_cons) = tyConDataCons (classTyCon cls)
+    (ex_tvs, theta, rho) = tcSplitSigmaTy (applyTys (dataConRepType data_con) tys)
+    (arg_tys, _) = splitFunTys rho
+    bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
+                   ++ map mkWildValBinder arg_tys
+    mk_wild_pred (p, i) | i==n      = ASSERT( p `tcEqPred` (coVarPred co_var)) 
+                                      co_var
+                        | otherwise = mkWildEvBinder p
+    
+dsEvGroup (AcyclicSCC (EvBind v r))
+  = LetEvBind (NonRec v (dsEvTerm r))
+
+dsEvGroup (CyclicSCC bs)
+  = LetEvBind (Rec (map ds_pair bs))
+  where
+    ds_pair (EvBind v r) = (v, dsEvTerm r)
+
+dsEvTerm :: EvTerm -> CoreExpr
+dsEvTerm (EvId v)      		 = Var v
+dsEvTerm (EvCast v co) 		 = Cast (Var v) co 
+dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
+dsEvTerm (EvCoercion co)         = Type co
+dsEvTerm (EvSuperClass d n)
+  = ASSERT( isClassPred (classSCTheta cls !! n) )
+    	    -- We can only select *dictionary* superclasses
+	    -- in terms.  Equality superclasses are dealt with
+	    -- in dsEvGroup, where they can generate a case expression
+    Var sc_sel_id `mkTyApps` tys `App` Var d
+  where
+    sc_sel_id  = classSCSelId cls n	-- Zero-indexed
+    (cls, tys) = getClassPredTys (evVarPred d)    
+    
 ------------------------
 makeCorePair :: Id -> Bool -> Arity -> CoreExpr -> (Id, CoreExpr)
 makeCorePair gbl_id is_default_method dict_arity rhs
@@ -445,34 +545,36 @@ Note that
 dsSpecs :: Id		-- The polymorphic Id
         -> CoreExpr     -- Its rhs
         -> TcSpecPrags
-        -> DsM ( [(Id,CoreExpr)] 	-- Binding for specialised Ids
+        -> DsM ( OrdList (Id,CoreExpr) 	-- Binding for specialised Ids
 	       , [CoreRule] )		-- Rules for the Global Ids
 -- See Note [Implementing SPECIALISE pragmas]
 dsSpecs poly_id poly_rhs prags
   = case prags of
-      IsDefaultMethod      -> return ([], [])
+      IsDefaultMethod      -> return (nilOL, [])
       SpecPrags sps -> do { pairs <- mapMaybeM spec_one sps
                           ; let (spec_binds_s, rules) = unzip pairs
-                          ; return (concat spec_binds_s, rules) }
+                          ; return (concatOL spec_binds_s, rules) }
  where 
-    spec_one :: Located TcSpecPrag -> DsM (Maybe ([(Id,CoreExpr)], CoreRule))
+    spec_one :: Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
     spec_one (L loc (SpecPrag spec_co spec_inl))
       = putSrcSpanDs loc $ 
         do { let poly_name = idName poly_id
 	   ; spec_name <- newLocalName poly_name
-	   ; wrap_fn   <- dsCoercion spec_co
-           ; let ds_spec_expr = wrap_fn (Var poly_id)
-                 spec_ty = exprType ds_spec_expr
-	   ; case decomposeRuleLhs ds_spec_expr of {
+	   ; wrap_fn   <- dsHsWrapper spec_co
+           ; let (bndrs, ds_lhs) = collectBinders (wrap_fn (Var poly_id))
+                 spec_ty = mkPiTypes bndrs (exprType ds_lhs)
+	   ; case decomposeRuleLhs ds_lhs of {
 	       Nothing -> do { warnDs (decomp_msg spec_co)
                              ; return Nothing } ;
 
-	       Just (bndrs, _fn, args) ->
+	       Just (_fn, args) ->
 
 	   -- Check for dead binders: Note [Unused spec binders]
-	     case filter isDeadBinder bndrs of {
-	   	bs | not (null bs) -> do { warnDs (dead_msg bs); return Nothing } 
-	   	   | otherwise -> do
+             let arg_fvs = exprsFreeVars args
+                 bad_bndrs = filterOut (`elemVarSet` arg_fvs) bndrs
+	     in if not (null bad_bndrs)
+                then do { warnDs (dead_msg bad_bndrs); return Nothing } 
+	   	else do
 
 	   { (spec_unf, unf_pairs) <- specUnfolding wrap_fn spec_ty (realIdUnfolding poly_id)
 
@@ -486,7 +588,7 @@ dsSpecs poly_id poly_rhs prags
 
               	 extra_dict_bndrs = [ mkLocalId (localiseName (idName d)) (idType d)
                                             -- See Note [Constant rule dicts]
-	      	 	  	    | d <- varSetElems (exprFreeVars ds_spec_expr)
+	      	 	  	    | d <- varSetElems (arg_fvs `delVarSetList` bndrs)
 	      	 	  	    , isDictId d]
 
               	 rule =  mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr poly_name)))
@@ -497,8 +599,8 @@ dsSpecs poly_id poly_rhs prags
                  spec_rhs  = wrap_fn poly_rhs
                  spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
 
-	    ; return (Just (spec_pair : unf_pairs, rule))
-	    } } } }
+	    ; return (Just (spec_pair `consOL` unf_pairs, rule))
+	    } } }
 
     dead_msg bs = vcat [ sep [ptext (sLit "Useless constraint") <> plural bs
 				 <+> ptext (sLit "in specialied type:"),
@@ -512,14 +614,15 @@ dsSpecs poly_id poly_rhs prags
     	     
 
 specUnfolding :: (CoreExpr -> CoreExpr) -> Type 
-              -> Unfolding -> DsM (Unfolding, [(Id,CoreExpr)])
+              -> Unfolding -> DsM (Unfolding, OrdList (Id,CoreExpr))
 specUnfolding wrap_fn spec_ty (DFunUnfolding _ _ ops)
   = do { let spec_rhss = map wrap_fn ops
        ; spec_ids <- mapM (mkSysLocalM (fsLit "spec") . exprType) spec_rhss
-       ; return (mkDFunUnfolding spec_ty (map Var spec_ids), spec_ids `zip` spec_rhss) }
+       ; return (mkDFunUnfolding spec_ty (map Var spec_ids), toOL (spec_ids `zip` spec_rhss)) }
 specUnfolding _ _ _
-  = return (noUnfolding, [])
+  = return (noUnfolding, nilOL)
 
+{-
 mkArbitraryTypeEnv :: [TyVar] -> [([TyVar], a, b, c)] -> TyVarEnv Type
 -- If any of the tyvars is missing from any of the lists in 
 -- the second arg, return a binding in the result
@@ -535,6 +638,7 @@ mkArbitraryTypeEnv tyvars exports
 				      , not (tv `elemVarEnv` env)]
 
     extend env tv = extendVarEnv env tv (dsMkArbitraryType tv)
+-}
 
 dsMkArbitraryType :: TcTyVar -> Type
 dsMkArbitraryType tv = anyTypeOfKind (tyVarKind tv)
@@ -587,37 +691,51 @@ as the old one, but with an Internal name and no IdInfo.
 %************************************************************************
 
 \begin{code}
-decomposeRuleLhs :: CoreExpr -> Maybe ([Var], Id, [CoreExpr])
+decomposeRuleLhs :: CoreExpr -> Maybe (Id, [CoreExpr])
 -- Take apart the LHS of a RULE.  It's suuposed to look like
 --     /\a. f a Int dOrdInt
 -- or  /\a.\d:Ord a. let { dl::Ord [a] = dOrdList a d } in f [a] dl
 -- That is, the RULE binders are lambda-bound
 -- Returns Nothing if the LHS isn't of the expected shape
 decomposeRuleLhs lhs 
-  = case collectArgs body of
-        (Var fn, args) -> Just (bndrs, fn, args)
+  =  -- Note [Simplifying the left-hand side of a RULE]
+    case collectArgs (simpleOptExpr lhs) of
+        (Var fn, args) -> Just (fn, args)
 
         (Case scrut bndr ty [(DEFAULT, _, body)], args)
 	        | isDeadBinder bndr	-- Note [Matching seqId]
-		-> Just (bndrs, seqId, args' ++ args)
+		-> Just (seqId, args' ++ args)
 		where
 		   args' = [Type (idType bndr), Type ty, scrut, body]
 	   
 	_other -> Nothing	-- Unexpected shape
-  where
-    (bndrs, body) = collectBinders (simpleOptExpr lhs)
-	-- simpleOptExpr occurrence-analyses and simplifies the lhs
-	-- and thereby
-	-- (a) identifies unused binders: Note [Unused spec binders]
-	-- (b) sorts dict bindings into NonRecs 
-	--	so they can be inlined by 'decomp'
-	-- (c) substitute trivial lets so that they don't get in the way
-	--     Note that we substitute the function too; we might 
-	--     have this as a LHS:  let f71 = M.f Int in f71
-        -- NB: tcSimplifyRuleLhs is very careful not to generate complicated
-	--     dictionary expressions that we might have to match
 \end{code}
 
+Note [Simplifying the left-hand side of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+simpleOptExpr occurrence-analyses and simplifies the lhs
+and thereby
+(a) sorts dict bindings into NonRecs and inlines them
+(b) substitute trivial lets so that they don't get in the way
+    Note that we substitute the function too; we might 
+    have this as a LHS:  let f71 = M.f Int in f71
+(c) does eta reduction
+
+For (c) consider the fold/build rule, which without simplification
+looked like:
+	fold k z (build (/\a. g a))  ==>  ...
+This doesn't match unless you do eta reduction on the build argument.
+Similarly for a LHS like
+	augment g (build h) 
+we do not want to get
+	augment (\a. g a) (build h)
+otherwise we don't match when given an argument like
+	augment (\a. h a a) (build h)
+
+NB: tcSimplifyRuleLhs is very careful not to generate complicated
+    dictionary expressions that we might have to match
+
+
 Note [Matching seqId]
 ~~~~~~~~~~~~~~~~~~~
 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
@@ -679,19 +797,16 @@ addDictScc _ rhs = return rhs
 
 
 \begin{code}
-dsCoercion :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
-dsCoercion WpHole 	     = return (\e -> e)
-dsCoercion (WpCompose c1 c2) = do { k1 <- dsCoercion c1 
-                                  ; k2 <- dsCoercion c2
-                                  ; return (k1 . k2) }
-dsCoercion (WpCast co)       = return (\e -> Cast e co) 
-dsCoercion (WpLam id)        = return (\e -> Lam id e) 
-dsCoercion (WpTyLam tv)      = return (\e -> Lam tv e) 
-dsCoercion (WpApp v)         | isTyVar v   -- Probably a coercion var
-                             = return (\e -> App e (Type (mkTyVarTy v)))
-	                     | otherwise
-                             = return (\e -> App e (Var v))
-dsCoercion (WpTyApp ty)      = return (\e -> App e (Type ty))
-dsCoercion (WpLet bs)        = do { prs <- dsLHsBinds bs
-			          ; return (\e -> Let (Rec prs) e) }
+dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
+dsHsWrapper WpHole 	      = return (\e -> e)
+dsHsWrapper (WpTyApp ty)      = return (\e -> App e (Type ty))
+dsHsWrapper (WpLet ev_binds)  = do { ds_ev_binds <- dsTcEvBinds ev_binds
+                                   ; return (wrapDsEvBinds ds_ev_binds) }
+dsHsWrapper (WpCompose c1 c2) = do { k1 <- dsHsWrapper c1 
+                                   ; k2 <- dsHsWrapper c2
+                                   ; return (k1 . k2) }
+dsHsWrapper (WpCast co)       = return (\e -> Cast e co) 
+dsHsWrapper (WpEvLam ev)      = return (\e -> Lam ev e) 
+dsHsWrapper (WpTyLam tv)      = return (\e -> Lam tv e) 
+dsHsWrapper (WpEvApp evtrm)   = return (\e -> App e (dsEvTerm evtrm))
 \end{code}
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index ef69b47..9df432b 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -86,9 +86,9 @@ dsValBinds (ValBindsOut binds _) body = foldrM ds_val_bind body binds
 
 -------------------------
 dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
-dsIPBinds (IPBinds ip_binds dict_binds) body
-  = do	{ prs <- dsLHsBinds dict_binds
-	; let inner = Let (Rec prs) body
+dsIPBinds (IPBinds ip_binds ev_binds) body
+  = do	{ ds_ev_binds <- dsTcEvBinds ev_binds
+	; let inner = wrapDsEvBinds ds_ev_binds body
 		-- The dict bindings may not be in 
 		-- dependency order; hence Rec
 	; foldrM ds_ip_bind inner ip_binds }
@@ -104,50 +104,18 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
 -- a tuple and doing selections.
 -- Silently ignore INLINE and SPECIALISE pragmas...
 ds_val_bind (NonRecursive, hsbinds) body
-  | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
-    (L loc bind : null_binds) <- bagToList binds,
-    isBangHsBind bind
-    || isUnboxedTupleBind bind
-    || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
-  = let
-      body_w_exports		      = foldr bind_export body exports
-      bind_export (tvs, g, l, _) body = ASSERT( null tvs )
-				        bindNonRec g (Var l) body
-    in
-    ASSERT (null null_binds)
+  | [L loc bind] <- bagToList hsbinds,
 	-- Non-recursive, non-overloaded bindings only come in ones
 	-- ToDo: in some bizarre case it's conceivable that there
 	--       could be dict binds in the 'binds'.  (See the notes
 	--	 below.  Then pattern-match would fail.  Urk.)
-    putSrcSpanDs loc	$
-    case bind of
-      FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn, 
-		fun_tick = tick, fun_infix = inf }
-        -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
-              MASSERT( null args ) -- Functions aren't lifted
-              MASSERT( isIdHsWrapper co_fn )
-              rhs' <- mkOptTickBox tick rhs
-              return (bindNonRec fun rhs' body_w_exports)
-
-      PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
-	-> 	-- let C x# y# = rhs in body
-		-- ==> case rhs of C x# y# -> body
-	   putSrcSpanDs loc			$
-           do { rhs <- dsGuarded grhss ty
-              ; let upat = unLoc pat
-                    eqn = EqnInfo { eqn_pats = [upat], 
-                                    eqn_rhs = cantFailMatchResult body_w_exports }
-              ; var    <- selectMatchVar upat
-              ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
-              ; return (scrungleMatch var rhs result) }
-
-      _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
-
+    strictMatchOnly bind
+  = putSrcSpanDs loc (dsStrictBind bind body)
 
 -- Ordinary case for bindings; none should be unlifted
 ds_val_bind (_is_rec, binds) body
   = do	{ prs <- dsLHsBinds binds
-	; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
+	; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
 	  case prs of
             [] -> return body
             _  -> return (Let (Rec prs) body) }
@@ -162,9 +130,53 @@ ds_val_bind (_is_rec, binds) body
 	-- NB The previous case dealt with unlifted bindings, so we
 	--    only have to deal with lifted ones now; so Rec is ok
 
-isUnboxedTupleBind :: HsBind Id -> Bool
-isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
-isUnboxedTupleBind _                             = False
+------------------
+dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
+dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
+               , abs_exports = exports
+               , abs_ev_binds = ev_binds
+               , abs_binds = binds }) body
+  = do { ds_ev_binds <- dsTcEvBinds ev_binds
+       ; let body1 = foldr bind_export body exports
+             bind_export (_, g, l, _) b = bindNonRec g (Var l) b
+       ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body) 
+                            body1 binds 
+       ; return (wrapDsEvBinds ds_ev_binds body2) }
+
+dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn 
+	              , fun_tick = tick, fun_infix = inf }) body
+		-- Can't be a bang pattern (that looks like a PatBind)
+		-- so must be simply unboxed
+  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
+       ; MASSERT( null args ) -- Functions aren't lifted
+       ; MASSERT( isIdHsWrapper co_fn )
+       ; rhs' <- mkOptTickBox tick rhs
+       ; return (bindNonRec fun rhs' body) }
+
+dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
+  = 	-- let C x# y# = rhs in body
+	-- ==> case rhs of C x# y# -> body
+    do { rhs <- dsGuarded grhss ty
+       ; let upat = unLoc pat
+             eqn = EqnInfo { eqn_pats = [upat], 
+                             eqn_rhs = cantFailMatchResult body }
+       ; var    <- selectMatchVar upat
+       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
+       ; return (scrungleMatch var rhs result) }
+
+dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
+
+----------------------
+strictMatchOnly :: HsBind Id -> Bool
+strictMatchOnly (AbsBinds { abs_binds = binds })
+  = anyBag (strictMatchOnly . unLoc) binds
+strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
+  =  isUnboxedTupleType ty 
+  || isBangLPat lpat   
+  || any (isUnLiftedType . idType) (collectPatBinders lpat)
+strictMatchOnly (FunBind { fun_id = L _ id })
+  = isUnLiftedType (idType id)
+strictMatchOnly _ = False -- I hope!  Checked immediately by caller in fact
 
 scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
 -- Returns something like (let var = scrut in body)
@@ -211,7 +223,7 @@ dsExpr (HsVar var)     	      = return (Var var)
 dsExpr (HsIPVar ip)    	      = return (Var (ipNameName ip))
 dsExpr (HsLit lit)     	      = dsLit lit
 dsExpr (HsOverLit lit) 	      = dsOverLit lit
-dsExpr (HsWrap co_fn e)       = do { co_fn' <- dsCoercion co_fn
+dsExpr (HsWrap co_fn e)       = do { co_fn' <- dsHsWrapper co_fn
                                    ; e' <- dsExpr e
                                    ; return (co_fn' e') }
 
@@ -289,9 +301,6 @@ dsExpr (HsSCC cc expr) = do
     mod_name <- getModuleDs
     Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
 
-
--- hdaume: core annotation
-
 dsExpr (HsCoreAnn fs expr)
   = Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
 
@@ -326,8 +335,10 @@ dsExpr (HsDo DoExpr stmts body result_ty)
 dsExpr (HsDo GhciStmt stmts body result_ty)
   = dsDo stmts body result_ty
 
-dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
-  = dsMDo tbl stmts body result_ty
+dsExpr (HsDo ctxt@(MDoExpr tbl) stmts body result_ty)
+  = do { (meth_binds, tbl') <- dsSyntaxTable tbl
+       ; core_expr <- dsMDo ctxt tbl' stmts body result_ty
+       ; return (mkLets meth_binds core_expr) }
 
 dsExpr (HsDo PArrComp stmts body result_ty)
   =	-- Special case for array comprehensions
@@ -523,8 +534,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
                      = nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
 		 inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
 			-- Reconstruct with the WrapId so that unpacking happens
-		 wrap = mkWpApps theta_vars `WpCompose` 
-			mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
+		 wrap = mkWpEvVarApps theta_vars          `WpCompose` 
+			mkWpTyApps    (mkTyVarTys ex_tvs) `WpCompose`
 			mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
 				       , isNothing (lookupTyVar wrap_subst tv) ]
     	         rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
@@ -543,7 +554,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 		 
     	         pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
 					 , pat_dicts = eqs_vars ++ theta_vars
-					 , pat_binds = emptyLHsBinds 
+					 , pat_binds = emptyTcEvBinds
 					 , pat_args = PrefixCon $ map nlVarPat arg_ids
 					 , pat_ty = in_ty }
 	   ; return (mkSimpleMatch [pat] wrapped_rhs) }
@@ -733,9 +744,10 @@ dsDo stmts body result_ty
     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op
                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
-                    , recS_rec_rets = rec_rets, recS_dicts = binds }) stmts 
+                    , recS_rec_rets = rec_rets, recS_dicts = _ev_binds }) stmts 
       = ASSERT( length rec_ids > 0 )
-        goL (new_bind_stmt : let_stmt : stmts)
+        ASSERT( isEmptyTcEvBinds _ev_binds )   -- No method binds
+        goL (new_bind_stmt : stmts)
       where
         -- returnE <- dsExpr return_id
         -- mfixE <- dsExpr mfix_id
@@ -743,8 +755,6 @@ dsDo stmts body result_ty
                                          bind_op 
 		                             noSyntaxExpr  -- Tuple cannot fail
 
-        let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
-
         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
         rec_tup_pats = map nlVarPat tup_ids
         later_pats   = rec_tup_pats
@@ -782,13 +792,14 @@ We turn (RecStmt [v1,..vn] stmts) into:
 				      return (v1,..vn))
 
 \begin{code}
-dsMDo	:: PostTcTable
+dsMDo	:: HsStmtContext Name
+        -> [(Name,Id)]
 	-> [LStmt Id]
 	-> LHsExpr Id
 	-> Type			-- Type of the whole expression
 	-> DsM CoreExpr
 
-dsMDo tbl stmts body result_ty
+dsMDo ctxt tbl stmts body result_ty
   = goL stmts
   where
     goL [] = dsLExpr body
@@ -800,7 +811,6 @@ dsMDo tbl stmts body result_ty
     bind_id   = lookupEvidence tbl bindMName
     then_id   = lookupEvidence tbl thenMName
     fail_id   = lookupEvidence tbl failMName
-    ctxt      = MDoExpr tbl
 
     go _ (LetStmt binds) stmts
       = do { rest <- goL stmts
@@ -825,15 +835,16 @@ dsMDo tbl stmts body result_ty
 	   ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, 
 					     rhs', Lam var match_code]) }
     
-    go loc (RecStmt rec_stmts later_ids rec_ids _ _ _ rec_rets binds) stmts
+    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
+                    , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets 
+                    , recS_dicts = _ev_binds }) stmts
       = ASSERT( length rec_ids > 0 )
         ASSERT( length rec_ids == length rec_rets )
+        ASSERT( isEmptyTcEvBinds _ev_binds )
         pprTrace "dsMDo" (ppr later_ids) $
-	 goL (new_bind_stmt : let_stmt : stmts)
+	 goL (new_bind_stmt : stmts)
       where
         new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
-	let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
-
 	
 		-- Remove the later_ids that appear (without fancy coercions) 
 		-- in rec_rets, because there's no need to knot-tie them separately
diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 25366fa..4c05f5e 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -221,7 +221,7 @@ wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
 wrapBind new old body	-- Can deal with term variables *or* type variables
   | new==old    = body
-  | isTyVar new = Let (mkTyBind new (mkTyVarTy old)) body
+  | isTyCoVar new = Let (mkTyBind new (mkTyVarTy old)) body
   | otherwise   = Let (NonRec new (Var old))         body
 
 seqVar :: Var -> CoreExpr -> CoreExpr
@@ -475,7 +475,7 @@ mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
   where
     case_bndr = case arg1 of
                    Var v1 | isLocalId v1 -> v1        -- Note [Desugaring seq (2) and (3)]
-                   _                     -> mkWildBinder ty1
+                   _                     -> mkWildValBinder ty1
 
 mkCoreAppDs fun arg = mkCoreApp fun arg	 -- The rest is done in MkCore
 
@@ -550,8 +550,7 @@ mkSelectorBinds pat val_expr
       error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID   tuple_ty (ppr pat)
       tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
       tuple_var <- newSysLocalDs tuple_ty
-      let
-          mk_tup_bind binder
+      let mk_tup_bind binder
             = (binder, mkTupleSelector binders binder tuple_var (Var tuple_var))
       return ( (tuple_var, tuple_expr) : map mk_tup_bind binders )
   where
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index d676911..e148cf7 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -346,7 +346,7 @@ matchCoercion (var:vars) ty (eqns@(eqn1:_))
   = do	{ let CoPat co pat _ = firstPat eqn1
 	; var' <- newUniqueId var (hsPatType pat)
 	; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns)
-	; co' <- dsCoercion co
+	; co' <- dsHsWrapper co
         ; let rhs' = co' (Var var)
 	; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
 
@@ -464,8 +464,8 @@ tidy1 v (VarPat var)
   = return (wrapBind var v, WildPat (idType var)) 
 
 tidy1 v (VarPatOut var binds)
-  = do	{ prs <- dsLHsBinds binds
-	; return (wrapBind var v . mkCoreLet (Rec prs),
+  = do	{ ds_ev_binds <- dsTcEvBinds binds
+	; return (wrapBind var v . wrapDsEvBinds ds_ev_binds,
 		  WildPat (idType var)) }
 
 	-- case v of { x@p -> mr[] }
@@ -875,7 +875,7 @@ viewLExprEq (e1,_) (e2,_) =
         wrap WpHole WpHole = True
         wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
         wrap (WpCast c)  (WpCast c')  = tcEqType c c'
-        wrap (WpApp d)   (WpApp d')   = d == d'
+        wrap (WpEvApp _) (WpEvApp _) = panic "ToDo: Match.viewLExprEq"
         wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
         -- Enhancement: could implement equality for more wrappers
         --   if it seems useful (lams and lets)
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index 9ec7f35..03fa325 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -23,8 +23,6 @@ import HsSyn
 import DsBinds
 import DataCon
 import TcType
-import CoreSyn
-import MkCore
 import DsMonad
 import DsUtils
 import Util	( all2, takeList, zipEqual )
@@ -140,10 +138,10 @@ matchOneCon vars ty (eqn1 : eqns)	-- All eqns for a single constructor
     shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds, 
 					           pat_binds = bind, pat_args = args
 					} : pats }))
-      = do { prs <- dsLHsBinds bind
+      = do { ds_ev_binds <- dsTcEvBinds bind
 	   ; return (wrapBinds (tvs `zip` tvs1) 
 		    . wrapBinds (ds  `zip` dicts1)
-		    . mkCoreLet (Rec prs),
+		    . wrapDsEvBinds ds_ev_binds,
 		    eqn { eqn_pats = conArgPats arg_tys args ++ pats }) }
 
     -- Choose the right arg_vars in the right order for this group
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 01e7b07..d2a199b 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -408,11 +408,14 @@ Library
         TcRnTypes
         TcRules
         TcSimplify
+        TcErrors
         TcTyClsDecls
         TcTyDecls
-        TcTyFuns
         TcType
         TcUnify
+        TcInteract
+        TcCanonical
+        TcSMonad
         Class
         Coercion
         FamInstEnv
diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 5d1bd27..90931cc 100644
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -250,7 +250,7 @@ schemeR fvs (nm, rhs)
 {-
    | trace (showSDoc (
               (char ' '
-               $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
+               $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs
                $$ pprCoreExpr (deAnnotate rhs)
                $$ char ' '
               ))) False
@@ -834,7 +834,7 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
 	     rhs_code <- schemeE (d_alts+size) s p' rhs
              return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
 	   where
-	     real_bndrs = filter (not.isTyVar) bndrs
+	     real_bndrs = filter (not.isTyCoVar) bndrs
 
         my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
         my_discr (DataAlt dc, _, _) 
@@ -1146,6 +1146,8 @@ maybe_getCCallReturnRep fn_ty
                                   -- if it was, it would be impossible 
                                   -- to create a valid return value 
                                   -- placeholder on the stack
+
+         blargh :: a -- Used at more than one type
          blargh = pprPanic "maybe_getCCallReturn: can't handle:" 
                            (pprType fn_ty)
      in 
@@ -1455,7 +1457,7 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
 -- whereas value lambdas cannot; that is why they are nuked here
 bcView (AnnNote _ (_,e)) 	     = Just e
 bcView (AnnCast (_,e) _) 	     = Just e
-bcView (AnnLam v (_,e)) | isTyVar v  = Just e
+bcView (AnnLam v (_,e)) | isTyCoVar v  = Just e
 bcView (AnnApp (_,e) (_, AnnType _)) = Just e
 bcView _                             = Nothing
 
diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index 45cbdc0..d53d247 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -633,6 +633,7 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
             text "module" <+> ppr mod <+> 
             text "cannot be linked; it is only available as a boot module")))
 
+    no_obj :: Outputable a => a -> IO b
     no_obj mod = dieWith span $
 		     ptext (sLit "cannot find object file for module ") <> 
 			quotes (ppr mod) $$
@@ -657,7 +658,7 @@ getLinkDeps hsc_env hpt pls maybe_normal_osuf span mods
 		-- ...and then find the linkable for it
 	       mb_lnk <- findObjectLinkableMaybe mod loc ;
 	       case mb_lnk of {
-		  Nothing -> no_obj mod ;
+		  Nothing  -> no_obj mod ;
 		  Just lnk -> adjust_linkable lnk
 	      }}
 
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index a23d355..fa167e3 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -569,13 +569,13 @@ liftTcM :: TcM a -> TR a
 liftTcM = id
 
 newVar :: Kind -> TR TcType
-newVar = liftTcM . liftM mkTyVarTy . newBoxyTyVar
+newVar = liftTcM . newFlexiTyVarTy
 
 -- | Returns the instantiated type scheme ty', and the substitution sigma 
 --   such that sigma(ty') = ty 
 instScheme :: Type -> TR (TcType, TvSubst)
 instScheme ty = liftTcM$ do
-   (tvs, _, _)      <- tcInstType return ty
+   (tvs, _, _)  <- tcInstType return ty
    (tvs',_,ty') <- tcInstType (mapM tcInstTyVar) ty
    return (ty', zipTopTvSubst tvs' (mkTyVarTys tvs))
 
@@ -590,7 +590,7 @@ addConstraint actual expected = do
     recoverTR (traceTR $ fsep [text "Failed to unify", ppr actual,
                                     text "with", ppr expected])
               (congruenceNewtypes actual expected >>=
-                           (getLIE . uncurry boxyUnify) >> return ())
+                           (getConstraints . uncurry unifyType) >> return ())
      -- TOMDO: what about the coercion?
      -- we should consider family instances
 
@@ -861,7 +861,7 @@ improveRTTIType hsc_env _ty rtti_ty = runTR_maybe hsc_env $ do
     (ty_tvs,  _, _)   <- tcInstType return ty
     (ty_tvs', _, ty') <- tcInstType (mapM tcInstTyVar) ty
     (_, _, rtti_ty')  <- tcInstType (mapM tcInstTyVar) (sigmaType rtti_ty)
-    _ <- getLIE(boxyUnify rtti_ty' ty')
+    _ <- getConstraints(unifyType rtti_ty' ty')
     tvs1_contents     <- zonkTcTyVars ty_tvs'
     let subst = (uncurry zipTopTvSubst . unzip)
                  [(tv,ty) | (tv,ty) <- zip ty_tvs tvs1_contents
@@ -1101,7 +1101,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
                         text " in presence of newtype evidence " <> ppr new_tycon)
                vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
                let ty' = mkTyConApp new_tycon vars
-               _ <- liftTcM (boxyUnify ty (repType ty'))
+               _ <- liftTcM (unifyType ty (repType ty'))
         -- assumes that reptype doesn't ^^^^ touch tyconApp args 
                return ty'
 
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 5709e58..f8afd26 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -32,10 +32,13 @@ import BasicTypes
 import Outputable	
 import SrcLoc
 import Util
+import VarEnv
 import Var
 import Bag
+import Unique
 import FastString
 
+import Data.IORef( IORef )
 import Data.Data hiding ( Fixity )
 \end{code}
 
@@ -77,10 +80,9 @@ data HsValBindsLR idL idR  -- Value bindings (not implicit parameters)
 	[LSig Name]
   deriving (Data, Typeable)
 
-type LHsBinds id  = Bag (LHsBind id)
-type DictBinds id = LHsBinds id		-- Used for dictionary or method bindings
-type LHsBind  id  = Located (HsBind id)
-type HsBind id = HsBindLR id id
+type LHsBinds id = Bag (LHsBind id)
+type LHsBind  id = Located (HsBind id)
+type HsBind id   = HsBindLR id id
 
 type LHsBindLR idL idR = Located (HsBindLR idL idR)
 type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
@@ -123,7 +125,7 @@ data HsBindLR idL idR
 				-- Before renaming, and after typechecking, 
 				-- the field is unused; it's just an error thunk
 
-        fun_tick :: Maybe (Int,[idR])   -- ^ This is the (optional) module-local tick number.
+        fun_tick :: Maybe (Int,[Id])   -- ^ This is the (optional) module-local tick number.
     }
 
   | PatBind {	-- The pattern is never a simple variable;
@@ -141,17 +143,17 @@ data HsBindLR idL idR
 				     --	(used for implication constraints only)
     }
 
-  | AbsBinds {					-- Binds abstraction; TRANSLATION
+  | AbsBinds {				-- Binds abstraction; TRANSLATION
         abs_tvs     :: [TyVar],  
-	abs_dicts   :: [DictId],		-- Includes equality constraints
+	abs_ev_vars :: [EvVar],	 -- Includes equality constraints
 
        -- AbsBinds only gets used when idL = idR after renaming,
        -- but these need to be idL's for the collect... code in HsUtil to have
        -- the right type
 	abs_exports :: [([TyVar], idL, idL, TcSpecPrags)],	-- (tvs, poly_id, mono_id, prags)
-	abs_binds   :: LHsBinds idL		-- The dictionary bindings and typechecked user bindings
-						-- mixed up together; you can tell the dict bindings because
-						-- they are all VarBinds
+
+        abs_ev_binds :: TcEvBinds,     -- Evidence bindings
+	abs_binds    :: LHsBinds idL   -- Typechecked user bindings
     }
   deriving (Data, Typeable)
 	-- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
@@ -285,7 +287,7 @@ ppr_monobind (FunBind { fun_id = fun, fun_infix = inf,
 			Just t  -> text "-- tick id = " <> ppr t)
     $$  pprFunBind (unLoc fun) inf matches
 
-ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars, 
+ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars, 
 			 abs_exports = exports, abs_binds = val_binds })
   = sep [ptext (sLit "AbsBinds"),
   	 brackets (interpp'SP tyvars),
@@ -321,12 +323,12 @@ pprTicks pp_no_debug pp_when_debug
 data HsIPBinds id
   = IPBinds 
 	[LIPBind id] 
-	(DictBinds id)	-- Only in typechecker output; binds 
+	TcEvBinds	-- Only in typechecker output; binds 
 			-- uses of the implicit parameters
   deriving (Data, Typeable)
 
 isEmptyIPBinds :: HsIPBinds id -> Bool
-isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds
+isEmptyIPBinds (IPBinds is ds) = null is && isEmptyTcEvBinds ds
 
 type LIPBind id = Located (IPBind id)
 
@@ -339,7 +341,7 @@ data IPBind id
 
 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) 
-			$$ pprLHsBinds ds
+			$$ ppr ds
 
 instance (OutputableBndr id) => Outputable (IPBind id) where
   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
@@ -359,65 +361,148 @@ instance (OutputableBndr id) => Outputable (IPBind id) where
 data HsWrapper
   = WpHole			-- The identity coercion
 
-  | WpCompose HsWrapper HsWrapper	-- (\a1..an. []) `WpCompose` (\x1..xn. [])
-				--	= (\a1..an \x1..xn. [])
+  | WpCompose HsWrapper HsWrapper	
+       -- (wrap1 `WpCompse` wrap2)[e] = wrap1[ wrap2[ e ]]
+       -- 
+       -- Hence  (\a. []) `WpCompose` (\b. []) = (\a b. [])
+       -- But    ([] a)   `WpCompose` ([] b)   = ([] b a)
 
   | WpCast Coercion		-- A cast:  [] `cast` co
 				-- Guaranteed not the identity coercion
 
-  | WpApp Var			-- [] d		the 'd' is a type-class dictionary or coercion variable
-
-  | WpTyApp Type		-- [] t		the 't' is a type or corecion
-    	    			--      ToDo: it'd be tidier if 't' was always a type (not coercion),
-				--	      but that is inconvenient in Inst.instCallDicts
+	-- Evidence abstraction and application
+        -- (both dictionaries and coercions)
+  | WpEvLam EvVar 		-- \d. []	the 'd' is an evidence variable
+  | WpEvApp EvTerm		-- [] d		the 'd' is evidence for a constraint
 
-  | WpLam Var	 		-- \d. []	the 'd' is a type-class dictionary or coercion variable
+	-- Type abstraction and application
   | WpTyLam TyVar 		-- \a. []	the 'a' is a type variable (not coercion var)
+  | WpTyApp Type		-- [] t		the 't' is a type (not coercion)
+
 
-	-- Non-empty bindings, so that the identity coercion
-	-- is always exactly WpHole
-  | WpLet (LHsBinds Id)		-- let binds in []
-				-- (would be nicer to be core bindings)
+  | WpLet TcEvBinds      	-- Non-empty (or possibly non-empty) evidence bindings,
+                                -- so that the identity coercion is always exactly WpHole
   deriving (Data, Typeable)
 
-instance Outputable HsWrapper where 
-  ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
 
-pprHsWrapper :: SDoc -> HsWrapper -> SDoc
-pprHsWrapper it wrap = 
-    let 
-        help it WpHole            = it
-        help it (WpCompose f1 f2) = help (help it f2) f1
-        help it (WpCast co)   = sep [it, nest 2 (ptext (sLit "`cast`") <+> pprParendType co)]
-        help it (WpApp id)    = sep [it, nest 2 (ppr id)]
-        help it (WpTyApp ty)  = sep [it, ptext (sLit "@") <+> pprParendType ty]
-        help it (WpLam id)    = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
-        help it (WpTyLam tv)  = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
-        help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
-    in
-      -- in debug mode, print the wrapper
-      -- otherwise just print what's inside
-      getPprStyle (\ s -> if debugStyle s then (help it wrap) else it)
+data TcEvBinds 
+  = TcEvBinds		-- Mutable evidence bindings
+       EvBindsVar	-- Mutable because they are updated "later"
+     	       	       	--    when an implication constraint is solved
+
+  | EvBinds 		-- Immutable after zonking
+       (Bag EvBind)
+
+  deriving( Typeable )
+
+data EvBindsVar = EvBindsVar (IORef EvBindMap) Unique
+     -- The Unique is only for debug printing
+
+-----------------
+type EvBindMap = VarEnv EvBind
+
+emptyEvBindMap :: EvBindMap
+emptyEvBindMap = emptyVarEnv
+
+extendEvBinds :: EvBindMap -> EvVar -> EvTerm -> EvBindMap
+extendEvBinds bs v t = extendVarEnv bs v (EvBind v t)
+
+lookupEvBind :: EvBindMap -> EvVar -> Maybe EvBind
+lookupEvBind = lookupVarEnv
+
+evBindMapBinds :: EvBindMap -> Bag EvBind
+evBindMapBinds = foldVarEnv consBag emptyBag
+
+-----------------
+instance Data TcEvBinds where
+  -- Placeholder; we can't travers into TcEvBinds
+  toConstr _   = abstractConstr "TcEvBinds"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNoRepType "TcEvBinds"
+
+-- All evidence is bound by EvBinds; no side effects
+data EvBind = EvBind EvVar EvTerm
+
+data EvTerm
+  = EvId EvId                  -- Term-level variable-to-variable bindings 
+                               -- (no coercion variables! they come via EvCoercion)
+
+  | EvCoercion Coercion        -- Coercion bindings
+
+  | EvCast EvVar Coercion      -- d |> co
+
+  | EvDFunApp DFunId           -- Dictionary instance application
+       [Type] [EvVar]  
 
+  | EvSuperClass DictId Int    -- n'th superclass. Used for both equalities and
+                               -- dictionaries, even though the former have no
+			       -- selector Id.  We count up from _0_ 
+			       
+  deriving( Data, Typeable)
+
+evVarTerm :: EvVar -> EvTerm
+evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v)
+            | otherwise = EvId v
+\end{code}
+
+Note [EvBinds/EvTerm]
+~~~~~~~~~~~~~~~~~~~~~
+How evidence is created and updated. Bindings for dictionaries, 
+and coercions and implicit parameters are carried around in TcEvBinds
+which during constraint generation and simplification is always of the
+form (TcEvBinds ref). After constraint simplification is finished it 
+will be transformed to t an (EvBinds ev_bag). 
+
+Evidence for coercions *SHOULD* be filled in using the TcEvBinds 
+However, all EvVars that correspond to *wanted* coercion terms in 
+an EvBind must be mutable variables so that they can be readily 
+inlined (by zonking) after constraint simplification is finished.
+
+Conclusion: a new wanted coercion variable should be made mutable. 
+[Notice though that evidence variables that bind coercion terms 
+ from super classes will be "given" and hence rigid] 
+
+
+\begin{code}
+emptyTcEvBinds :: TcEvBinds
+emptyTcEvBinds = EvBinds emptyBag
+
+isEmptyTcEvBinds :: TcEvBinds -> Bool
+isEmptyTcEvBinds (EvBinds b)    = isEmptyBag b
+isEmptyTcEvBinds (TcEvBinds {}) = panic "isEmptyTcEvBinds"
+ 
 (<.>) :: HsWrapper -> HsWrapper -> HsWrapper
 WpHole <.> c = c
 c <.> WpHole = c
 c1 <.> c2    = c1 `WpCompose` c2
 
 mkWpTyApps :: [Type] -> HsWrapper
-mkWpTyApps tys = mk_co_fn WpTyApp (reverse tys)
+mkWpTyApps tys = mk_co_app_fn WpTyApp tys
+
+mkWpEvApps :: [EvTerm] -> HsWrapper
+mkWpEvApps args = mk_co_app_fn WpEvApp args
 
-mkWpApps :: [Var] -> HsWrapper
-mkWpApps ids = mk_co_fn WpApp (reverse ids)
+mkWpEvVarApps :: [EvVar] -> HsWrapper
+mkWpEvVarApps vs = mkWpEvApps (map evVarTerm vs)
 
 mkWpTyLams :: [TyVar] -> HsWrapper
-mkWpTyLams ids = mk_co_fn WpTyLam ids
+mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
 
 mkWpLams :: [Var] -> HsWrapper
-mkWpLams ids = mk_co_fn WpLam ids
+mkWpLams ids = mk_co_lam_fn WpEvLam ids
 
-mk_co_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
-mk_co_fn f as = foldr (WpCompose . f) WpHole as
+mkWpLet :: TcEvBinds -> HsWrapper
+-- This no-op is a quite a common case
+mkWpLet (EvBinds b) | isEmptyBag b = WpHole
+mkWpLet ev_binds                   = WpLet ev_binds
+
+mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
+mk_co_lam_fn f as = foldr (\x wrap -> f x `WpCompose` wrap) WpHole as
+
+mk_co_app_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
+-- For applications, the *first* argument must
+-- come *last* in the composition sequence
+mk_co_app_fn f as = foldr (\x wrap -> wrap `WpCompose` f x) WpHole as
 
 idHsWrapper :: HsWrapper
 idHsWrapper = WpHole
@@ -427,6 +512,45 @@ isIdHsWrapper WpHole = True
 isIdHsWrapper _      = False
 \end{code}
 
+Pretty printing
+
+\begin{code}
+instance Outputable HsWrapper where 
+  ppr co_fn = pprHsWrapper (ptext (sLit "<>")) co_fn
+
+pprHsWrapper :: SDoc -> HsWrapper -> SDoc
+-- In debug mode, print the wrapper
+-- otherwise just print what's inside
+pprHsWrapper it wrap
+  = getPprStyle (\ s -> if debugStyle s then (help it wrap) else it)
+  where
+    help it WpHole            = it
+    help it (WpCompose f1 f2) = help (help it f2) f1
+    help it (WpCast co)   = sep [it, nest 2 (ptext (sLit "`cast`") <+> pprParendType co)]
+    help it (WpEvApp id)  = sep [it, nest 2 (ppr id)]
+    help it (WpTyApp ty)  = sep [it, ptext (sLit "@") <+> pprParendType ty]
+    help it (WpEvLam id)  = sep [ptext (sLit "\\") <> pprBndr LambdaBind id <> dot, it]
+    help it (WpTyLam tv)  = sep [ptext (sLit "/\\") <> pprBndr LambdaBind tv <> dot, it]
+    help it (WpLet binds) = sep [ptext (sLit "let") <+> braces (ppr binds), it]
+
+instance Outputable TcEvBinds where
+  ppr (TcEvBinds v) = ppr v
+  ppr (EvBinds bs)  = ptext (sLit "EvBinds") <> braces (ppr bs)
+
+instance Outputable EvBindsVar where
+  ppr (EvBindsVar _ u) = ptext (sLit "EvBindsVar") <> angleBrackets (ppr u)
+
+instance Outputable EvBind where
+  ppr (EvBind v e)   = ppr v <+> equals <+> ppr e
+
+instance Outputable EvTerm where
+  ppr (EvId v)        	 = ppr v
+  ppr (EvCast v co)   	 = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
+  ppr (EvCoercion co)    = ppr co
+  ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
+  ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys
+                                             , ppr ts ]
+\end{code}
 
 %************************************************************************
 %*									*
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index dff8ce7..d49afec 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -232,6 +232,7 @@ instance OutputableBndr name => Outputable (HsGroup name) where
              ppr_ds deriv_decls,
 	     ppr_ds foreign_decls]
 	where
+          ppr_ds :: Outputable a => [a] -> Maybe SDoc
 	  ppr_ds [] = Nothing
 	  ppr_ds ds = Just (vcat (map ppr ds))
 
@@ -636,6 +637,7 @@ instance OutputableBndr name
         top_matter    =     ptext (sLit "class") 
 		        <+> pp_decl_head (unLoc context) lclas tyvars Nothing
 		        <+> pprFundeps (map unLoc fds)
+        ppr_semi :: Outputable a => a -> SDoc
 	ppr_semi decl = ppr decl <> semi
 
 pp_decl_head :: OutputableBndr name
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 84901ee..245631d 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -48,7 +48,7 @@ type LHsExpr id = Located (HsExpr id)
 type PostTcExpr  = HsExpr Id
 -- | We use a PostTcTable where there are a bunch of pieces of evidence, more
 -- than is convenient to keep individually.
-type PostTcTable = [(Name, Id)]
+type PostTcTable = [(Name, PostTcExpr)]
 
 noPostTcExpr :: PostTcExpr
 noPostTcExpr = HsLit (HsString (fsLit "noPostTcExpr"))
@@ -62,7 +62,7 @@ noPostTcTable = []
 --
 -- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for
 --      @(>>=)@, and then instantiated by the type checker with its type args
---      tec
+--      etc
 
 type SyntaxExpr id = HsExpr id
 
@@ -895,8 +895,8 @@ data StmtLR idL idR
                                      -- the returned thing has to be *monomorphic*, 
 				     -- so they may be type applications
 
-      , recS_dicts :: DictBinds idR  -- Method bindings of Ids bound by the
-                                     -- RecStmt, and used afterwards
+      , recS_dicts :: TcEvBinds    -- Method bindings of Ids bound by the
+                                   -- RecStmt, and used afterwards
       }
   deriving (Data, Typeable)
 \end{code}
@@ -1147,8 +1147,8 @@ pp_dotdot = ptext (sLit " .. ")
 \begin{code}
 data HsMatchContext id  -- Context of a Match
   = FunRhs id Bool              -- Function binding for f; True <=> written infix
-  | CaseAlt                     -- Patterns and guards on a case alternative
   | LambdaExpr                  -- Patterns of a lambda
+  | CaseAlt                     -- Patterns and guards on a case alternative
   | ProcExpr                    -- Patterns of a proc
   | PatBindRhs                  -- Patterns in the *guards* of a pattern binding
   | RecUpd                      -- Record update [used only in DsExpr to
@@ -1198,16 +1198,25 @@ matchSeparator ThPatQuote   = panic "unused"
 
 \begin{code}
 pprMatchContext :: Outputable id => HsMatchContext id -> SDoc
-pprMatchContext (FunRhs fun _)    = ptext (sLit "the definition of")
-                                    <+> quotes (ppr fun)
-pprMatchContext CaseAlt           = ptext (sLit "a case alternative")
-pprMatchContext RecUpd            = ptext (sLit "a record-update construct")
-pprMatchContext ThPatQuote        = ptext (sLit "a Template Haskell pattern quotation")
-pprMatchContext PatBindRhs        = ptext (sLit "a pattern binding")
-pprMatchContext LambdaExpr        = ptext (sLit "a lambda abstraction")
-pprMatchContext ProcExpr          = ptext (sLit "an arrow abstraction")
-pprMatchContext (StmtCtxt ctxt)   = ptext (sLit "a pattern binding in")
-                                    $$ pprStmtContext ctxt
+pprMatchContext ctxt 
+  | want_an ctxt = ptext (sLit "an") <+> pprMatchContextNoun ctxt
+  | otherwise    = ptext (sLit "a")  <+> pprMatchContextNoun ctxt
+  where
+    want_an (FunRhs {}) = True	-- Use "an" in front
+    want_an ProcExpr    = True
+    want_an _           = False
+                 
+pprMatchContextNoun :: Outputable id => HsMatchContext id -> SDoc
+pprMatchContextNoun (FunRhs fun _)  = ptext (sLit "equation for")
+                                      <+> quotes (ppr fun)
+pprMatchContextNoun CaseAlt         = ptext (sLit "case alternative")
+pprMatchContextNoun RecUpd          = ptext (sLit "record-update construct")
+pprMatchContextNoun ThPatQuote      = ptext (sLit "Template Haskell pattern quotation")
+pprMatchContextNoun PatBindRhs      = ptext (sLit "pattern binding")
+pprMatchContextNoun LambdaExpr      = ptext (sLit "lambda abstraction")
+pprMatchContextNoun ProcExpr        = ptext (sLit "arrow abstraction")
+pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in")
+                                      $$ pprStmtContext ctxt
 
 pprStmtContext :: Outputable id => HsStmtContext id -> SDoc
 pprStmtContext (ParStmtCtxt c)
diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs
index c025a8d..1bf0aa8 100644
--- a/compiler/hsSyn/HsPat.lhs
+++ b/compiler/hsSyn/HsPat.lhs
@@ -20,11 +20,10 @@ module HsPat (
 	HsConPatDetails, hsConPatArgs, 
 	HsRecFields(..), HsRecField(..), hsRecFields,
 
-	mkPrefixConPat, mkCharLitPat, mkNilPat, mkCoPat, mkCoPatCoI,
+	mkPrefixConPat, mkCharLitPat, mkNilPat, 
 
-	isBangHsBind, hsPatNeedsParens,
-	patsAreAllCons, isConPat, isSigPat, isWildPat,
-	patsAreAllLits,	isLitPat, isIrrefutableHsPat,
+	isBangHsBind, isBangLPat, hsPatNeedsParens,
+	isIrrefutableHsPat,
 
 	pprParendLPat
     ) where
@@ -37,7 +36,6 @@ import HsLit
 import HsTypes
 import BasicTypes
 -- others:
-import Coercion
 import PprCore		( {- instance OutputableBndr TyVar -} )
 import TysWiredIn
 import Var
@@ -65,7 +63,7 @@ data Pat id
 	-- support hsPatType :: Pat Id -> Type
 
   | VarPat	id			-- Variable
-  | VarPatOut	id (DictBinds id)	-- Used only for overloaded Ids; the 
+  | VarPatOut	id TcEvBinds		-- Used only for overloaded Ids; the 
 					-- bindings give its overloaded instances
   | LazyPat	(LPat id)		-- Lazy pattern
   | AsPat	(Located id) (LPat id)  -- As pattern
@@ -101,10 +99,10 @@ data Pat id
   | ConPatOut {
 	pat_con   :: Located DataCon,
 	pat_tvs   :: [TyVar],		-- Existentially bound type variables (tyvars only)
-	pat_dicts :: [id],		-- Ditto *coercion variables* and *dictionaries*
+	pat_dicts :: [EvVar],		-- Ditto *coercion variables* and *dictionaries*
 					-- One reason for putting coercion variable here, I think,
 					-- 	is to ensure their kinds are zonked
-	pat_binds :: DictBinds id,	-- Bindings involving those dictionaries
+	pat_binds :: TcEvBinds,		-- Bindings involving those dictionaries
 	pat_args  :: HsConPatDetails id,
 	pat_ty	  :: Type   		-- The type of the pattern
     }
@@ -148,7 +146,7 @@ data Pat id
 		    Type
 
 	------------ Pattern coercions (translation only) ---------------
-  | CoPat 	HsWrapper		-- If co::t1 -> t2, p::t2, 
+  | CoPat 	HsWrapper		-- If co :: t1 ~ t2, p :: t2, 
 					-- then (CoPat co p) :: t1
 		(Pat id)		-- Why not LPat?  Ans: existing locn will do
 	    	Type			-- Type of whole pattern, t1
@@ -276,7 +274,7 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
     if debugStyle sty then 	-- typechecked Pat in an error message, 
 				-- and we want to make sure it prints nicely
 	ppr con <+> sep [ hsep (map pprPatBndr tvs) <+> hsep (map pprPatBndr dicts),
-		   	  pprLHsBinds binds, pprConArgs details]
+		   	  ppr binds, pprConArgs details]
     else pprUserCon con details
 
 pprPat (LitPat s)	    = ppr s
@@ -331,7 +329,7 @@ mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id
 -- Make a vanilla Prefix constructor pattern
 mkPrefixConPat dc pats ty 
   = noLoc $ ConPatOut { pat_con = noLoc dc, pat_tvs = [], pat_dicts = [],
-			pat_binds = emptyLHsBinds, pat_args = PrefixCon pats, 
+			pat_binds = emptyTcEvBinds, pat_args = PrefixCon pats, 
 			pat_ty = ty }
 
 mkNilPat :: Type -> OutPat id
@@ -339,15 +337,6 @@ mkNilPat ty = mkPrefixConPat nilDataCon [] ty
 
 mkCharLitPat :: Char -> OutPat id
 mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy
-
-mkCoPat :: HsWrapper -> Pat id -> Type -> Pat id
-mkCoPat co pat ty
-  | isIdHsWrapper co = pat
-  | otherwise        = CoPat co pat ty
-
-mkCoPatCoI :: CoercionI -> Pat id -> Type -> Pat id
-mkCoPatCoI IdCo     pat _  = pat
-mkCoPatCoI (ACo co) pat ty = mkCoPat (WpCast co) pat ty
 \end{code}
 
 
@@ -381,41 +370,15 @@ patterns are treated specially, of course.
 
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 \begin{code}
-isWildPat :: Pat id -> Bool
-isWildPat (WildPat _) = True
-isWildPat _           = False
-
-patsAreAllCons :: [Pat id] -> Bool
-patsAreAllCons pat_list = all isConPat pat_list
-
-isConPat :: Pat id -> Bool
-isConPat (AsPat _ pat)	 = isConPat (unLoc pat)
-isConPat (ConPatIn {})	 = True
-isConPat (ConPatOut {})  = True
-isConPat (ListPat {})	 = True
-isConPat (PArrPat {})	 = True
-isConPat (TuplePat {})	 = True
-isConPat _               = False
-
-isSigPat :: Pat id -> Bool
-isSigPat (SigPatIn _ _)  = True
-isSigPat (SigPatOut _ _) = True
-isSigPat _               = False
-
-patsAreAllLits :: [Pat id] -> Bool
-patsAreAllLits pat_list = all isLitPat pat_list
-
-isLitPat :: Pat id -> Bool
-isLitPat (AsPat _ pat)	        = isLitPat (unLoc pat)
-isLitPat (LitPat _)	        = True
-isLitPat (NPat _ _ _)	        = True
-isLitPat (NPlusKPat _ _ _ _)    = True
-isLitPat _                      = False
+isBangLPat :: LPat id -> Bool
+isBangLPat (L _ (BangPat {})) = True
+isBangLPat (L _ (ParPat p))   = isBangLPat p
+isBangLPat _                  = False
 
 isBangHsBind :: HsBind id -> Bool
 -- In this module because HsPat is above HsBinds in the import graph
-isBangHsBind (PatBind { pat_lhs = L _ (BangPat _) }) = True
-isBangHsBind _                                       = False
+isBangHsBind (PatBind { pat_lhs = p }) = isBangLPat p
+isBangHsBind _                         = False
 
 isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index a5e8982..38608a4 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -359,8 +359,8 @@ pprHsForAll exp tvs cxt
 pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc
 pprHsContext []	        = empty
 pprHsContext [L _ pred] 
-   | noParenHsPred pred = ppr pred <+> ptext (sLit "=>")
-pprHsContext cxt        = ppr_hs_context cxt <+> ptext (sLit "=>")
+   | noParenHsPred pred = ppr pred <+> darrow
+pprHsContext cxt        = ppr_hs_context cxt <+> darrow
 
 noParenHsPred :: HsPred name -> Bool
 -- c.f. TypeRep.noParenPred
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index cfd2799..f01fb6e 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -19,8 +19,9 @@ module HsUtils(
   mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
   mkSimpleMatch, unguardedGRHSs, unguardedRHS, 
   mkMatchGroup, mkMatch, mkHsLam,
-  mkHsWrap, mkLHsWrap, mkHsWrapCoI, coiToHsWrapper, mkHsDictLet,
-  mkHsOpApp, mkHsDo,
+  mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
+  coiToHsWrapper, mkHsDictLet,
+  mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI,
 
   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
@@ -52,7 +53,7 @@ module HsUtils(
   noRebindableInfo, 
 
   -- Collecting binders
-  collectLocalBinders, collectHsValBinders, 
+  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
   collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
   collectPatBinders, collectPatsBinders,
   collectLStmtsBinders, collectStmtsBinders,
@@ -132,13 +133,25 @@ mkHsWrap co_fn e | isIdHsWrapper co_fn = e
 		 | otherwise	       = HsWrap co_fn e
 
 mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
-mkHsWrapCoI IdCo     e = e
+mkHsWrapCoI (IdCo _) e = e
 mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
 
+mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id
+mkLHsWrapCoI (IdCo _) e         = e
+mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e)
+
 coiToHsWrapper :: CoercionI -> HsWrapper
-coiToHsWrapper IdCo     = idHsWrapper
+coiToHsWrapper (IdCo _) = idHsWrapper
 coiToHsWrapper (ACo co) = WpCast co
 
+mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
+mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
+		       | otherwise	     = CoPat co_fn p ty
+
+mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id
+mkHsWrapPatCoI (IdCo _) pat _  = pat
+mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty
+
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 	where
@@ -147,14 +160,8 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
 mkMatchGroup :: [LMatch id] -> MatchGroup id
 mkMatchGroup matches = MatchGroup matches placeHolderType
 
-mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id
--- Used for the dictionary bindings gotten from TcSimplify
--- We make them recursive to be on the safe side
-mkHsDictLet binds expr 
-  | isEmptyLHsBinds binds = expr
-  | otherwise             = L (getLoc expr) (HsLet (HsValBinds val_binds) expr)
-			  where
-			    val_binds = ValBindsOut [(Recursive, binds)] []
+mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
+mkHsDictLet ev_binds expr = mkLHsWrap (WpLet ev_binds) expr
 
 mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
 -- Used for constructing dictionary terms etc, so no locations 
@@ -219,7 +226,7 @@ mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
 emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = []
                        , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr
 		       , recS_bind_fn = noSyntaxExpr
-                       , recS_rec_rets = [], recS_dicts = emptyLHsBinds }
+                       , recS_rec_rets = [], recS_dicts = emptyTcEvBinds }
 
 mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
 
@@ -461,6 +468,9 @@ collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
 collectHsBindsBinders binds = collect_binds binds []
 
+collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
+collectHsBindListBinders = foldr (collect_bind . unLoc) []
+
 collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
 collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
 
@@ -507,7 +517,8 @@ collect_lpat (L _ pat) bndrs
   = go pat
   where
     go (VarPat var) 	   	  = var : bndrs
-    go (VarPatOut var bs) 	  = var : collect_binds bs bndrs
+    go (VarPatOut var _) 	  = var : bndrs
+	-- See Note [Dictionary binders in ConPatOut]
     go (WildPat _)	      	  = bndrs
     go (LazyPat pat)     	  = collect_lpat pat bndrs
     go (BangPat pat)     	  = collect_lpat pat bndrs
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 8a3dfd7..de57feb 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -5,10 +5,12 @@
 
 \begin{code}
 module BuildTyCl (
-	buildSynTyCon, buildAlgTyCon, buildDataCon,
+	buildSynTyCon, 
+        buildAlgTyCon, 
+        buildDataCon,
 	TcMethInfo, buildClass,
-	mkAbstractTyConRhs, mkOpenDataTyConRhs, 
-	mkNewTyConRhs, mkDataTyConRhs, setAssocFamilyPermutation
+	mkAbstractTyConRhs, 
+	mkNewTyConRhs, mkDataTyConRhs
     ) where
 
 #include "HsVersions.h"
@@ -27,7 +29,7 @@ import Type
 import Coercion
 
 import TcRnMonad
-import Util		( count )
+import Data.List	( partition )
 import Outputable
 \end{code}
 	
@@ -35,29 +37,22 @@ import Outputable
 \begin{code}
 ------------------------------------------------------
 buildSynTyCon :: Name -> [TyVar] 
-              -> SynTyConRhs 
+              -> SynTyConRhs
 	      -> Kind			-- ^ Kind of the RHS
-	      -> Maybe (TyCon, [Type])  -- ^ family instance if applicable
+	      -> TyConParent
+	      -> Maybe (TyCon, [Type])    -- ^ family instance if applicable
               -> TcRnIf m n TyCon
-
-buildSynTyCon tc_name tvs rhs@(OpenSynTyCon {}) rhs_kind _
-  = let
-      kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
-    in
-    return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
-    
-buildSynTyCon tc_name tvs rhs@(SynonymTyCon {}) rhs_kind mb_family
-  = do { -- We need to tie a knot as the coercion of a data instance depends
-	 -- on the instance representation tycon and vice versa.
-       ; tycon <- fixM (\ tycon_rec -> do 
-	 { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
-	 ; let { tycon   = mkSynTyCon tc_name kind tvs rhs parent
-	       ; kind    = mkArrowKinds (map tyVarKind tvs) rhs_kind
-	       }
-         ; return tycon
-         })
-       ; return tycon 
-       }
+buildSynTyCon tc_name tvs rhs rhs_kind parent mb_family 
+  | Just fam_inst_info <- mb_family
+  = ASSERT( isNoParent parent )
+    fixM $ \ tycon_rec -> do 
+    { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec 
+    ; return (mkSynTyCon tc_name kind tvs rhs fam_parent) }
+
+  | otherwise
+  = return (mkSynTyCon tc_name kind tvs rhs parent)
+  where
+    kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
 
 ------------------------------------------------------
 buildAlgTyCon :: Name -> [TyVar] 
@@ -66,23 +61,26 @@ buildAlgTyCon :: Name -> [TyVar]
 	      -> RecFlag
 	      -> Bool			-- ^ True <=> want generics functions
 	      -> Bool			-- ^ True <=> was declared in GADT syntax
+              -> TyConParent
 	      -> Maybe (TyCon, [Type])  -- ^ family instance if applicable
 	      -> TcRnIf m n TyCon
 
 buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
-	      mb_family
-  = do { -- We need to tie a knot as the coercion of a data instance depends
-	 -- on the instance representation tycon and vice versa.
-       ; tycon <- fixM (\ tycon_rec -> do 
-	 { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
-	 ; let { tycon = mkAlgTyCon tc_name kind tvs stupid_theta rhs
-				    parent is_rec want_generics gadt_syn
-	       ; kind  = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
-	       }
-         ; return tycon
-         })
-       ; return tycon 
-       }
+	      parent mb_family
+  | Just fam_inst_info <- mb_family
+  = -- We need to tie a knot as the coercion of a data instance depends
+     -- on the instance representation tycon and vice versa.
+    ASSERT( isNoParent parent )
+    fixM $ \ tycon_rec -> do 
+    { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec
+    ; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
+		         fam_parent is_rec want_generics gadt_syn) }
+
+  | otherwise
+  = return (mkAlgTyCon tc_name kind tvs stupid_theta rhs
+	               parent is_rec want_generics gadt_syn)
+  where
+    kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind
 
 -- | If a family tycon with instance types is given, the current tycon is an
 -- instance of that family and we need to
@@ -95,27 +93,21 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
 -- (2) produce a `TyConParent' value containing the parent and coercion
 --     information.
 --
-mkParentInfo :: Maybe (TyCon, [Type]) 
-             -> Name -> [TyVar] 
-             -> TyCon 
-             -> TcRnIf m n TyConParent
-mkParentInfo Nothing                  _       _   _         =
-  return NoParentTyCon
-mkParentInfo (Just (family, instTys)) tc_name tvs rep_tycon =
-  do { -- Create the coercion
-     ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
-     ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
+mkFamInstParentInfo :: Name -> [TyVar] 
+             	    -> (TyCon, [Type]) 
+             	    -> TyCon 
+             	    -> TcRnIf m n TyConParent
+mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon
+  = do { -- Create the coercion
+       ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
+       ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
                                         family instTys rep_tycon
-     ; return $ FamilyTyCon family instTys co_tycon
-     }
+       ; return $ FamInstTyCon family instTys co_tycon }
     
 ------------------------------------------------------
 mkAbstractTyConRhs :: AlgTyConRhs
 mkAbstractTyConRhs = AbstractTyCon
 
-mkOpenDataTyConRhs :: AlgTyConRhs
-mkOpenDataTyConRhs = OpenTyCon Nothing
-
 mkDataTyConRhs :: [DataCon] -> AlgTyConRhs
 mkDataTyConRhs cons
   = DataTyCon {
@@ -182,13 +174,6 @@ mkNewTyConRhs tycon_name tycon con
     eta_reduce tvs ty = (reverse tvs, ty)
 				
 
-setAssocFamilyPermutation :: [TyVar] -> TyThing -> TyThing
-setAssocFamilyPermutation clas_tvs (ATyCon tc) 
-  = ATyCon (setTyConArgPoss clas_tvs tc)
-setAssocFamilyPermutation _clas_tvs other
-  = pprPanic "setAssocFamilyPermutation" (ppr other)
-
-
 ------------------------------------------------------
 buildDataCon :: Name -> Bool
 	    -> [HsBang] 
@@ -249,9 +234,9 @@ mkDataConStupidTheta tycon arg_tys univ_tvs
 type TcMethInfo = (Name, DefMethSpec, Type)  -- A temporary intermediate, to communicate 
 					     -- between tcClassSigs and buildClass
 
-buildClass :: Bool			-- True <=> do not include unfoldings 
-					--	    on dict selectors
-					-- Used when importing a class without -O
+buildClass :: Bool		-- True <=> do not include unfoldings 
+				--	    on dict selectors
+				-- Used when importing a class without -O
 	   -> Name -> [TyVar] -> ThetaType
 	   -> [FunDep TyVar]		   -- Functional dependencies
 	   -> [TyThing]			   -- Associated types
@@ -272,14 +257,14 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 	; op_items <- mapM (mk_op_item rec_clas) sig_stuff
 	  		-- Build the selector id and default method id
 
-	; let n_value_preds   = count (not . isEqPred) sc_theta
-	      all_value_preds = n_value_preds == length sc_theta
+	; let (eq_theta, dict_theta) = partition isEqPred sc_theta
+
 	      -- We only make selectors for the *value* superclasses, 
 	      -- not equality predicates 
-
 	; sc_sel_names <- mapM  (newImplicitBinder class_name . mkSuperDictSelOcc) 
-				[1..n_value_preds]
-        ; let sc_sel_ids = [mkDictSelId no_unf sc_name rec_clas | sc_name <- sc_sel_names]
+				[1..length dict_theta]
+        ; let sc_sel_ids = [ mkDictSelId no_unf sc_name rec_clas 
+                           | sc_name <- sc_sel_names]
 	      -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we 
 	      -- can construct names for the selectors. Thus
 	      --      class (C a, C b) => D a b where ...
@@ -287,23 +272,23 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 	      --      D_sc1, D_sc2
 	      -- (We used to call them D_C, but now we can have two different
 	      --  superclasses both called C!)
-	      --
 	
-	; let use_newtype = (n_value_preds + length sig_stuff == 1) && all_value_preds
+	; let use_newtype = null eq_theta && (length dict_theta + length sig_stuff == 1)
 		-- Use a newtype if the data constructor has 
 		-- 	(a) exactly one value field
 		--	(b) no existential or equality-predicate fields
 		-- i.e. exactly one operation or superclass taken together
 		-- See note [Class newtypes and equality predicates]
 
-		-- We play a bit fast and loose by treating the superclasses
-		-- as ordinary arguments.  That means that in the case of
+		-- We play a bit fast and loose by treating the dictionary
+		-- superclasses as ordinary arguments.  That means that in 
+                -- the case of
 		--     class C a => D a
 		-- we don't get a newtype with no arguments!
 	      args      = sc_sel_names ++ op_names
-	      arg_tys   = map mkPredTy sc_theta ++ op_tys
 	      op_tys	= [ty | (_,_,ty) <- sig_stuff]
 	      op_names  = [op | (op,_,_) <- sig_stuff]
+	      arg_tys   = map mkPredTy dict_theta ++ op_tys
               rec_tycon = classTyCon rec_clas
                
 	; dict_con <- buildDataCon datacon_name
@@ -311,7 +296,8 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 				   (map (const HsNoBang) args)
 				   [{- No fields -}]
 				   tvs [{- no existentials -}]
-                                   [{- No GADT equalities -}] [{- No theta -}]
+                                   [{- No GADT equalities -}] 
+                                   eq_theta
                                    arg_tys
 				   (mkTyConApp rec_tycon (mkTyVarTys tvs))
 				   rec_tycon
@@ -335,7 +321,9 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
 	      ; atTyCons = [tycon | ATyCon tycon <- ats]
 
 	      ; result = mkClass class_name tvs fds 
-			         sc_theta sc_sel_ids atTyCons
+			         (eq_theta ++ dict_theta)  -- Equalities first
+                                 (length eq_theta)	   -- Number of equalities
+                                 sc_sel_ids atTyCons
 				 op_items tycon
 	      }
 	; traceIf (text "buildClass" <+> ppr tycon) 
diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index 442ecf2..47772d7 100644
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -265,7 +265,7 @@ instance Outputable IfaceTyCon where
 pprIfaceContext :: IfaceContext -> SDoc
 -- Prints "(C a, D b) =>", including the arrow
 pprIfaceContext []     = empty
-pprIfaceContext theta = ppr_preds theta <+> ptext (sLit "=>")
+pprIfaceContext theta = ppr_preds theta <+> darrow
 
 ppr_preds :: [IfacePredType] -> SDoc
 ppr_preds [pred] = ppr pred	-- No parens
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index ce08f6d..31e5875 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -31,7 +31,6 @@ import TcRnMonad
 
 import PrelNames
 import PrelInfo
-import PrelRules
 import Rules
 import Annotations
 import InstEnv
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 5c236b3..fa9e0ec 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -62,6 +62,7 @@ import Class
 import TyCon
 import DataCon
 import Type
+import Coercion
 import TcType
 import InstEnv
 import FamInstEnv
@@ -318,7 +319,10 @@ mkIface_ hsc_env maybe_old_fingerprint
      le_occ n1 n2 = nameOccName n1 <= nameOccName n2
 
      dflags = hsc_dflags hsc_env
+
+     deliberatelyOmitted :: String -> a
      deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)
+
      ifFamInstTcName = ifaceTyConName . ifFamInstTyCon
 
      flattenVectInfo (VectInfo { vectInfoVar   = vVar
@@ -1377,14 +1381,14 @@ tyThingToIfaceDecl (ATyCon tycon)
     tyvars = tyConTyVars tycon
     (syn_rhs, syn_ki) 
        = case synTyConRhs tycon of
-	    OpenSynTyCon ki _ -> (Nothing,               toIfaceType ki)
-	    SynonymTyCon ty   -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
+	    SynFamilyTyCon  -> (Nothing,               toIfaceType (synTyConResKind tycon))
+	    SynonymTyCon ty -> (Just (toIfaceType ty), toIfaceType (typeKind ty))
 
     ifaceConDecls (NewTyCon { data_con = con })     = 
       IfNewTyCon  (ifaceConDecl con)
     ifaceConDecls (DataTyCon { data_cons = cons })  = 
       IfDataTyCon (map ifaceConDecl cons)
-    ifaceConDecls OpenTyCon {}                      = IfOpenDataTyCon
+    ifaceConDecls DataFamilyTyCon {}                = IfOpenDataTyCon
     ifaceConDecls AbstractTyCon			    = IfAbstractTyCon
 	-- The last case happens when a TyCon has been trimmed during tidying
 	-- Furthermore, tyThingToIfaceDecl is also used
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 1f846d3..83a2458 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -414,16 +414,21 @@ the forkM stuff.
 tcIfaceDecl :: Bool	-- True <=> discard IdInfo on IfaceId bindings
 	    -> IfaceDecl
 	    -> IfL TyThing
-
-tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, 
- 	    		 	   ifIdDetails = details, ifIdInfo = info})
+tcIfaceDecl = tc_iface_decl NoParentTyCon
+
+tc_iface_decl :: TyConParent	-- For nested declarations
+              -> Bool	-- True <=> discard IdInfo on IfaceId bindings
+	      -> IfaceDecl
+	      -> IfL TyThing
+tc_iface_decl _ ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, 
+ 	                               ifIdDetails = details, ifIdInfo = info})
   = do	{ name <- lookupIfaceTop occ_name
 	; ty <- tcIfaceType iface_type
 	; details <- tcIdDetails ty details
 	; info <- tcIdInfo ignore_prags name ty info
 	; return (AnId (mkGlobalId details name ty info)) }
 
-tcIfaceDecl _ (IfaceData {ifName = occ_name, 
+tc_iface_decl parent _ (IfaceData {ifName = occ_name, 
 			  ifTyVars = tv_bndrs, 
 			  ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
 			  ifCons = rdr_cons, 
@@ -434,34 +439,33 @@ tcIfaceDecl _ (IfaceData {ifName = occ_name,
     { tc_name <- lookupIfaceTop occ_name
     ; tycon <- fixM ( \ tycon -> do
 	    { stupid_theta <- tcIfaceCtxt ctxt
-	    ; mb_fam_inst  <- tcFamInst mb_family
 	    ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons
-	    ; buildAlgTyCon tc_name tyvars stupid_theta
-			    cons is_rec want_generic gadt_syn mb_fam_inst
+	    ; mb_fam_inst  <- tcFamInst mb_family
+	    ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec
+			    want_generic gadt_syn parent mb_fam_inst
 	    })
     ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
     ; return (ATyCon tycon) }
 
-tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
-		         ifSynRhs = mb_rhs_ty,
-		         ifSynKind = kind, ifFamInst = mb_family})
+tc_iface_decl parent _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
+		         	  ifSynRhs = mb_rhs_ty,
+		         	  ifSynKind = kind, ifFamInst = mb_family})
    = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do
-     { tc_name <- lookupIfaceTop occ_name
+     { tc_name  <- lookupIfaceTop occ_name
      ; rhs_kind <- tcIfaceType kind	-- Note [Synonym kind loop]
-     ; ~(rhs, fam) <- forkM (mk_doc tc_name) $ 
-       	      	      do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty
-			 ; fam <- tcFamInst mb_family
-			 ; return (rhs, fam) }
-     ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam
-     ; return $ ATyCon tycon
+     ; rhs      <- forkM (mk_doc tc_name) $ 
+       	      	   tc_syn_rhs mb_rhs_ty
+     ; fam_info <- tcFamInst mb_family
+     ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind parent fam_info
+     ; return (ATyCon tycon)
      }
    where
      mk_doc n = ptext (sLit "Type syonym") <+> ppr n
-     tc_syn_rhs kind Nothing   = return (OpenSynTyCon kind Nothing)
-     tc_syn_rhs _    (Just ty) = do { rhs_ty <- tcIfaceType ty
-		   		    ; return (SynonymTyCon rhs_ty) }
+     tc_syn_rhs Nothing   = return SynFamilyTyCon
+     tc_syn_rhs (Just ty) = do { rhs_ty <- tcIfaceType ty
+		               ; return (SynonymTyCon rhs_ty) }
 
-tcIfaceDecl ignore_prags
+tc_iface_decl _parent ignore_prags
 	    (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, 
 			 ifTyVars = tv_bndrs, ifFDs = rdr_fds, 
 			 ifATs = rdr_ats, ifSigs = rdr_sigs, 
@@ -473,9 +477,9 @@ tcIfaceDecl ignore_prags
     ; ctxt <- tcIfaceCtxt rdr_ctxt
     ; sigs <- mapM tc_sig rdr_sigs
     ; fds  <- mapM tc_fd rdr_fds
-    ; ats' <- mapM (tcIfaceDecl ignore_prags) rdr_ats
-    ; let ats = map (setAssocFamilyPermutation tyvars) ats'
-    ; cls  <- buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec
+    ; cls  <- fixM $ \ cls -> do
+              { ats  <- mapM (tc_iface_decl (AssocFamilyTyCon cls) ignore_prags) rdr_ats
+              ; buildClass ignore_prags cls_name tyvars ctxt fds ats sigs tc_isrec }
     ; return (AClass cls) }
   where
    tc_sig (IfaceClassOp occ dm rdr_ty)
@@ -492,7 +496,7 @@ tcIfaceDecl ignore_prags
 			   ; tvs2' <- mapM tcIfaceTyVar tvs2
 			   ; return (tvs1', tvs2') }
 
-tcIfaceDecl _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
+tc_iface_decl _ _ (IfaceForeign {ifName = rdr_name, ifExtName = ext_name})
   = do	{ name <- lookupIfaceTop rdr_name
 	; return (ATyCon (mkForeignTyCon name ext_name 
 					 liftedTypeKind 0)) }
@@ -507,7 +511,7 @@ tcIfaceDataCons :: Name -> TyCon -> [TyVar] -> IfaceConDecls -> IfL AlgTyConRhs
 tcIfaceDataCons tycon_name tycon _ if_cons
   = case if_cons of
 	IfAbstractTyCon	 -> return mkAbstractTyConRhs
-	IfOpenDataTyCon	 -> return mkOpenDataTyConRhs
+	IfOpenDataTyCon	 -> return DataFamilyTyCon
 	IfDataTyCon cons -> do 	{ data_cons <- mapM tc_con_decl cons
 				; return (mkDataTyConRhs data_cons) }
 	IfNewTyCon con	 -> do 	{ data_con <- tc_con_decl con
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 75f31ca..557dfb4 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -293,6 +293,7 @@ data ExtensionFlag
    | Opt_MonomorphismRestriction
    | Opt_MonoPatBinds
    | Opt_MonoLocalBinds
+   | Opt_RelaxedPolyRec		-- Deprecated
    | Opt_ExtendedDefaultRules           -- Use GHC's extended rules for defaulting
    | Opt_ForeignFunctionInterface
    | Opt_UnliftedFFITypes
@@ -314,8 +315,6 @@ data ExtensionFlag
    | Opt_RecordPuns
    | Opt_ViewPatterns
    | Opt_GADTs
-   | Opt_OutsideIn
-   | Opt_RelaxedPolyRec		-- Deprecated
    | Opt_NPlusKPatterns
    | Opt_DoAndIfThenElse
 
@@ -731,26 +730,9 @@ defaultDynFlags =
         filesToClean   = panic "defaultDynFlags: No filesToClean",
         dirsToClean    = panic "defaultDynFlags: No dirsToClean",
         haddockOptions = Nothing,
-        flags = [
-            Opt_AutoLinkPackages,
-            Opt_ReadUserPackageConf,
-
-            Opt_MethodSharing,
-
-            Opt_DoAsmMangling,
-
-            Opt_SharedImplib,
-
-            Opt_GenManifest,
-            Opt_EmbedManifest,
-            Opt_PrintBindContents
-            ]
-            ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
-                    -- The default -O0 options
-            ++ standardWarnings,
-
+        flags = defaultFlags,
         language = Nothing,
-        extensionFlags = Left [],
+        extensionFlags = Left defaultExtensionFlags,
 
         log_action = \severity srcSpan style msg ->
                         case severity of
@@ -1004,95 +986,6 @@ updOptLevel n dfs
    extra_dopts  = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ]
    remove_dopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ]
 
-optLevelFlags :: [([Int], DynFlag)]
-optLevelFlags
-  = [ ([0],     Opt_IgnoreInterfacePragmas)
-    , ([0],     Opt_OmitInterfacePragmas)
-
-    , ([1,2],   Opt_IgnoreAsserts)
-    , ([1,2],   Opt_EnableRewriteRules)  -- Off for -O0; see Note [Scoping for Builtin rules]
-                                         --              in PrelRules
-    , ([1,2],   Opt_DoEtaReduction)
-    , ([1,2],   Opt_CaseMerge)
-    , ([1,2],   Opt_Strictness)
-    , ([1,2],   Opt_CSE)
-    , ([1,2],   Opt_FullLaziness)
-    , ([1,2],   Opt_Specialise)
-    , ([1,2],   Opt_FloatIn)
-
-    , ([2],     Opt_LiberateCase)
-    , ([2],     Opt_SpecConstr)
-    , ([2],     Opt_RegsGraph)
-
---     , ([2],     Opt_StaticArgumentTransformation)
--- Max writes: I think it's probably best not to enable SAT with -O2 for the
--- 6.10 release. The version of SAT in HEAD at the moment doesn't incorporate
--- several improvements to the heuristics, and I'm concerned that without
--- those changes SAT will interfere with some attempts to write "high
--- performance Haskell", as we saw in some posts on Haskell-Cafe earlier
--- this year. In particular, the version in HEAD lacks the tail call
--- criterion, so many things that look like reasonable loops will be
--- turned into functions with extra (unneccesary) thunk creation.
-
-    , ([0,1,2], Opt_DoLambdaEtaExpansion)
-                -- This one is important for a tiresome reason:
-                -- we want to make sure that the bindings for data
-                -- constructors are eta-expanded.  This is probably
-                -- a good thing anyway, but it seems fragile.
-    ]
-
--- -----------------------------------------------------------------------------
--- Standard sets of warning options
-
-standardWarnings :: [DynFlag]
-standardWarnings
-    = [ Opt_WarnWarningsDeprecations,
-        Opt_WarnDeprecatedFlags,
-        Opt_WarnUnrecognisedPragmas,
-        Opt_WarnOverlappingPatterns,
-        Opt_WarnMissingFields,
-        Opt_WarnMissingMethods,
-        Opt_WarnDuplicateExports,
-        Opt_WarnLazyUnliftedBindings,
-        Opt_WarnDodgyForeignImports,
-        Opt_WarnWrongDoBind,
-        Opt_WarnAlternativeLayoutRuleTransitional
-      ]
-
-minusWOpts :: [DynFlag]
-minusWOpts
-    = standardWarnings ++
-      [ Opt_WarnUnusedBinds,
-        Opt_WarnUnusedMatches,
-        Opt_WarnUnusedImports,
-        Opt_WarnIncompletePatterns,
-        Opt_WarnDodgyExports,
-        Opt_WarnDodgyImports
-      ]
-
-minusWallOpts :: [DynFlag]
-minusWallOpts
-    = minusWOpts ++
-      [ Opt_WarnTypeDefaults,
-        Opt_WarnNameShadowing,
-        Opt_WarnMissingSigs,
-        Opt_WarnHiShadows,
-        Opt_WarnOrphans,
-        Opt_WarnUnusedDoBind
-      ]
-
--- minuswRemovesOpts should be every warning option
-minuswRemovesOpts :: [DynFlag]
-minuswRemovesOpts
-    = minusWallOpts ++
-      [Opt_WarnImplicitPrelude,
-       Opt_WarnIncompletePatternsRecUpd,
-       Opt_WarnSimplePatterns,
-       Opt_WarnMonomorphism,
-       Opt_WarnUnrecognisedPragmas,
-       Opt_WarnTabs
-      ]
-
 -- -----------------------------------------------------------------------------
 -- StgToDo:  abstraction of stg-to-stg passes to run.
 
@@ -1558,8 +1451,7 @@ fFlags = [
   ( "warn-orphans",                     Opt_WarnOrphans, nop ),
   ( "warn-tabs",                        Opt_WarnTabs, nop ),
   ( "warn-unrecognised-pragmas",        Opt_WarnUnrecognisedPragmas, nop ),
-  ( "warn-lazy-unlifted-bindings",      Opt_WarnLazyUnliftedBindings,
-    \_ -> deprecate "lazy unlifted bindings will be an error in GHC 6.14, and this flag will no longer exist"),
+  ( "warn-lazy-unlifted-bindings",      Opt_WarnLazyUnliftedBindings, nop),
   ( "warn-unused-do-bind",              Opt_WarnUnusedDoBind, nop ),
   ( "warn-wrong-do-bind",               Opt_WarnWrongDoBind, nop ),
   ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ),
@@ -1746,6 +1638,31 @@ xFlags = [
     \_ -> deprecate "The new qualified operator syntax was rejected by Haskell'" )
   ]
 
+defaultFlags :: [DynFlag]
+defaultFlags 
+  = [ Opt_AutoLinkPackages,
+      Opt_ReadUserPackageConf,
+
+      Opt_MethodSharing,
+
+      Opt_DoAsmMangling,
+
+      Opt_SharedImplib,
+
+      Opt_GenManifest,
+      Opt_EmbedManifest,
+      Opt_PrintBindContents
+    ]
+
+    ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
+             -- The default -O0 options
+
+    ++ standardWarnings
+
+defaultExtensionFlags :: [OnOff ExtensionFlag]
+defaultExtensionFlags 
+  = []		-- In due course I'd like Opt_MonoLocalBinds to be on by default
+
 impliedFlags :: [(ExtensionFlag, ExtensionFlag)]
 impliedFlags
   = [ (Opt_RankNTypes,                Opt_ExplicitForAll)
@@ -1755,15 +1672,13 @@ impliedFlags
     , (Opt_ExistentialQuantification, Opt_ExplicitForAll)
     , (Opt_PolymorphicComponents,     Opt_ExplicitForAll)
 
-    , (Opt_GADTs,               Opt_OutsideIn)       -- We want type-sig variables to
-                                                     --      be completely rigid for GADTs
+    , (Opt_GADTs,                  Opt_MonoLocalBinds)
+    , (Opt_TypeFamilies,           Opt_MonoLocalBinds)
+    , (Opt_FunctionalDependencies, Opt_MonoLocalBinds)
 
-    , (Opt_TypeFamilies,        Opt_OutsideIn)       -- Trac #2944 gives a nice example
     , (Opt_TypeFamilies,        Opt_KindSignatures)  -- Type families use kind signatures
       						     -- all over the place
 
-    , (Opt_ScopedTypeVariables, Opt_OutsideIn)       -- Ditto for scoped type variables; see
-                                                     --      Note [Scoped tyvars] in TcBinds
     , (Opt_ImpredicativeTypes,  Opt_RankNTypes)
 
 	-- Record wild-cards implies field disambiguation
@@ -1773,6 +1688,95 @@ impliedFlags
     , (Opt_RecordWildCards,     Opt_DisambiguateRecordFields)
   ]
 
+optLevelFlags :: [([Int], DynFlag)]
+optLevelFlags
+  = [ ([0],     Opt_IgnoreInterfacePragmas)
+    , ([0],     Opt_OmitInterfacePragmas)
+
+    , ([1,2],   Opt_IgnoreAsserts)
+    , ([1,2],   Opt_EnableRewriteRules)  -- Off for -O0; see Note [Scoping for Builtin rules]
+                                         --              in PrelRules
+    , ([1,2],   Opt_DoEtaReduction)
+    , ([1,2],   Opt_CaseMerge)
+    , ([1,2],   Opt_Strictness)
+    , ([1,2],   Opt_CSE)
+    , ([1,2],   Opt_FullLaziness)
+    , ([1,2],   Opt_Specialise)
+    , ([1,2],   Opt_FloatIn)
+
+    , ([2],     Opt_LiberateCase)
+    , ([2],     Opt_SpecConstr)
+    , ([2],     Opt_RegsGraph)
+
+--     , ([2],     Opt_StaticArgumentTransformation)
+-- Max writes: I think it's probably best not to enable SAT with -O2 for the
+-- 6.10 release. The version of SAT in HEAD at the moment doesn't incorporate
+-- several improvements to the heuristics, and I'm concerned that without
+-- those changes SAT will interfere with some attempts to write "high
+-- performance Haskell", as we saw in some posts on Haskell-Cafe earlier
+-- this year. In particular, the version in HEAD lacks the tail call
+-- criterion, so many things that look like reasonable loops will be
+-- turned into functions with extra (unneccesary) thunk creation.
+
+    , ([0,1,2], Opt_DoLambdaEtaExpansion)
+                -- This one is important for a tiresome reason:
+                -- we want to make sure that the bindings for data
+                -- constructors are eta-expanded.  This is probably
+                -- a good thing anyway, but it seems fragile.
+    ]
+
+-- -----------------------------------------------------------------------------
+-- Standard sets of warning options
+
+standardWarnings :: [DynFlag]
+standardWarnings
+    = [ Opt_WarnWarningsDeprecations,
+        Opt_WarnDeprecatedFlags,
+        Opt_WarnUnrecognisedPragmas,
+        Opt_WarnOverlappingPatterns,
+        Opt_WarnMissingFields,
+        Opt_WarnMissingMethods,
+        Opt_WarnDuplicateExports,
+        Opt_WarnLazyUnliftedBindings,
+        Opt_WarnDodgyForeignImports,
+        Opt_WarnWrongDoBind,
+        Opt_WarnAlternativeLayoutRuleTransitional
+      ]
+
+minusWOpts :: [DynFlag]
+minusWOpts
+    = standardWarnings ++
+      [ Opt_WarnUnusedBinds,
+        Opt_WarnUnusedMatches,
+        Opt_WarnUnusedImports,
+        Opt_WarnIncompletePatterns,
+        Opt_WarnDodgyExports,
+        Opt_WarnDodgyImports
+      ]
+
+minusWallOpts :: [DynFlag]
+minusWallOpts
+    = minusWOpts ++
+      [ Opt_WarnTypeDefaults,
+        Opt_WarnNameShadowing,
+        Opt_WarnMissingSigs,
+        Opt_WarnHiShadows,
+        Opt_WarnOrphans,
+        Opt_WarnUnusedDoBind
+      ]
+
+-- minuswRemovesOpts should be every warning option
+minuswRemovesOpts :: [DynFlag]
+minuswRemovesOpts
+    = minusWallOpts ++
+      [Opt_WarnImplicitPrelude,
+       Opt_WarnIncompletePatternsRecUpd,
+       Opt_WarnSimplePatterns,
+       Opt_WarnMonomorphism,
+       Opt_WarnUnrecognisedPragmas,
+       Opt_WarnTabs
+      ]
+
 enableGlasgowExts :: DynP ()
 enableGlasgowExts = do setDynFlag Opt_PrintExplicitForalls
                        mapM_ setExtensionFlag glasgowExtsFlags
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 5dfa76c..92345c7 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -148,7 +148,7 @@ module GHC (
 	TyCon, 
 	tyConTyVars, tyConDataCons, tyConArity,
 	isClassTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isFunTyCon,
-	isOpenTyCon,
+	isFamilyTyCon,
 	synTyConDefn, synTyConType, synTyConResKind,
 
 	-- ** Type variables
@@ -247,7 +247,7 @@ import InteractiveEval
 
 import TcRnDriver
 import TcIface
-import TcRnTypes        hiding (LIE)
+import TcRnTypes
 import TcRnMonad        ( initIfaceCheck )
 import Packages
 import NameSet
@@ -255,6 +255,7 @@ import RdrName
 import qualified HsSyn -- hack as we want to reexport the whole module
 import HsSyn hiding ((<.>))
 import Type
+import Coercion		( synTyConResKind )
 import TcType		hiding( typeKind )
 import Id
 import Var
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 156a04e..5c41f68 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -129,7 +129,7 @@ import Id
 import Type		
 
 import Annotations
-import Class		( Class, classSelIds, classATs, classTyCon )
+import Class		( Class, classAllSelIds, classATs, classTyCon )
 import TyCon
 import DataCon		( DataCon, dataConImplicitIds, dataConWrapId )
 import PrelNames	( gHC_PRIM )
@@ -1333,7 +1333,7 @@ implicitTyThings (AClass cl)
     --    are only the family decls; they have no implicit things
     map ATyCon (classATs cl) ++
     -- superclass and operation selectors
-    map AnId (classSelIds cl)
+    map AnId (classAllSelIds cl)
 
 implicitTyThings (ADataCon dc) = 
     -- For data cons add the worker and (possibly) wrapper
diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index b10a31d..d859784 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -112,7 +112,7 @@ pprTyConHdr _ tyCon
             | otherwise            = sLit "data"
 
     opt_family
-      | GHC.isOpenTyCon tyCon = ptext (sLit "family")
+      | GHC.isFamilyTyCon tyCon = ptext (sLit "family")
       | otherwise             = empty
 
     opt_stupid 	-- The "stupid theta" part of the declaration
@@ -149,15 +149,15 @@ pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc
 --	(C a, Ord b) => stuff
 pprTypeForUser print_foralls ty 
   | print_foralls = ppr tidy_ty
-  | otherwise     = ppr (mkPhiTy [p | (_tvs, ps) <- ctxt, p <- ps] ty')
+  | otherwise     = ppr (mkPhiTy ctxt ty')
   where
     tidy_ty     = tidyTopType ty
-    (ctxt, ty') = tcMultiSplitSigmaTy tidy_ty
+    (_, ctxt, ty') = tcSplitSigmaTy tidy_ty
 
 pprTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc
 pprTyCon pefas show_me tyCon
   | GHC.isSynTyCon tyCon
-  = if GHC.isOpenTyCon tyCon
+  = if GHC.isFamilyTyCon tyCon
     then pprTyConHdr pefas tyCon <+> dcolon <+> 
 	 pprTypeForUser pefas (GHC.synTyConResKind tyCon)
     else 
diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs
index 143d81e..6536a13 100644
--- a/compiler/main/StaticFlagParser.hs
+++ b/compiler/main/StaticFlagParser.hs
@@ -127,6 +127,7 @@ static_flags = [
   , Flag "dsuppress-module-prefixes" (PassFlag addOpt)
   , Flag "dppr-user-length"          (AnySuffix addOpt)
   , Flag "dopt-fuel"                 (AnySuffix addOpt)
+  , Flag "dtrace-level"              (AnySuffix addOpt)
   , Flag "dno-debug-output"          (PassFlag addOpt)
   , Flag "dstub-dead-values"         (PassFlag addOpt)
       -- rest of the debugging flags are dynamic
diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs
index 752c516..a8e3551 100644
--- a/compiler/main/StaticFlags.hs
+++ b/compiler/main/StaticFlags.hs
@@ -24,7 +24,7 @@ module StaticFlags (
 	opt_SuppressUniques,
         opt_SuppressCoercions,
 	opt_SuppressModulePrefixes,
-	opt_PprStyle_Debug,
+	opt_PprStyle_Debug, opt_TraceLevel,
         opt_NoDebugOutput,
 
 	-- profiling opts
@@ -193,7 +193,11 @@ opt_SuppressModulePrefixes :: Bool
 opt_SuppressModulePrefixes	= lookUp  (fsLit "-dsuppress-module-prefixes")
 
 opt_PprStyle_Debug  :: Bool
-opt_PprStyle_Debug		= lookUp  (fsLit "-dppr-debug")
+opt_PprStyle_Debug              = lookUp  (fsLit "-dppr-debug")
+
+opt_TraceLevel :: Int
+opt_TraceLevel = lookup_def_int "-dtrace-level" 1  	-- Standard level is 1
+	       	 			    	        -- Less verbose is 0
 
 opt_PprUserLength   :: Int
 opt_PprUserLength	        = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 6a0a2cf..8ce4dcd 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -20,7 +20,7 @@ import CoreMonad
 import CoreUtils
 import Rules
 import CoreArity	( exprArity, exprBotStrictness_maybe )
-import Class		( classSelIds )
+import Class		( classAllSelIds )
 import VarEnv
 import VarSet
 import Var
@@ -454,7 +454,7 @@ mustExposeTyCon exports tc
   | isEnumerationTyCon tc	-- For an enumeration, exposing the constructors
   = True			-- won't lead to the need for further exposure
 				-- (This includes data types with no constructors.)
-  | isOpenTyCon tc		-- Open type family
+  | isFamilyTyCon tc		-- Open type family
   = True
 
   | otherwise			-- Newtype, datatype
@@ -560,7 +560,7 @@ getImplicitBinds type_env
   = map get_defn (concatMap implicit_ids (typeEnvElts type_env))
   where
     implicit_ids (ATyCon tc)  = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
-    implicit_ids (AClass cls) = classSelIds cls
+    implicit_ids (AClass cls) = classAllSelIds cls
     implicit_ids _            = []
     
     get_defn :: Id -> CoreBind
diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs
index d7659b5..0efc6f5 100644
--- a/compiler/nativeGen/RegAlloc/Liveness.hs
+++ b/compiler/nativeGen/RegAlloc/Liveness.hs
@@ -356,21 +356,30 @@ slurpConflicts live
 --
 --
 slurpReloadCoalesce 
-	:: Instruction instr
+	:: forall instr. Instruction instr
 	=> LiveCmmTop instr
 	-> Bag (Reg, Reg)
 
 slurpReloadCoalesce live
 	= slurpCmm emptyBag live
 
- where	slurpCmm cs CmmData{}	= cs
+ where	
+        slurpCmm :: Bag (Reg, Reg)
+                 -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)]
+                 -> Bag (Reg, Reg)
+        slurpCmm cs CmmData{}	= cs
  	slurpCmm cs (CmmProc _ _ _ sccs)
 		= slurpComp cs (flattenSCCs sccs)
 
+        slurpComp :: Bag (Reg, Reg)
+                     -> [LiveBasicBlock instr]
+                     -> Bag (Reg, Reg)
 	slurpComp  cs blocks
 	 = let	(moveBags, _)	= runState (slurpCompM blocks) emptyUFM
 	   in	unionManyBags (cs : moveBags)
 
+        slurpCompM :: [LiveBasicBlock instr]
+                   -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)]
 	slurpCompM blocks
 	 = do	-- run the analysis once to record the mapping across jumps.
 	 	mapM_	(slurpBlock False) blocks
@@ -381,6 +390,8 @@ slurpReloadCoalesce live
 		--	not worth the trouble.
 		mapM	(slurpBlock True) blocks
 
+        slurpBlock :: Bool -> LiveBasicBlock instr
+                   -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg))
 	slurpBlock propagate (BasicBlock blockId instrs)
 	 = do	-- grab the slot map for entry to this block
 	 	slotMap		<- if propagate
@@ -390,8 +401,7 @@ slurpReloadCoalesce live
 	 	(_, mMoves)	<- mapAccumLM slurpLI slotMap instrs
 	   	return $ listToBag $ catMaybes mMoves
 
-	slurpLI :: Instruction instr
-		=> UniqFM Reg 				-- current slotMap
+	slurpLI :: UniqFM Reg 				-- current slotMap
 		-> LiveInstr instr
 		-> State (UniqFM [UniqFM Reg]) 		-- blockId -> [slot -> reg]
 							-- 	for tracking slotMaps across jumps
diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs
index f856313..00ce130 100644
--- a/compiler/nativeGen/X86/Instr.hs
+++ b/compiler/nativeGen/X86/Instr.hs
@@ -530,7 +530,9 @@ x86_patchRegsOfInstr instr env
     _other		-> panic "patchRegs: unrecognised instr"
 
   where
+    patch1 :: (Operand -> a) -> Operand -> a
     patch1 insn op      = insn $! patchOp op
+    patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a
     patch2 insn src dst = (insn $! patchOp src) $! patchOp dst
 
     patchOp (OpReg  reg) = OpReg $! env reg
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index b0b7751..e78b1ca 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -791,8 +791,8 @@ decllist :: { Located (OrdList (LHsDecl RdrName)) }
 binds 	::  { Located (HsLocalBinds RdrName) } 		-- May have implicit parameters
 						-- No type declarations
 	: decllist			{ L1 (HsValBinds (cvBindGroup (unLoc $1))) }
-	| '{'            dbinds '}'	{ LL (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
-	|     vocurly    dbinds close	{ L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyLHsBinds)) }
+	| '{'            dbinds '}'	{ LL (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
+	|     vocurly    dbinds close	{ L (getLoc $2) (HsIPBinds (IPBinds (unLoc $2) emptyTcEvBinds)) }
 
 wherebinds :: { Located (HsLocalBinds RdrName) }	-- May have implicit parameters
 						-- No type declarations
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index c8d8483..2df4012 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -172,7 +172,7 @@ basicKnownKeyNames
 	newStablePtrName,
 
     -- GHC Extensions
-    groupWithName,
+        groupWithName,
 
 	-- Strings and lists
 	unpackCStringName, unpackCStringAppendName,
@@ -182,6 +182,8 @@ basicKnownKeyNames
 	concatName, filterName, mapName,
 	zipName, foldrName, buildName, augmentName, appendName,
 
+        dollarName,	    -- The ($) apply function
+
         -- Parallel array operations
 	nullPName, lengthPName, replicatePName,	singletonPName, mapPName,
 	filterPName, zipPName, crossMapPName, indexPName,
@@ -599,14 +601,15 @@ groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey
 fromStringName, otherwiseIdName, foldrName, buildName, augmentName,
     mapName, appendName, assertName,
     breakpointName, breakpointCondName, breakpointAutoName,
-    opaqueTyConName :: Name
+    dollarName, opaqueTyConName :: Name
 fromStringName = methName dATA_STRING (fsLit "fromString") fromStringClassOpKey
 otherwiseIdName   = varQual gHC_BASE (fsLit "otherwise")  otherwiseIdKey
 foldrName	  = varQual gHC_BASE (fsLit "foldr")      foldrIdKey
 buildName	  = varQual gHC_BASE (fsLit "build")      buildIdKey
 augmentName	  = varQual gHC_BASE (fsLit "augment")    augmentIdKey
-mapName       = varQual gHC_BASE (fsLit "map")        mapIdKey
+mapName           = varQual gHC_BASE (fsLit "map")        mapIdKey
 appendName	  = varQual gHC_BASE (fsLit "++")         appendIdKey
+dollarName	  = varQual gHC_BASE (fsLit "$")          dollarIdKey
 assertName        = varQual gHC_BASE (fsLit "assert")     assertIdKey
 breakpointName    = varQual gHC_BASE (fsLit "breakpoint") breakpointIdKey
 breakpointCondName= varQual gHC_BASE (fsLit "breakpointCond") breakpointCondIdKey
@@ -1199,9 +1202,10 @@ breakpointAutoJumpIdKey       = mkPreludeMiscIdUnique 67
 inlineIdKey :: Unique
 inlineIdKey		      = mkPreludeMiscIdUnique 68
 
-mapIdKey, groupWithIdKey :: Unique
-mapIdKey		      = mkPreludeMiscIdUnique 69
+mapIdKey, groupWithIdKey, dollarIdKey :: Unique
+mapIdKey	      = mkPreludeMiscIdUnique 69
 groupWithIdKey        = mkPreludeMiscIdUnique 70
+dollarIdKey           = mkPreludeMiscIdUnique 71
 
 -- Parallel array functions
 singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey,
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 4ca4462..c148753 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -15,32 +15,35 @@ ToDo:
 
 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
 
-module PrelRules ( primOpRules, builtinRules ) where
+module PrelRules ( 
+    primOpRules, builtinRules,
+
+    -- Error Ids defined here because may be called here
+    mkRuntimeErrorApp, mkImpossibleExpr, 
+    rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID, rUNTIME_ERROR_ID,
+    nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,
+    pAT_ERROR_ID, eRROR_ID, rEC_SEL_ERROR_ID,
+ ) where
 
 #include "HsVersions.h"
 
 import CoreSyn
 import MkCore		( mkWildCase )
-import Id		( realIdUnfolding )
-import Literal		( Literal(..), mkMachInt, mkMachWord
-			, literalType
-			, word2IntLit, int2WordLit
-			, narrow8IntLit, narrow16IntLit, narrow32IntLit
-			, narrow8WordLit, narrow16WordLit, narrow32WordLit
-			, char2IntLit, int2CharLit
-			, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
-			, float2DoubleLit, double2FloatLit, litFitsInChar
-			)
+import Id
+import IdInfo
+import Demand
+import Literal
 import PrimOp		( PrimOp(..), tagToEnumKey )
-import TysWiredIn	( boolTy, trueDataConId, falseDataConId )
+import TysWiredIn
+import TysPrim
 import TyCon		( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
 import DataCon		( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
 import CoreUtils	( cheapEqExpr )
 import CoreUnfold	( exprIsConApp_maybe )
-import Type		( tyConAppTyCon, coreEqType )
+import TcType		( mkSigmaTy )
+import Type
 import OccName		( occNameFS )
-import PrelNames	( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey,
-			  eqStringName, unpackCStringIdKey, inlineIdName )
+import PrelNames
 import Maybes		( orElse )
 import Name		( Name, nameOccName )
 import Outputable
@@ -437,13 +440,41 @@ mkDoubleVal d = Lit (convFloating (MachDouble d))
 %*									*
 %************************************************************************
 
+Note [tagToEnum#]
+~~~~~~~~~~~~~~~~~
+Nasty check to ensure that tagToEnum# is applied to a type that is an
+enumeration TyCon.  Unification may refine the type later, but this
+check won't see that, alas.  It's crude but it works.
+
+Here's are two cases that should fail
+ 	f :: forall a. a
+	f = tagToEnum# 0	-- Can't do tagToEnum# at a type variable
+
+	g :: Int
+	g = tagToEnum# 0	-- Int is not an enumeration
+
+We used to make this check in the type inference engine, but it's quite
+ugly to do so, because the delayed constraint solving means that we don't
+really know what's going on until the end. It's very much a corner case
+because we don't expect the user to call tagToEnum# at all; we merely
+generate calls in derived instances of Enum.  So we compromise: a
+rewrite rule rewrites a bad instance of tagToEnum# to an error call,
+and emits a warning.
+
 \begin{code}
 tagToEnumRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
+tagToEnumRule _ [Type ty, _]
+  | not (is_enum_ty ty)	  -- See Note [tagToEnum#]
+  = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
+    Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type")
+  where
+    is_enum_ty ty = case splitTyConApp_maybe ty of
+                       Just (tc, _) -> isEnumerationTyCon tc
+		       Nothing      -> False
+
 tagToEnumRule _ [Type ty, Lit (MachInt i)]
   = ASSERT( isEnumerationTyCon tycon ) 
     case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of
-
-
 	[]	  -> Nothing	-- Abstract type
 	(dc:rest) -> ASSERT( null rest )
 		     Just (Var (dataConWorkId dc))
@@ -455,6 +486,7 @@ tagToEnumRule _ [Type ty, Lit (MachInt i)]
 tagToEnumRule _ _ = Nothing
 \end{code}
 
+
 For dataToTag#, we can reduce if either 
 	
 	(a) the argument is a constructor
@@ -523,7 +555,8 @@ builtinRules
 
 ---------------------------------------------------
 -- The rule is this:
--- 	unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n
+-- 	unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  
+--      =  unpackFoldrCString# "foobaz" c n
 
 match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
 match_append_lit _ [Type ty1,
@@ -580,3 +613,117 @@ match_inline _ (Type _ : e : _)
 
 match_inline _ _ = Nothing
 \end{code}
+
+%************************************************************************
+%*                                                                      *
+\subsection[PrelVals-error-related]{@error@ and friends; @trace@}
+%*                                                                      *
+%************************************************************************
+b
+GHC randomly injects these into the code.
+
+@patError@ is just a version of @error@ for pattern-matching
+failures.  It knows various ``codes'' which expand to longer
+strings---this saves space!
+
+@absentErr@ is a thing we put in for ``absent'' arguments.  They jolly
+well shouldn't be yanked on, but if one is, then you will get a
+friendly message from @absentErr@ (rather than a totally random
+crash).
+
+@parError@ is a special version of @error@ which the compiler does
+not know to be a bottoming Id.  It is used in the @_par_@ and @_seq_@
+templates, but we don't ever expect to generate code for it.
+
+\begin{code}
+mkRuntimeErrorApp 
+        :: Id           -- Should be of type (forall a. Addr# -> a)
+                        --      where Addr# points to a UTF8 encoded string
+        -> Type         -- The type to instantiate 'a'
+        -> String       -- The string to print
+        -> CoreExpr
+
+mkRuntimeErrorApp err_id res_ty err_msg 
+  = mkApps (Var err_id) [Type res_ty, err_string]
+  where
+    err_string = Lit (mkMachString err_msg)
+
+mkImpossibleExpr :: Type -> CoreExpr
+mkImpossibleExpr res_ty
+  = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"
+
+errorName, recSelErrorName, runtimeErrorName :: Name
+irrefutPatErrorName, recConErrorName, patErrorName :: Name
+nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name
+errorName                = mkWiredInIdName gHC_ERR (fsLit "error")            errorIdKey eRROR_ID
+recSelErrorName          = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recSelError")     recSelErrorIdKey rEC_SEL_ERROR_ID
+runtimeErrorName         = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "runtimeError")    runtimeErrorIdKey rUNTIME_ERROR_ID
+irrefutPatErrorName      = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID
+recConErrorName          = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "recConError")     recConErrorIdKey rEC_CON_ERROR_ID
+patErrorName             = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "patError")         patErrorIdKey pAT_ERROR_ID
+noMethodBindingErrorName = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "noMethodBindingError")
+                                           noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID
+nonExhaustiveGuardsErrorName 
+  = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit "nonExhaustiveGuardsError") 
+                    nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID
+
+rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id
+pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id
+rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName
+rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName
+iRREFUT_PAT_ERROR_ID            = mkRuntimeErrorId irrefutPatErrorName
+rEC_CON_ERROR_ID                = mkRuntimeErrorId recConErrorName
+pAT_ERROR_ID                    = mkRuntimeErrorId patErrorName
+nO_METHOD_BINDING_ERROR_ID      = mkRuntimeErrorId noMethodBindingErrorName
+nON_EXHAUSTIVE_GUARDS_ERROR_ID  = mkRuntimeErrorId nonExhaustiveGuardsErrorName
+
+-- The runtime error Ids take a UTF8-encoded string as argument
+
+mkRuntimeErrorId :: Name -> Id
+mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy
+
+runtimeErrorTy :: Type
+runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy)
+\end{code}
+
+\begin{code}
+eRROR_ID :: Id
+eRROR_ID = pc_bottoming_Id errorName errorTy
+
+errorTy  :: Type
+errorTy  = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy)
+    -- Notice the openAlphaTyVar.  It says that "error" can be applied
+    -- to unboxed as well as boxed types.  This is OK because it never
+    -- returns, so the return type is irrelevant.
+\end{code}
+
+
+%************************************************************************
+%*                                                                      *
+\subsection{Utilities}
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+pc_bottoming_Id :: Name -> Type -> Id
+-- Function of arity 1, which diverges after being given one argument
+pc_bottoming_Id name ty
+ = mkVanillaGlobalWithInfo name ty bottoming_info
+ where
+    bottoming_info = vanillaIdInfo `setStrictnessInfo` Just strict_sig
+				   `setArityInfo`         1
+			-- Make arity and strictness agree
+
+        -- Do *not* mark them as NoCafRefs, because they can indeed have
+        -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,
+        -- which has some CAFs
+        -- In due course we may arrange that these error-y things are
+        -- regarded by the GC as permanently live, in which case we
+        -- can give them NoCaf info.  As it is, any function that calls
+        -- any pc_bottoming_Id will itself have CafRefs, which bloats
+        -- SRTs.
+
+    strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
+        -- These "bottom" out, no matter what their arguments
+\end{code}
+
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 9efe64e..fd5695b 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -222,7 +222,7 @@ rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
 rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars)
 rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
     (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
-    return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s)
+    return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s)
 
 rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)
 rnIPBind (IPBind n expr) = do
@@ -419,41 +419,19 @@ rnBindLHS :: NameMaker
           -- (i.e., any free variables of the pattern)
           -> RnM (LHsBindLR Name RdrName)
 
-rnBindLHS name_maker _ (L loc (PatBind { pat_lhs = pat, 
-                                         pat_rhs = grhss, 
-                                         pat_rhs_ty=pat_rhs_ty
-                                       })) 
+rnBindLHS name_maker _ (L loc bind@(PatBind { pat_lhs = pat }))
   = setSrcSpan loc $ do
       -- we don't actually use the FV processing of rnPatsAndThen here
       (pat',pat'_fvs) <- rnBindPat name_maker pat
-      return (L loc (PatBind { pat_lhs = pat', 
-                               pat_rhs = grhss, 
-                               -- we temporarily store the pat's FVs here;
-                               -- gets updated to the FVs of the whole bind
-                               -- when doing the RHS below
-                               bind_fvs = pat'_fvs,
-                               -- these will get ignored in the next pass,
-                               -- when we rename the RHS
-			       pat_rhs_ty = pat_rhs_ty }))
-
-rnBindLHS name_maker _ (L loc (FunBind { fun_id = name@(L nameLoc _), 
-                                         fun_infix = inf, 
-                                         fun_matches = matches,
-                                         fun_co_fn = fun_co_fn, 
-                                         fun_tick = fun_tick
-                                       }))
+      return (L loc (bind { pat_lhs = pat', bind_fvs = pat'_fvs }))
+                -- We temporarily store the pat's FVs in bind_fvs;
+                -- gets updated to the FVs of the whole bind
+                -- when doing the RHS below
+                            
+rnBindLHS name_maker _ (L loc bind@(FunBind { fun_id = name@(L nameLoc _) }))
   = setSrcSpan loc $ 
     do { newname <- applyNameMaker name_maker name
-       ; return (L loc (FunBind { fun_id = L nameLoc newname, 
-                             	  fun_infix = inf, 
-                             	  fun_matches = matches,
-                             	  -- we temporatily store the LHS's FVs (empty in this case) here
-                             	  -- gets updated when doing the RHS below
-                             	  bind_fvs = emptyFVs,
-                             	  -- everything else will get ignored in the next pass
-                             	  fun_co_fn = fun_co_fn, 
-                             	  fun_tick = fun_tick
-                             	  })) }
+       ; return (L loc (bind { fun_id = L nameLoc newname })) } 
 
 rnBindLHS _ _ b = pprPanic "rnBindLHS" (ppr b)
 
@@ -462,13 +440,13 @@ rnBind :: (Name -> [Name])		-- Signature tyvar function
        -> (FreeVars -> FreeVars)	-- Trimming function for rhs free vars
        -> LHsBindLR Name RdrName
        -> RnM (LHsBind Name, [Name], Uses)
-rnBind _ trim (L loc (PatBind { pat_lhs = pat,
-                                pat_rhs = grhss, 
-                                -- pat fvs were stored here while
-                                -- after processing the LHS          
-                                bind_fvs = pat_fvs }))
+rnBind _ trim (L loc bind@(PatBind { pat_lhs = pat
+                                   , pat_rhs = grhss 
+                                      -- pat fvs were stored in bind_fvs
+                                      -- after processing the LHS          
+                                   , bind_fvs = pat_fvs }))
   = setSrcSpan loc $ 
-    do	{let bndrs = collectPatBinders pat
+    do	{ let bndrs = collectPatBinders pat
 
 	; (grhss', fvs) <- rnGRHSs PatBindRhs grhss
 		-- No scoped type variables for pattern bindings
@@ -476,20 +454,14 @@ rnBind _ trim (L loc (PatBind { pat_lhs = pat,
               fvs'    = trim all_fvs
 
 	; fvs' `seq` -- See Note [Free-variable space leak]
-          return (L loc (PatBind { pat_lhs    = pat,
-                                   pat_rhs    = grhss', 
-				   pat_rhs_ty = placeHolderType, 
-                                   bind_fvs   = fvs' }),
+          return (L loc (bind { pat_rhs  = grhss' 
+			      , bind_fvs = fvs' }),
 		  bndrs, all_fvs) }
 
-rnBind sig_fn 
-       trim 
-       (L loc (FunBind { fun_id = name, 
-                         fun_infix = is_infix, 
-                         fun_matches = matches,
-                         -- no pattern FVs
-                         bind_fvs = _
-                       })) 
+rnBind sig_fn trim 
+       (L loc bind@(FunBind { fun_id = name 
+                            , fun_infix = is_infix 
+                            , fun_matches = matches })) 
        -- invariant: no free vars here when it's a FunBind
   = setSrcSpan loc $ 
     do	{ let plain_name = unLoc name
@@ -503,12 +475,8 @@ rnBind sig_fn
 
 	; fvs' `seq` -- See Note [Free-variable space leak]
 
-          return (L loc (FunBind { fun_id = name,
-                               	   fun_infix = is_infix, 
-                               	   fun_matches = matches',
-			       	   bind_fvs = fvs',
-                               	   fun_co_fn = idHsWrapper, 
-                               	   fun_tick = Nothing }), 
+          return (L loc (bind { fun_matches = matches'
+			      , bind_fvs   = fvs' }), 
 		  [plain_name], fvs)
       }
 
@@ -619,8 +587,9 @@ rnMethodBind :: Name
 	      -> [Name]
 	      -> LHsBindLR RdrName RdrName
 	      -> RnM (Bag (LHsBindLR Name Name), FreeVars)
-rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = is_infix, 
-					             fun_matches = MatchGroup matches _ }))
+rnMethodBind cls sig_fn gen_tyvars 
+             (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix 
+				  , fun_matches = MatchGroup matches _ }))
   = setSrcSpan loc $ do
     sel_name <- wrapLocM (lookupInstDeclBndr cls) name
     let plain_name = unLoc sel_name
@@ -631,11 +600,9 @@ rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix =
     let new_group = MatchGroup new_matches placeHolderType
 
     when is_infix $ checkPrecMatch plain_name new_group
-    return (unitBag (L loc (FunBind {
-                                fun_id = sel_name, fun_infix = is_infix,
-                                fun_matches = new_group,
-                                bind_fvs = fvs, fun_co_fn = idHsWrapper,
-                                fun_tick = Nothing })),
+    return (unitBag (L loc (bind { fun_id      = sel_name 
+                                 , fun_matches = new_group
+                                 , bind_fvs    = fvs })),
              fvs `addOneFV` plain_name)
         -- The 'fvs' field isn't used for method binds
   where
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 2f62681..4cba23b 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -20,7 +20,7 @@ import RnEnv
 import RnHsDoc          ( rnHsDoc )
 import IfaceEnv		( ifaceExportNames )
 import LoadIface	( loadSrcInterface, loadSysInterface )
-import TcRnMonad hiding (LIE)
+import TcRnMonad
 
 import HeaderInfo       ( mkPrelImports )
 import PrelNames
@@ -600,7 +600,8 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails
 	-- different parents).  See the discussion at occ_env.
     lookup_ie :: Bool -> IE RdrName -> MaybeErr Message [(IE Name,AvailInfo)]
     lookup_ie opt_typeFamilies ie 
-      = let bad_ie = Failed (badImportItemErr iface decl_spec ie)
+      = let bad_ie :: MaybeErr Message a
+            bad_ie = Failed (badImportItemErr iface decl_spec ie)
 
             lookup_name rdr 
 	      | isQual rdr = Failed (qualImportItemErr rdr)
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index e362a12..9e16379 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -209,7 +209,7 @@ rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
 
    traceRn (text "finish rnSrc" <+> ppr rn_group) ;
    traceRn (text "finish Dus" <+> ppr src_dus ) ;
-   return (final_tcg_env , rn_group)
+   return (final_tcg_env, rn_group)
                     }}}}
 
 -- some utils because we do this a bunch above
diff --git a/compiler/simplCore/FloatIn.lhs b/compiler/simplCore/FloatIn.lhs
index cf53e91..b9f44c9 100644
--- a/compiler/simplCore/FloatIn.lhs
+++ b/compiler/simplCore/FloatIn.lhs
@@ -198,7 +198,7 @@ fiExpr to_drop lam@(_, AnnLam _ _)
 
     go seen_one_shot_id [] = seen_one_shot_id
     go seen_one_shot_id (b:bs)
-      | isTyVar       b = go seen_one_shot_id bs
+      | isTyCoVar       b = go seen_one_shot_id bs
       | isOneShotBndr b = go True bs
       | otherwise       = False	 -- Give up at a non-one-shot Id
 \end{code}
diff --git a/compiler/simplCore/FloatOut.lhs b/compiler/simplCore/FloatOut.lhs
index 579565f..fba88e7 100644
--- a/compiler/simplCore/FloatOut.lhs
+++ b/compiler/simplCore/FloatOut.lhs
@@ -242,7 +242,7 @@ floatExpr _ lam@(Lam _ _)
 	-- going to escape a value lambda.
 	-- In particular, for one-shot lambdas we don't float things
 	-- out; we get no saving by so doing.
-	partition_fn | all isTyVar bndrs = partitionByLevel
+	partition_fn | all isTyCoVar bndrs = partitionByLevel
 		     | otherwise	 = partitionByMajorLevel
     in
     case (floatExpr (last lvls) body) of { (fs, floats, body') ->
diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs
index 22e042a..a37b5f1 100644
--- a/compiler/simplCore/OccurAnal.lhs
+++ b/compiler/simplCore/OccurAnal.lhs
@@ -28,6 +28,7 @@ import BasicTypes
 
 import VarSet
 import VarEnv
+import Var		( Var, varUnique )
 
 import Maybes           ( orElse )
 import Digraph          ( SCC(..), stronglyConnCompFromEdgedVerticesR )
@@ -91,7 +92,7 @@ occAnalBind :: OccEnv 		-- The incoming OccEnv
                 [CoreBind])
 
 occAnalBind env _ (NonRec binder rhs) body_usage
-  | isTyVar binder			-- A type let; we don't gather usage info
+  | isTyCoVar binder			-- A type let; we don't gather usage info
   = (body_usage, [NonRec binder rhs])
 
   | not (binder `usedIn` body_usage)    -- It's not mentioned
@@ -314,12 +315,13 @@ occAnalBind _ env (Rec pairs) body_usage
     rec_edges = {-# SCC "occAnalBind.assoc" #-}  map make_node pairs
     
     make_node (bndr, rhs)
-	= (ND bndr rhs' all_rhs_usage rhs_fvs, idUnique bndr, out_edges)
+	= (ND bndr rhs' all_rhs_usage rhs_fvs, varUnique bndr, out_edges)
 	where
 	  (rhs_usage, rhs') = occAnalRhs env bndr rhs
-	  all_rhs_usage = addRuleUsage rhs_usage bndr    -- Note [Rules are extra RHSs]
-	  rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
-	  out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
+	  all_rhs_usage = addIdOccs rhs_usage rule_vars -- Note [Rules are extra RHSs]
+	  rhs_fvs   = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
+	  out_edges = keysUFM (rhs_fvs `unionVarSet` rule_vars)
+          rule_vars = idRuleVars bndr      -- See Note [Rule dependency info]
         -- (a -> b) means a mentions b
         -- Given the usage details (a UFM that gives occ info for each free var of
         -- the RHS) we can get the list of free vars -- or rather their Int keys --
@@ -400,6 +402,7 @@ occAnalRec (CyclicSCC nodes) (body_usage, binds)
     no_rules      = null init_rule_fvs
     init_rule_fvs = [(b, rule_fvs)
                     | b <- bndrs
+		    , isId b
                     , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set
                     , not (isEmptyVarSet rule_fvs)]
 
@@ -529,6 +532,8 @@ reOrderCycle depth (bind : binds) pairs
 
     score :: Node Details -> Int        -- Higher score => less likely to be picked as loop breaker
     score (ND bndr rhs _ _, _, _)
+        | not (isId bndr) = 100	    -- A type or cercion varialbe is never a loop breaker
+
         | isDFunId bndr = 9   -- Never choose a DFun as a loop breaker
 	   	     	      -- Note [DFuns should not be loop breakers]
 
@@ -582,7 +587,8 @@ reOrderCycle depth (bind : binds) pairs
 
 makeLoopBreaker :: Bool -> Id -> Id
 -- Set the loop-breaker flag: see Note [Weak loop breakers]
-makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
+makeLoopBreaker weak bndr 
+  = ASSERT2( isId bndr, ppr bndr ) setIdOccInfo bndr (IAmALoopBreaker weak)
 \end{code}
 
 Note [Complexity of loop breaking]
@@ -730,7 +736,8 @@ occAnalRhs :: OccEnv
 	      -- Returned usage details includes any INLINE rhs
 
 occAnalRhs env id rhs
-  = (addIdOccs rhs_usage (idUnfoldingVars id), rhs')
+  | isId id   = (addIdOccs rhs_usage (idUnfoldingVars id), rhs')
+  | otherwise = (rhs_usage, rhs')
     	-- Include occurrences for the "extra RHS" from a CoreUnfolding
   where
     (rhs_usage, rhs') = occAnal ctxt rhs
@@ -759,9 +766,11 @@ occAnalRhs env id rhs
 
 
 \begin{code}
-addRuleUsage :: UsageDetails -> Id -> UsageDetails
+addRuleUsage :: UsageDetails -> Var -> UsageDetails
 -- Add the usage from RULES in Id to the usage
-addRuleUsage usage id = addIdOccs usage (idRuleVars id)
+addRuleUsage usage var 
+  | isId var  = addIdOccs usage (idRuleVars var)
+  | otherwise = usage
         -- idRuleVars here: see Note [Rule dependency info]
 
 addIdOccs :: UsageDetails -> VarSet -> UsageDetails
@@ -841,7 +850,7 @@ occAnal env app@(App _ _)
 --   (a) occurrences inside type lambdas only not marked as InsideLam
 --   (b) type variables not in environment
 
-occAnal env (Lam x body) | isTyVar x
+occAnal env (Lam x body) | isTyCoVar x
   = case occAnal env body of { (body_usage, body') ->
     (body_usage, Lam x body')
     }
@@ -1440,8 +1449,8 @@ mkAltEnv env scrut cb
   where
     pe  = occ_proxy env
     pe' = case scrut of
-             Var v           -> extendProxyEnv pe v IdCo     cb
-             Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb
+             Var v           -> extendProxyEnv pe v (IdCo (idType v)) cb
+             Cast (Var v) co -> extendProxyEnv pe v (ACo co)          cb
 	     _other          -> trimProxyEnv pe [cb]
 
 -----------
@@ -1467,7 +1476,7 @@ trimProxyEnv (PE pe fvs) bndrs
                              
 -----------
 freeVarsCoI :: CoercionI -> VarSet
-freeVarsCoI IdCo     = emptyVarSet
+freeVarsCoI (IdCo t) = tyVarsOfType t
 freeVarsCoI (ACo co) = tyVarsOfType co
 \end{code}
 
@@ -1500,9 +1509,8 @@ addOneOcc usage id info
 emptyDetails :: UsageDetails
 emptyDetails = (emptyVarEnv :: UsageDetails)
 
-localUsedIn, usedIn :: Id -> UsageDetails -> Bool
-v `localUsedIn` details = v `elemVarEnv` details
-v `usedIn`      details =  isExportedId v || v `localUsedIn` details
+usedIn :: Id -> UsageDetails -> Bool
+v `usedIn` details = isExportedId v || v `elemVarEnv` details
 
 type IdWithOccInfo = Id
 
@@ -1536,7 +1544,7 @@ tagBinder usage binder
 
 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
 setBinderOcc usage bndr
-  | isTyVar bndr      = bndr
+  | isTyCoVar bndr    = bndr
   | isExportedId bndr = case idOccInfo bndr of
                           NoOccInfo -> bndr
                           _         -> setIdOccInfo bndr NoOccInfo
diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index 8c99fcb..ef0c7f2 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -535,7 +535,7 @@ lvlBind :: TopLevelFlag		-- Used solely to decide whether to clone
 	-> LvlM (LevelledBind, LevelEnv)
 
 lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_))
-  |  isTyVar bndr 		-- Don't do anything for TyVar binders
+  |  isTyCoVar bndr 		-- Don't do anything for TyVar binders
 				--   (simplifier gets rid of them pronto)
   = do rhs' <- lvlExpr ctxt_lvl env rhs
        return (NonRec (TB bndr ctxt_lvl) rhs', env)
@@ -845,7 +845,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs
 		   (False, True) -> False
 		   _    	 -> v1 <= v2	-- Same family
 
-    is_tv v = isTyVar v && not (isCoVar v)
+    is_tv v = isTyCoVar v && not (isCoVar v)
 
     uniq :: [Var] -> [Var]
 	-- Remove adjacent duplicates; the sort will have brought them together
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 2a41a0e..316382b 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -41,7 +41,6 @@ import FamInstEnv
 import Id
 import DataCon
 import TyCon		( tyConDataCons )
-import Class		( classSelIds )
 import BasicTypes       ( CompilerPhase, isActive, isDefaultInlinePragma )
 import VarSet
 import VarEnv
@@ -71,64 +70,31 @@ import Maybes
 %************************************************************************
 
 \begin{code}
-core2core :: HscEnv
-	  -> ModGuts
-	  -> IO ModGuts
+core2core :: HscEnv -> ModGuts -> IO ModGuts
+core2core hsc_env guts 
+  = do { us <- mkSplitUniqSupply 's'
+       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ 
+                           doCorePasses (getCoreToDo dflags) guts
 
-core2core hsc_env guts = do
-    let dflags = hsc_dflags hsc_env
+       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
+             "Grand total simplifier statistics"
+             (pprSimplCount stats)
 
-    us <- mkSplitUniqSupply 's'
-    let (cp_us, ru_us) = splitUniqSupply us
-
-    -- COMPUTE THE RULE BASE TO USE
-    -- See Note [Overall plumbing for rules] in Rules.lhs
-    (hpt_rule_base, guts1) <- prepareRules hsc_env guts ru_us
-
-    -- Get the module out of the current HscEnv so we can retrieve it from the monad.
+       ; return guts2 }
+  where
+    dflags         = hsc_dflags hsc_env
+    home_pkg_rules = hptRules hsc_env (dep_mods (mg_deps guts))
+    hpt_rule_base  = mkRuleBase home_pkg_rules
+    mod            = mg_module guts
+    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
     -- This is very convienent for the users of the monad (e.g. plugins do not have to
     -- consume the ModGuts to find the module) but somewhat ugly because mg_module may
     -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
     -- would mean our cached value would go out of date.
-    let mod = mg_module guts
-    (guts2, stats) <- runCoreM hsc_env hpt_rule_base cp_us mod $ do
-        -- FIND BUILT-IN PASSES
-        let builtin_core_todos = getCoreToDo dflags
-
-        -- DO THE BUSINESS
-        doCorePasses builtin_core_todos guts1
-
-    Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
-        "Grand total simplifier statistics"
-        (pprSimplCount stats)
-
-    return guts2
 
 
 type CorePass = CoreToDo
 
-simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
-	     -> CoreExpr
-	     -> IO CoreExpr
--- simplifyExpr is called by the driver to simplify an
--- expression typed in at the interactive prompt
---
--- Also used by Template Haskell
-simplifyExpr dflags expr
-  = do	{
-	; Err.showPass dflags "Simplify"
-
-	; us <-  mkSplitUniqSupply 's'
-
-	; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
-				 simplExprGently simplEnvForGHCi expr
-
-	; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
-			(pprCoreExpr expr')
-
-	; return expr'
-	}
-
 doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts
 doCorePasses passes guts 
   = foldM do_pass guts passes
@@ -250,125 +216,33 @@ observe do_pass = doPassM $ \binds -> do
 
 %************************************************************************
 %*									*
-	Dealing with rules
+	Gentle simplification
 %*									*
 %************************************************************************
 
--- prepareLocalRuleBase takes the CoreBinds and rules defined in this module.
--- It attaches those rules that are for local Ids to their binders, and
--- returns the remainder attached to Ids in an IdSet.  
-
 \begin{code}
-prepareRules :: HscEnv 
-	     -> ModGuts
-	     -> UniqSupply
-	     -> IO (RuleBase, 		-- Rule base for imported things, incl
-					-- (a) rules defined in this module (orphans)
-					-- (b) rules from other modules in home package
-					-- but not things from other packages
-
-		    ModGuts)		-- Modified fields are 
-					--	(a) Bindings have rules attached,
-					--		and INLINE rules simplified
-					-- 	(b) Rules are now just orphan rules
-
-prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
-	     guts@(ModGuts { mg_binds = binds, mg_deps = deps 
-	     		   , mg_rules = local_rules, mg_rdr_env = rdr_env })
-	     us 
-  = do	{ us <- mkSplitUniqSupply 'w'
-
-	; let 	-- Simplify the local rules; boringly, we need to make an in-scope set
-		-- from the local binders, to avoid warnings from Simplify.simplVar
-	      local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
-	      env	       = setInScopeSet simplEnvForRules local_ids 
-	      (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
-				 mapM (simplRule env) local_rules
-
-	; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
-
-	      home_pkg_rules = hptRules hsc_env (dep_mods deps)
-	      hpt_rule_base  = mkRuleBase home_pkg_rules
-	      binds_w_rules  = updateBinders rules_for_locals binds
-
-
-	; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
-		(withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
-		 vcat [text "Local rules for local Ids", pprRules simpl_rules,
-		       blankLine,
-		       text "Local rules for imported Ids", pprRuleBase hpt_rule_base])
-
-	; return (hpt_rule_base, guts { mg_binds = binds_w_rules, 
-					mg_rules = rules_for_imps })
-    }
+simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
+	     -> CoreExpr
+	     -> IO CoreExpr
+-- simplifyExpr is called by the driver to simplify an
+-- expression typed in at the interactive prompt
+--
+-- Also used by Template Haskell
+simplifyExpr dflags expr
+  = do	{
+	; Err.showPass dflags "Simplify"
 
--- Note [Attach rules to local ids]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Find the rules for locally-defined Ids; then we can attach them
--- to the binders in the top-level bindings
--- 
--- Reason
--- 	- It makes the rules easier to look up
---	- It means that transformation rules and specialisations for
---	  locally defined Ids are handled uniformly
---	- It keeps alive things that are referred to only from a rule
---	  (the occurrence analyser knows about rules attached to Ids)
---	- It makes sure that, when we apply a rule, the free vars
---	  of the RHS are more likely to be in scope
---	- The imported rules are carried in the in-scope set
---	  which is extended on each iteration by the new wave of
---	  local binders; any rules which aren't on the binding will
---	  thereby get dropped
-
-updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
-updateBinders rules_for_locals binds
-  = map update_bind binds
-  where
-    local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
-
-    update_bind (NonRec b r) = NonRec (add_rules b) r
-    update_bind (Rec prs)    = Rec (mapFst add_rules prs)
-
-	-- See Note [Attach rules to local ids]
-	-- NB: the binder might have some existing rules,
-	-- arising from specialisation pragmas
-    add_rules bndr
-	| Just rules <- lookupNameEnv local_rules (idName bndr)
-	= bndr `addIdSpecialisations` rules
-	| otherwise
-	= bndr
-\end{code}
+	; us <-  mkSplitUniqSupply 's'
 
-Note [Simplifying the left-hand side of a RULE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We must do some gentle simplification on the lhs (template) of each
-rule.  The case that forced me to add this was the fold/build rule,
-which without simplification looked like:
-	fold k z (build (/\a. g a))  ==>  ...
-This doesn't match unless you do eta reduction on the build argument.
-Similarly for a LHS like
-	augment g (build h) 
-we do not want to get
-	augment (\a. g a) (build h)
-otherwise we don't match when given an argument like
-	augment (\a. h a a) (build h)
-
-The simplifier does indeed do eta reduction (it's in
-Simplify.completeLam) but only if -O is on.
+	; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
+				 simplExprGently simplEnvForGHCi expr
 
-\begin{code}
-simplRule :: SimplEnv -> CoreRule -> SimplM CoreRule
-simplRule env rule@(BuiltinRule {})
-  = return rule
-simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
-  = do (env, bndrs') <- simplBinders env bndrs
-       args' <- mapM (simplExprGently env) args
-       rhs' <- simplExprGently env rhs
-       return (rule { ru_bndrs = bndrs', ru_args = args'
-                    , ru_rhs = occurAnalyseExpr rhs' })
-\end{code}
+	; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"
+			(pprCoreExpr expr')
+
+	; return expr'
+	}
 
-\begin{code}
 simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr
 -- Simplifies an expression 
 -- 	does occurrence analysis, then simplification
diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index b341b87..10b0003 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -528,7 +528,7 @@ simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)
 -- The substitution is extended only if the variable is cloned, because
 -- we *don't* need to use it to track occurrence info.
 simplBinder env bndr
-  | isTyVar bndr  = do	{ let (env', tv) = substTyVarBndr env bndr
+  | isTyCoVar bndr  = do	{ let (env', tv) = substTyVarBndr env bndr
 			; seqTyVar tv `seq` return (env', tv) }
   | otherwise     = do	{ let (env', id) = substIdBndr env bndr
 			; seqId id `seq` return (env', id) }
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 96857a3..d1c5cef 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -36,7 +36,7 @@ import qualified CoreSubst
 import PprCore
 import CoreFVs
 import CoreUtils
-import CoreArity	( etaExpand, exprEtaExpandArity )
+import CoreArity
 import CoreUnfold
 import Name
 import Id
@@ -1039,7 +1039,7 @@ mkLam _env bndrs body
 	   ; return etad_lam }
 
       | dopt Opt_DoLambdaEtaExpansion dflags,
-   	not (all isTyVar bndrs) -- Don't eta expand type abstractions
+   	not (all isTyCoVar bndrs) -- Don't eta expand type abstractions
       = do { let body' = tryEtaExpansion dflags body
  	   ; return (mkLams bndrs body') }
    
@@ -1085,7 +1085,7 @@ because the latter is not well-kinded.
 
 {-	Sept 01: I'm experimenting with getting the
 	full laziness pass to float out past big lambdsa
- | all isTyVar bndrs,	-- Only for big lambdas
+ | all isTyCoVar bndrs,	-- Only for big lambdas
    contIsRhs cont	-- Only try the rhs type-lambda floating
 			-- if this is indeed a right-hand side; otherwise
 			-- we end up floating the thing out, only for float-in
@@ -1097,100 +1097,6 @@ because the latter is not well-kinded.
 
 %************************************************************************
 %*									*
-		Eta reduction
-%*									*
-%************************************************************************
-
-Note [Eta reduction conditions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We try for eta reduction here, but *only* if we get all the way to an
-trivial expression.  We don't want to remove extra lambdas unless we
-are going to avoid allocating this thing altogether.
-
-There are some particularly delicate points here:
-
-* Eta reduction is not valid in general:  
-	\x. bot  /=  bot
-  This matters, partly for old-fashioned correctness reasons but,
-  worse, getting it wrong can yield a seg fault. Consider
-	f = \x.f x
-	h y = case (case y of { True -> f `seq` True; False -> False }) of
-		True -> ...; False -> ...
-
-  If we (unsoundly) eta-reduce f to get f=f, the strictness analyser
-  says f=bottom, and replaces the (f `seq` True) with just
-  (f `cast` unsafe-co).  BUT, as thing stand, 'f' got arity 1, and it
-  *keeps* arity 1 (perhaps also wrongly).  So CorePrep eta-expands 
-  the definition again, so that it does not termninate after all.
-  Result: seg-fault because the boolean case actually gets a function value.
-  See Trac #1947.
-
-  So it's important to to the right thing.
-
-* Note [Arity care]: we need to be careful if we just look at f's
-  arity. Currently (Dec07), f's arity is visible in its own RHS (see
-  Note [Arity robustness] in SimplEnv) so we must *not* trust the
-  arity when checking that 'f' is a value.  Otherwise we will
-  eta-reduce
-      f = \x. f x
-  to
-      f = f
-  Which might change a terminiating program (think (f `seq` e)) to a 
-  non-terminating one.  So we check for being a loop breaker first.
-
-  However for GlobalIds we can look at the arity; and for primops we
-  must, since they have no unfolding.  
-
-* Regardless of whether 'f' is a value, we always want to 
-  reduce (/\a -> f a) to f
-  This came up in a RULE: foldr (build (/\a -> g a))
-  did not match 	  foldr (build (/\b -> ...something complex...))
-  The type checker can insert these eta-expanded versions,
-  with both type and dictionary lambdas; hence the slightly 
-  ad-hoc isDictId
-
-* Never *reduce* arity. For example
-      f = \xy. g x y
-  Then if h has arity 1 we don't want to eta-reduce because then
-  f's arity would decrease, and that is bad
-
-These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
-Alas.
-
-\begin{code}
-tryEtaReduce :: [OutBndr] -> OutExpr -> Maybe OutExpr
-tryEtaReduce bndrs body 
-  = go (reverse bndrs) body
-  where
-    incoming_arity = count isId bndrs
-
-    go (b : bs) (App fun arg) | ok_arg b arg = go bs fun	-- Loop round
-    go []       fun           | ok_fun fun   = Just fun		-- Success!
-    go _        _			     = Nothing		-- Failure!
-
-	-- Note [Eta reduction conditions]
-    ok_fun (App fun (Type ty)) 
-	| not (any (`elemVarSet` tyVarsOfType ty) bndrs)
-	=  ok_fun fun
-    ok_fun (Var fun_id)
-	=  not (fun_id `elem` bndrs)
-	&& (ok_fun_id fun_id || all ok_lam bndrs)
-    ok_fun _fun = False
-
-    ok_fun_id fun = fun_arity fun >= incoming_arity
-
-    fun_arity fun 	      -- See Note [Arity care]
-       | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0
-       | otherwise = idArity fun   	      
-
-    ok_lam v = isTyVar v || isDictId v
-
-    ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg
-\end{code}
-
-
-%************************************************************************
-%*									*
 		Eta expansion
 %*									*
 %************************************************************************
@@ -1337,7 +1243,7 @@ abstractFloats main_tvs body_env body
 	rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs
 	tvs_here | any isCoVar main_tvs = main_tvs	-- Note [Abstract over coercions]
 		 | otherwise 
-		 = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
+		 = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyCoVar rhs')
 	
 		-- Abstract only over the type variables free in the rhs
 		-- wrt which the new binding is abstracted.  But the naive
@@ -1529,16 +1435,17 @@ prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
 				-- 	case x of { DEFAULT -> e }
 				-- and we don't want to fill in a default for them!
   , Just all_cons <- tyConDataCons_maybe tycon
-  , not (null all_cons)		-- This is a tricky corner case.  If the data type has no constructors,
-				-- which GHC allows, then the case expression will have at most a default
-				-- alternative.  We don't want to eliminate that alternative, because the
-				-- invariant is that there's always one alternative.  It's more convenient
-				-- to leave	
-				--	case x of { DEFAULT -> e }     
-				-- as it is, rather than transform it to
-				--	error "case cant match"
-				-- which would be quite legitmate.  But it's a really obscure corner, and
-				-- not worth wasting code on.
+  , not (null all_cons)	
+	-- This is a tricky corner case.  If the data type has no constructors,
+	-- which GHC allows, then the case expression will have at most a default
+	-- alternative.  We don't want to eliminate that alternative, because the
+	-- invariant is that there's always one alternative.  It's more convenient
+	-- to leave	
+	--	case x of { DEFAULT -> e }     
+	-- as it is, rather than transform it to
+	--	error "case cant match"
+	-- which would be quite legitmate.  But it's a really obscure corner, and
+	-- not worth wasting code on.
   , let imposs_data_cons = [con | DataAlt con <- imposs_cons]	-- We now know it's a data type 
 	impossible con   = con `elem` imposs_data_cons || dataConCannotMatch inst_tys con
   = case filterOut impossible all_cons of
@@ -1554,9 +1461,12 @@ prepareDefault case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rhs)
 
 	_ -> return [(DEFAULT, [], deflt_rhs)]
 
-  | debugIsOn, isAlgTyCon tycon, not (isOpenTyCon tycon), null (tyConDataCons tycon)
+  | debugIsOn, isAlgTyCon tycon
+  , null (tyConDataCons tycon)
+  , not (isFamilyTyCon tycon || isAbstractTyCon tycon)
 	-- Check for no data constructors
-        -- This can legitimately happen for type families, so don't report that
+        -- This can legitimately happen for abstract types and type families,
+        -- so don't report that
   = pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon)
         $ return [(DEFAULT, [], deflt_rhs)]
 
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index ec7e190..fd8981a 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -877,7 +877,7 @@ simplExprF' env expr@(Lam _ _) cont
     n_params = length bndrs
     (bndrs, body) = collectBinders expr
     zap | n_args >= n_params = \b -> b
-        | otherwise          = \b -> if isTyVar b then b
+        | otherwise          = \b -> if isTyCoVar b then b
                                      else zapLamIdInfo b
         -- NB: we count all the args incl type args
         -- so we must count all the binders (incl type lambdas)
@@ -1081,7 +1081,7 @@ simplNonRecE :: SimplEnv
 	-- First deal with type applications and type lets
 	--   (/\a. e) (Type ty)   and   (let a = Type ty in e)
 simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont
-  = ASSERT( isTyVar bndr )
+  = ASSERT( isTyCoVar bndr )
     do	{ ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg
 	; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont }
 
@@ -1095,7 +1095,7 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont
                      (StrictBind bndr bndrs body env cont) }
 
   | otherwise
-  = ASSERT( not (isTyVar bndr) )
+  = ASSERT( not (isTyCoVar bndr) )
     do  { (env1, bndr1) <- simplNonRecBndr env bndr
         ; let (env2, bndr2) = addBndrRules env1 bndr bndr1
         ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
@@ -1137,7 +1137,7 @@ simplNote env (CoreNote s) e cont
 simplVar :: SimplEnv -> InVar -> SimplM OutExpr
 -- Look up an InVar in the environment
 simplVar env var
-  | isTyVar var 
+  | isTyCoVar var 
   = return (Type (substTyVar env var))
   | otherwise
   = case substId env var of
@@ -1768,7 +1768,7 @@ simplAlt env _ case_bndr' cont' (DataAlt con, vs, rhs)
         = go vs the_strs
         where
           go [] [] = []
-          go (v:vs') strs | isTyVar v = v : go vs' strs
+          go (v:vs') strs | isTyCoVar v = v : go vs' strs
           go (v:vs') (str:strs)
             | isMarkedStrict str = evald_v  : go vs' strs
             | otherwise          = zapped_v : go vs' strs
@@ -1843,7 +1843,7 @@ knownCon env scrut dc dc_ty_args dc_args bndr bs rhs cont
     bind_args env' [] _  = return env'
 
     bind_args env' (b:bs') (Type ty : args)
-      = ASSERT( isTyVar b )
+      = ASSERT( isTyCoVar b )
         bind_args (extendTvSubst env' b ty) bs' args
 
     bind_args env' (b:bs') (arg : args)
@@ -2030,7 +2030,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
 			  | otherwise		   = bndrs' ++ [case_bndr_w_unf]
 	      
               abstract_over bndr
-                  | isTyVar bndr = True -- Abstract over all type variables just in case
+                  | isTyCoVar bndr = True -- Abstract over all type variables just in case
                   | otherwise    = not (isDeadBinder bndr)
                         -- The deadness info on the new Ids is preserved by simplBinders
 
diff --git a/compiler/specialise/Rules.lhs b/compiler/specialise/Rules.lhs
index 1219d1c..87999a4 100644
--- a/compiler/specialise/Rules.lhs
+++ b/compiler/specialise/Rules.lhs
@@ -58,15 +58,15 @@ import Data.List
 
 Note [Overall plumbing for rules]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-* The ModGuts initially contains mg_rules :: [CoreRule] of rules
-  declared in this module. During the core-to-core pipeline,
-  locally-declared rules for locally-declared Ids are attached to the
-  IdInfo for that Id, so the mg_rules field of ModGuts now only
-  contains locally-declared rules for *imported* Ids.  TidyPgm restores
-  the original setup, so that the ModGuts again has *all* the
-  locally-declared rules.  See Note [Attach rules to local ids] in
-  SimplCore
+* After the desugarer:
+   - The ModGuts initially contains mg_rules :: [CoreRule] of
+     locally-declared rules for imported Ids.  
+   - Locally-declared rules for locally-declared Ids are attached to
+     the IdInfo for that Id.  See Note [Attach rules to local ids] in
+     DsBinds
+ 
+* TidyPgm strips off all the rules from local Ids and adds them to
+  mg_rules, so that the ModGuts has *all* the locally-declared rules.
 
 * The HomePackageTable contains a ModDetails for each home package
   module.  Each contains md_rules :: [CoreRule] of rules declared in
@@ -500,7 +500,7 @@ matchN id_unf in_scope tmpl_vars tmpl_es target_es
 
     lookup_tmpl :: TvSubstEnv -> IdSubstEnv -> Var -> CoreExpr
     lookup_tmpl tv_subst id_subst tmpl_var'
-	| isTyVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of
+	| isTyCoVar tmpl_var' = case lookupVarEnv tv_subst tmpl_var' of
 				Just ty 	-> Type ty
 				Nothing 	-> unbound tmpl_var'
 	| otherwise	    = case lookupVarEnv id_subst tmpl_var' of
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 84f8698..a9e9136 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -672,7 +672,7 @@ extendCaseBndrs env case_bndr con alt_bndrs
   	--	Var v  -> extendValEnv env1 v cval
 	--	_other -> env1
  where
-   zap v | isTyVar v = v		-- See NB2 above
+   zap v | isTyCoVar v = v		-- See NB2 above
          | otherwise = zapIdOccInfo v
    env1 = extendValEnv env case_bndr cval
    cval = case con of
@@ -936,7 +936,7 @@ scExpr' env (Case scrut b ty alts)
 	   ; return (usg', scrut_occ, (con, bs2, rhs')) }
 
 scExpr' env (Let (NonRec bndr rhs) body)
-  | isTyVar bndr	-- Type-lets may be created by doBeta
+  | isTyCoVar bndr	-- Type-lets may be created by doBeta
   = scExpr' (extendScSubst env bndr rhs) body
 
   | otherwise		   -- Note [Local let bindings]
@@ -1398,7 +1398,7 @@ callToPats env bndr_occs (con_env, args)
 		-- at the call site
 		-- See Note [Shadowing] at the top
 		
-	      (tvs, ids) = partition isTyVar qvars
+	      (tvs, ids) = partition isTyCoVar qvars
 	      qvars'     = tvs ++ ids
 		-- Put the type variables first; the type of a term
 		-- variable may mention a type variable
@@ -1572,7 +1572,7 @@ isValue env (Var v)
 	-- as well, for let-bound constructors!
 
 isValue env (Lam b e)
-  | isTyVar b = case isValue env e of
+  | isTyCoVar b = case isValue env e of
 		  Just _  -> Just LambdaVal
 		  Nothing -> Nothing
   | otherwise = Just LambdaVal
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index edda603..370393b 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -445,7 +445,7 @@ mkStgAltType bndr alts
    _is_poly_alt_tycon tc
 	=  isFunTyCon tc
         || isPrimTyCon tc   -- "Any" is lifted but primitive
-	|| isOpenTyCon tc   -- Type family; e.g. arising from strict
+	|| isFamilyTyCon tc   -- Type family; e.g. arising from strict
 			    -- function application where argument has a
 			    -- type-family type
 
@@ -1120,7 +1120,7 @@ myCollectArgs expr
     go (Cast e _)       as = go e as
     go (Note _ e)       as = go e as
     go (Lam b e)        as
-       | isTyVar b         = go e as	-- Note [Collect args]
+       | isTyCoVar b         = go e as	-- Note [Collect args]
     go _                _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
 \end{code}
 
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index 2a160cd..32986e5 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -186,7 +186,7 @@ dmdAnal sigs dmd (App fun arg)	-- Non-type arguments
     (res_ty `bothType` arg_ty, App fun' arg')
 
 dmdAnal sigs dmd (Lam var body)
-  | isTyVar var
+  | isTyCoVar var
   = let   
 	(body_ty, body') = dmdAnal sigs dmd body
     in
@@ -765,7 +765,7 @@ annotateBndr :: DmdType -> Var -> (DmdType, Var)
 -- The returned var is annotated with demand info
 -- No effect on the argument demands
 annotateBndr dmd_ty@(DmdType fv ds res) var
-  | isTyVar var = (dmd_ty, var)
+  | isTyCoVar var = (dmd_ty, var)
   | otherwise   = (DmdType fv' ds res, setIdDemandInfo var dmd)
   where
     (fv', dmd) = removeFV fv var res
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index 611c4d4..40a2a26 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -336,7 +336,7 @@ mkWWstr (arg : args) = do
 --	  brings into scope wrap_arg (via lets)
 mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)
 mkWWstr_one arg
-  | isTyVar arg
+  | isTyCoVar arg
   = return ([arg],  nop_fn, nop_fn)
 
   | otherwise
diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index b09f9a5..e2da795 100644
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -2,7 +2,7 @@ The @FamInst@ type: family instance heads
 
 \begin{code}
 module FamInst ( 
-        checkFamInstConsistency, tcExtendLocalFamInstEnv
+        checkFamInstConsistency, tcExtendLocalFamInstEnv, tcGetFamInstEnvs
     ) where
 
 import HscTypes
@@ -197,4 +197,17 @@ addFamInstLoc famInst thing_inside
   = setSrcSpan (mkSrcSpan loc loc) thing_inside
   where
     loc = getSrcLoc famInst
+\end{code} 
+
+\begin{code} 
+
+tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv)
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+tcGetFamInstEnvs 
+  = do { eps <- getEps; env <- getGblEnv
+       ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) 
+       }
+
+
 \end{code}
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index b237778..c1801d6 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -7,397 +7,191 @@ The @Inst@ type: dictionaries or method instances
 
 \begin{code}
 module Inst ( 
-	Inst,
+       deeplySkolemise, 
+       deeplyInstantiate, instCall, instStupidTheta,
+       emitWanted, emitWanteds,
+
+       newOverloadedLit, mkOverLit, 
+     
+       tcGetInstEnvs, getOverlapFlag, tcExtendLocalInstEnv,
+       instCallConstraints, newMethodFromName,
+       tcSyntaxName,
+
+       -- Simple functions over evidence variables
+       hasEqualities,
+       
+       tyVarsOfWanteds, tyVarsOfWanted, tyVarsOfWantedEvVar, tyVarsOfWantedEvVars, 
+       tyVarsOfEvVar, tyVarsOfEvVars, tyVarsOfImplication,
+       tidyWanteds, tidyWanted, tidyWantedEvVar, tidyWantedEvVars,
+       tidyEvVar, tidyImplication
 
-	pprInstances, pprDictsTheta, pprDictsInFull,	-- User error messages
-	showLIE, pprInst, pprInsts, pprInstInFull,	-- Debugging messages
-
-	tidyInsts, tidyMoreInsts,
-
-	newDictBndr, newDictBndrs, newDictBndrsO,
-	newDictOccs, newDictOcc,
-	instCall, instStupidTheta,
-	cloneDict, mkOverLit,
-	newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy, 
-	tcInstClassOp, 
-	tcSyntaxName, 
-
-	tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, tcTyVarsOfInst,
-	tcTyVarsOfInsts, ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst,
-	fdPredsOfInsts, growInstsTyVars, getDictClassTys, dictPred,
-
-	lookupSimpleInst, LookupInstResult(..), 
-	tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
-
-	isAbstractableInst, isEqInst,
-	isDict, isClassDict, isMethod, isImplicInst,
-	isIPDict, isInheritableInst, isMethodOrLit,
-	isTyVarDict, isMethodFor, 
-
-	zonkInst, zonkInsts,
-	instToId, instToVar, instType, instName, instToDictBind,
-	addInstToDictBind,
-
-	InstOrigin(..), InstLoc, pprInstLoc,
-
-	mkWantedCo, mkGivenCo, isWantedCo, eqInstCoType, mkIdEqInstCo, 
-        mkSymEqInstCo, mkLeftTransEqInstCo, mkRightTransEqInstCo, mkAppEqInstCo,
-        mkTyConEqInstCo, mkFunEqInstCo,
-        wantedEqInstIsUnsolved, eitherEqInst, mkEqInst, mkWantedEqInst,
-        wantedToLocalEqInst, finalizeEqInst, eqInstType, eqInstCoercion,
-        eqInstTys
     ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-}	TcExpr( tcPolyExpr )
-import {-# SOURCE #-}	TcUnify( boxyUnify {- , unifyType -} )
+import {-# SOURCE #-}	TcExpr( tcPolyExpr, tcSyntaxOp )
+import {-# SOURCE #-}	TcUnify( unifyType )
 
 import FastString
 import HsSyn
 import TcHsSyn
 import TcRnMonad
 import TcEnv
+import TcRnTypes
 import InstEnv
 import FunDeps
 import TcMType
 import TcType
-import MkCore ( mkBigCoreTupTy )
-import TyCon
-import Type
-import TypeRep
 import Class
 import Unify
-import Module
 import Coercion
 import HscTypes
-import CoreFVs
 import Id
 import Name
-import NameSet
-import Var      ( Var, TyVar )
-import qualified Var
+import Var      ( Var, TyVar, EvVar, varType, setVarType )
 import VarEnv
 import VarSet
 import PrelNames
-import BasicTypes
 import SrcLoc
 import DynFlags
 import Bag
 import Maybes
 import Util
-import Unique
 import Outputable
 import Data.List
-
-import Control.Monad
-\end{code}
-
-
-
-Selection
-~~~~~~~~~
-\begin{code}
-instName :: Inst -> Name
-instName (EqInst {tci_name = name}) = name
-instName inst = Var.varName (instToVar inst)
-
-instToId :: Inst -> TcId
-instToId inst = WARN( not (isId id), ppr inst ) 
-	      id 
-	      where
-		id = instToVar inst
-
-instToVar :: Inst -> Var
-instToVar (LitInst {tci_name = nm, tci_ty = ty})
-  = mkLocalId nm ty
-instToVar (Method {tci_id = id}) 
-  = id
-instToVar (Dict {tci_name = nm, tci_pred = pred})    
-  | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
-  | otherwise	  = mkLocalId nm (mkPredTy pred)
-instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
-		       tci_wanted = wanteds})
-  = mkLocalId nm (mkImplicTy tvs givens wanteds)
-instToVar inst@(EqInst {})
-  = eitherEqInst inst id assertCoVar
-  where
-    assertCoVar (TyVarTy cotv) = cotv
-    assertCoVar coty           = pprPanic "Inst.instToVar" (ppr coty)
-
-instType :: Inst -> Type
-instType (LitInst {tci_ty = ty})  = ty
-instType (Method {tci_id = id})   = idType id
-instType (Dict {tci_pred = pred}) = mkPredTy pred
-instType imp@(ImplicInst {})      = mkImplicTy (tci_tyvars imp) (tci_given imp)	
-					       (tci_wanted imp)
--- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
-instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
-
-mkImplicTy :: [TyVar] -> [Inst] -> [Inst] -> Type
-mkImplicTy tvs givens wanteds	-- The type of an implication constraint
-  = ASSERT( all isAbstractableInst givens )
-    -- pprTrace "mkImplicTy" (ppr givens) $
-    -- See [Equational Constraints in Implication Constraints]
-    let dict_wanteds = filter (not . isEqInst) wanteds
-    in 
-      mkForAllTys tvs $ 
-      mkPhiTy (map dictPred givens) $
-      mkBigCoreTupTy (map instType dict_wanteds)
-
-dictPred :: Inst -> TcPredType
-dictPred (Dict {tci_pred = pred}) = pred
-dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
-dictPred inst		          = pprPanic "dictPred" (ppr inst)
-
-getDictClassTys :: Inst -> (Class, [Type])
-getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
-getDictClassTys inst		         = pprPanic "getDictClassTys" (ppr inst)
-
---------------------------------
--- fdPredsOfInst is used to get predicates that contain functional 
--- dependencies *or* might do so.  The "might do" part is because
--- a constraint (C a b) might have a superclass with FDs
--- Leaving these in is really important for the call to fdPredsOfInsts
--- in TcSimplify.inferLoop, because the result is fed to 'grow',
--- which is supposed to be conservative
-fdPredsOfInst :: Inst -> [TcPredType]
-fdPredsOfInst (Dict {tci_pred = pred}) 	     = [pred]
-fdPredsOfInst (Method {tci_theta = theta})   = theta
-fdPredsOfInst (ImplicInst {tci_wanted = ws}) = fdPredsOfInsts ws
-   -- The ImplicInst case doesn't look right;
-   -- what if ws mentions skolem variables?
-fdPredsOfInst (LitInst {})		     = []
-fdPredsOfInst (EqInst {})		     = []
-
-fdPredsOfInsts :: [Inst] -> [PredType]
-fdPredsOfInsts insts = concatMap fdPredsOfInst insts
-
----------------------------------
-isInheritableInst :: Inst -> Bool
-isInheritableInst (Dict {tci_pred = pred})     = isInheritablePred pred
-isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
-isInheritableInst _                            = True
-
-
----------------------------------
--- Get the implicit parameters mentioned by these Insts
--- NB: the results of these functions are insensitive to zonking
-
-ipNamesOfInsts :: [Inst] -> [Name]
-ipNamesOfInst  :: Inst   -> [Name]
-ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
-
-ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
-ipNamesOfInst (Method {tci_theta = theta})   = [ipNameName n | IParam n _ <- theta]
-ipNamesOfInst _                              = []
-
----------------------------------
-
--- |All free type variables (not including the coercion variables of
--- equalities)
---
-tyVarsOfInst :: Inst -> TyVarSet
-tyVarsOfInst (LitInst {tci_ty = ty})  = tyVarsOfType  ty
-tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
-tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) 
-  = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
-    -- The id might have free type variables; in the case of
-    -- locally-overloaded class methods, for example
-tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, 
-                          tci_wanted = wanteds})
-  = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) 
-    `minusVarSet` mkVarSet tvs
-    `unionVarSet` unionVarSets (map varTypeTyVars tvs)
-		-- Remember the free tyvars of a coercion
-tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) 
-  = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
-
--- |All free meta type variables *including* the coercion variables of
--- equalities
---
-tcTyVarsOfInst :: Inst -> TyVarSet
-tcTyVarsOfInst (LitInst {tci_ty = ty})  = tcTyVarsOfType  ty
-tcTyVarsOfInst (Dict {tci_pred = pred}) = tcTyVarsOfPred pred
-tcTyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) 
-  = tcTyVarsOfTypes tys `unionVarSet` varTypeTcTyVars id
-    -- The id might have free type variables; in the case of
-    -- locally-overloaded class methods, for example
-tcTyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, 
-                            tci_wanted = wanteds})
-  = (tcTyVarsOfInsts givens `unionVarSet` tcTyVarsOfInsts wanteds) 
-    `minusVarSet` mkVarSet tvs
-    `unionVarSet` unionVarSets (map varTypeTcTyVars tvs)
-		-- Remember the free tyvars of a coercion
-tcTyVarsOfInst (EqInst {tci_co = co, tci_left = ty1, tci_right = ty2}) 
-  = either unitVarSet tcTyVarsOfType co `unionVarSet`   -- include covars
-    tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2
-
-tyVarsOfInsts :: [Inst] -> TyVarSet
-tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
-
-tcTyVarsOfInsts :: [Inst] -> TcTyVarSet
-tcTyVarsOfInsts insts = foldr (unionVarSet . tcTyVarsOfInst) emptyVarSet insts
-
-tyVarsOfLIE :: Bag Inst -> TyVarSet
-tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
-
-
---------------------------
-instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
-instToDictBind inst rhs 
-  = unitBag (L (instSpan inst) (VarBind { var_id = instToId inst
-					, var_rhs = rhs
-					, var_inline = False }))
-
-addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
-addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
 \end{code}
 
-Note [Growing the tau-tvs using constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-(growInstsTyVars insts tvs) is the result of extending the set 
-    of tyvars tvs using all conceivable links from pred
-
-E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}
-Then grow precs tvs = {a,b,c}
 
-All the type variables from an implicit parameter are added, whether or
-not they are mentioned in tvs; see Note [Implicit parameters and ambiguity] 
-in TcSimplify.
 
-See also Note [Ambiguity] in TcSimplify
+%************************************************************************
+%*									*
+		Emitting constraints
+%*									*
+%************************************************************************
 
 \begin{code}
-growInstsTyVars :: [Inst] -> TyVarSet -> TyVarSet
-growInstsTyVars insts tvs
-  | null insts = tvs
-  | otherwise  = fixVarSet mk_next tvs
-  where
-    mk_next tvs = foldr grow_inst_tvs tvs insts
-
-grow_inst_tvs :: Inst -> TyVarSet -> TyVarSet
-grow_inst_tvs (Dict {tci_pred = pred})     tvs = growPredTyVars pred tvs
-grow_inst_tvs (Method {tci_theta = theta}) tvs = foldr growPredTyVars tvs theta
-grow_inst_tvs (ImplicInst {tci_tyvars = tvs1, tci_wanted = ws}) tvs
-  = tvs `unionVarSet` (foldr grow_inst_tvs (tvs `delVarSetList` tvs1) ws
-    		          `delVarSetList` tvs1)
-grow_inst_tvs inst tvs   -- EqInst, LitInst
-  = growTyVars (tyVarsOfInst inst) tvs
+emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar]
+emitWanteds origin theta = mapM (emitWanted origin) theta
+
+emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
+emitWanted origin pred = do { loc <- getCtLoc origin
+                            ; ev  <- newWantedEvVar pred
+                            ; emitConstraint (WcEvVar (WantedEvVar ev loc))
+                            ; return ev }
+
+newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
+-- Used when Name is the wired-in name for a wired-in class method,
+-- so the caller knows its type for sure, which should be of form
+--    forall a. C a => <blah>
+-- newMethodFromName is supposed to instantiate just the outer 
+-- type variable and constraint
+
+newMethodFromName origin name inst_ty
+  = do { id <- tcLookupId name
+ 	      -- Use tcLookupId not tcLookupGlobalId; the method is almost
+	      -- always a class op, but with -XNoImplicitPrelude GHC is
+	      -- meant to find whatever thing is in scope, and that may
+	      -- be an ordinary function. 
+
+       ; let (tvs, theta, _caller_knows_this) = tcSplitSigmaTy (idType id)
+             (the_tv:rest) = tvs
+             subst = zipOpenTvSubst [the_tv] [inst_ty]
+
+       ; wrap <- ASSERT( null rest && isSingleton theta )
+                 instCall origin [inst_ty] (substTheta subst theta)
+       ; return (mkHsWrap wrap (HsVar id)) }
 \end{code}
 
 
 %************************************************************************
 %*									*
-		Predicates
+	Deep instantiation and skolemisation
 %*									*
 %************************************************************************
 
-\begin{code}
-
-isAbstractableInst :: Inst -> Bool
-isAbstractableInst inst = isDict inst || isEqInst inst
-
-isEqInst :: Inst -> Bool
-isEqInst (EqInst {}) = True
-isEqInst _           = False
+Note [Deep skolemisation]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+deeplySkolemise decomposes and skolemises a type, returning a type
+with all its arrows visible (ie not buried under foralls)
 
-isDict :: Inst -> Bool
-isDict (Dict {}) = True
-isDict _         = False
+Examples:
 
-isClassDict :: Inst -> Bool
-isClassDict (Dict {tci_pred = pred}) = isClassPred pred
-isClassDict _                        = False
+  deeplySkolemise (Int -> forall a. Ord a => blah)  
+    =  ( wp, [a], [d:Ord a], Int -> blah )
+    where wp = \x:Int. /\a. \(d:Ord a). <hole> x
 
-isTyVarDict :: Inst -> Bool
-isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
-isTyVarDict _                        = False
+  deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)  
+    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )
+    where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x
 
-isIPDict :: Inst -> Bool
-isIPDict (Dict {tci_pred = pred}) = isIPPred pred
-isIPDict _                        = False
+In general,
+  if      deeplySkolemise ty = (wrap, tvs, evs, rho)
+    and   e :: rho
+  then    wrap e :: ty
+    and   'wrap' binds tvs, evs
 
-isImplicInst :: Inst -> Bool
-isImplicInst (ImplicInst {}) = True
-isImplicInst _               = False
+ToDo: this eta-abstraction plays fast and loose with termination,
+      because it can introduce extra lambdas.  Maybe add a `seq` to
+      fix this
 
-isMethod :: Inst -> Bool
-isMethod (Method {}) = True
-isMethod _           = False
 
-isMethodFor :: TcIdSet -> Inst -> Bool
-isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
-isMethodFor _   _                       = False
+\begin{code}
+deeplySkolemise
+  :: SkolemInfo
+  -> TcSigmaType 
+  -> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType)
+
+deeplySkolemise skol_info ty
+  | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
+  = do { ids1 <- newSysLocalIds (fsLit "dsk") arg_tys
+       ; tvs1 <- mapM (tcInstSkolTyVar skol_info) tvs
+       ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs1)
+       ; ev_vars1 <- newEvVars (substTheta subst theta)
+       ; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise skol_info (substTy subst ty')
+       ; return ( mkWpLams ids1
+                   <.> mkWpTyLams tvs1
+                   <.> mkWpLams ev_vars1
+                   <.> wrap
+                   <.> mkWpEvVarApps ids1
+                , tvs1     ++ tvs2
+                , ev_vars1 ++ ev_vars2
+                , mkFunTys arg_tys rho ) }
 
-isMethodOrLit :: Inst -> Bool
-isMethodOrLit (Method {})  = True
-isMethodOrLit (LitInst {}) = True
-isMethodOrLit _            = False
+  | otherwise
+  = return (idHsWrapper, [], [], ty)
+
+deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
+--   Int -> forall a. a -> a  ==>  (\x:Int. [] x alpha) :: Int -> alpha
+-- In general if
+-- if    deeplyInstantiate ty = (wrap, rho)
+-- and   e :: ty
+-- then  wrap e :: rho
+
+deeplyInstantiate orig ty
+  | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
+  = do { (_, tys, subst) <- tcInstTyVars tvs
+       ; ids1  <- newSysLocalIds (fsLit "dsk") (substTys subst arg_tys)
+       ; wrap1 <- instCall orig tys (substTheta subst theta)
+       ; (wrap2, rho) <- deeplyInstantiate orig (substTy subst rho)
+       ; return (mkWpLams ids1 
+                    <.> wrap1 
+                    <.> mkWpEvVarApps ids1
+                    <.> wrap2,
+                 mkFunTys arg_tys rho) }
+
+  | otherwise = return (idHsWrapper, ty)
 \end{code}
 
 
 %************************************************************************
 %*									*
-\subsection{Building dictionaries}
+            Instantiating a call
 %*									*
 %************************************************************************
 
--- newDictBndrs makes a dictionary at a binding site
--- instCall makes a dictionary at an occurrence site
---	and throws it into the LIE
-
 \begin{code}
 ----------------
-newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
-newDictBndrsO orig theta = do { loc <- getInstLoc orig
-			      ; newDictBndrs loc theta }
-
-newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
-newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
-
-newDictBndr :: InstLoc -> TcPredType -> TcM Inst
--- Makes a "given"
-newDictBndr inst_loc pred@(EqPred ty1 ty2)
-  = do { uniq <- newUnique 
-	; let name = mkPredName uniq inst_loc pred 
-	      co   = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))
-	; return (EqInst {tci_name  = name, 
-			  tci_loc   = inst_loc, 
-			  tci_left  = ty1, 
-			  tci_right = ty2, 
-			  tci_co    = co }) }
-
-newDictBndr inst_loc pred = newDict inst_loc pred
-
--------------------
-newDictOccs :: InstLoc -> TcThetaType -> TcM [Inst]
-newDictOccs inst_loc theta = mapM (newDictOcc inst_loc) theta
-
-newDictOcc :: InstLoc -> TcPredType -> TcM Inst
--- Makes a "wanted"
-newDictOcc inst_loc pred@(EqPred ty1 ty2)
-  = do	{ uniq <- newUnique 
-	; cotv <- newMetaCoVar ty1 ty2
-	; let name = mkPredName uniq inst_loc pred 
-	; return (EqInst {tci_name  = name, 
-			  tci_loc   = inst_loc, 
-			  tci_left  = ty1, 
-			  tci_right = ty2, 
-			  tci_co    = Left cotv }) }
-
-newDictOcc inst_loc pred = newDict inst_loc pred
-
-----------------
-newDict :: InstLoc -> TcPredType -> TcM Inst
--- Always makes a Dict, not an EqInst
-newDict inst_loc pred
-  = do 	{ uniq <- newUnique 
-	; let name = mkPredName uniq inst_loc pred 
-	; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
-
-----------------
-instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
+instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
 -- Instantiate the constraints of a call
 --	(instCall o tys theta)
 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
@@ -405,163 +199,79 @@ instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
 -- (c) Returns an HsWrapper ([.] tys dicts)
 
 instCall orig tys theta 
-  = do	{ loc <- getInstLoc orig
-	; dict_app <- instCallDicts loc theta
+  = do	{ dict_app <- instCallConstraints orig theta
 	; return (dict_app <.> mkWpTyApps tys) }
 
 ----------------
-instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
--- Similar to instCall, but only emit the constraints in the LIE
--- Used exclusively for the 'stupid theta' of a data constructor
-instStupidTheta orig theta
-  = do	{ loc <- getInstLoc orig
-	; _co <- instCallDicts loc theta	-- Discard the coercion
-	; return () }
-
-----------------
-instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
+instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
 -- Instantiates the TcTheta, puts all constraints thereby generated
 -- into the LIE, and returns a HsWrapper to enclose the call site.
--- This is the key place where equality predicates 
--- are unleashed into the world
-instCallDicts _ [] = return idHsWrapper
-
--- instCallDicts loc (EqPred ty1 ty2 : preds)
---   = do  { unifyType ty1 ty2	-- For now, we insist that they unify right away 
--- 				-- Later on, when we do associated types, 
--- 				-- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
--- 	; (dicts, co_fn) <- instCallDicts loc preds
--- 	; return (dicts, co_fn <.> WpTyApp ty1) }
--- 	-- We use type application to apply the function to the 
--- 	-- coercion; here ty1 *is* the appropriate identity coercion
-
-instCallDicts loc (EqPred ty1 ty2 : preds)
-  = do  { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
-	; coi <- boxyUnify ty1 ty2
-	; let co = fromCoI coi ty1
-	; co_fn <- instCallDicts loc preds
-	; return (co_fn <.> WpTyApp co) }
-
-instCallDicts loc (pred : preds)
-  = do	{ dict <- newDict loc pred
-	; extendLIE dict
-	; co_fn <- instCallDicts loc preds
-	; return (co_fn <.> WpApp (instToId dict)) }
-
--------------
-cloneDict :: Inst -> TcM Inst
-cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique
-				  ; return (dict {tci_name = setNameUnique nm uniq}) }
-cloneDict eq@(EqInst {})     = return eq
-cloneDict other = pprPanic "cloneDict" (ppr other)
-
--- For vanilla implicit parameters, there is only one in scope
--- at any time, so we used to use the name of the implicit parameter itself
--- But with splittable implicit parameters there may be many in 
--- scope, so we make up a new namea.
-newIPDict :: InstOrigin -> IPName Name -> Type 
-	  -> TcM (IPName Id, Inst)
-newIPDict orig ip_name ty
-  = do	{ inst_loc <- getInstLoc orig
-	; dict <- newDict inst_loc (IParam ip_name ty)
-	; return (mapIPName (\_ -> instToId dict) ip_name, dict) }
-\end{code}
 
+instCallConstraints _ [] = return idHsWrapper
 
-\begin{code}
-mkPredName :: Unique -> InstLoc -> PredType -> Name
-mkPredName uniq loc pred_ty
-  = mkInternalName uniq occ (instLocSpan loc)
-  where
-    occ = case pred_ty of
-	    ClassP cls _ -> mkDictOcc (getOccName cls)
-	    IParam ip  _ -> getOccName (ipNameName ip)
-	    EqPred ty  _ -> mkEqPredCoOcc baseOcc
-	      where
-		-- we use the outermost tycon of the lhs, if there is one, to
-		-- improve readability of Core code
-	        baseOcc = case splitTyConApp_maybe ty of
-			    Nothing      -> mkTcOcc "$"
-                            Just (tc, _) -> getOccName tc
+instCallConstraints origin (EqPred ty1 ty2 : preds)	-- Try short-cut
+  = do  { traceTc "instCallConstraints" $ ppr (EqPred ty1 ty2)
+	; coi   <- unifyType ty1 ty2
+	; co_fn <- instCallConstraints origin preds
+	; let co = case coi of
+                       IdCo ty -> ty
+                       ACo  co -> co
+        ; return (co_fn <.> WpEvApp (EvCoercion co)) }
+
+instCallConstraints origin (pred : preds)
+  = do	{ ev_var <- emitWanted origin pred
+	; co_fn <- instCallConstraints origin preds
+	; return (co_fn <.> WpEvApp (EvId ev_var)) }
+
+----------------
+instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
+-- Similar to instCall, but only emit the constraints in the LIE
+-- Used exclusively for the 'stupid theta' of a data constructor
+instStupidTheta orig theta
+  = do	{ _co <- instCallConstraints orig theta -- Discard the coercion
+	; return () }
 \end{code}
 
 %************************************************************************
 %*									*
-\subsection{Building methods (calls of overloaded functions)}
+		Literals
 %*									*
 %************************************************************************
 
+In newOverloadedLit we convert directly to an Int or Integer if we
+know that's what we want.  This may save some time, by not
+temporarily generating overloaded literals, but it won't catch all
+cases (the rest are caught in lookupInst).
 
 \begin{code}
-newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
-newMethodFromName origin ty name = do
-    id <- tcLookupId name
-	-- Use tcLookupId not tcLookupGlobalId; the method is almost
-	-- always a class op, but with -XNoImplicitPrelude GHC is
-	-- meant to find whatever thing is in scope, and that may
-	-- be an ordinary function. 
-    loc <- getInstLoc origin
-    inst <- tcInstClassOp loc id [ty]
-    extendLIE inst
-    return (instToId inst)
-
-newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
-newMethodWithGivenTy orig id tys = do
-    loc <- getInstLoc orig
-    inst <- newMethod loc id tys
-    extendLIE inst
-    return (instToId inst)
-
---------------------------------------------
--- tcInstClassOp, and newMethod do *not* drop the 
--- Inst into the LIE; they just returns the Inst
--- This is important because they are used by TcSimplify
--- to simplify Insts
-
--- NB: the kind of the type variable to be instantiated
---     might be a sub-kind of the type to which it is applied,
---     notably when the latter is a type variable of kind ??
---     Hence the call to checkKind
--- A worry: is this needed anywhere else?
-tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
-tcInstClassOp inst_loc sel_id tys = do
-    let
-	(tyvars, _rho) = tcSplitForAllTys (idType sel_id)
-    zipWithM_ checkKind tyvars tys
-    newMethod inst_loc sel_id tys
-
-checkKind :: TyVar -> TcType -> TcM ()
--- Ensure that the type has a sub-kind of the tyvar
-checkKind tv ty
-  = do	{ let ty1 = ty 
-		-- ty1 <- zonkTcType ty
-	; if typeKind ty1 `isSubKind` Var.tyVarKind tv
-	  then return ()
-	  else 
-
-    pprPanic "checkKind: adding kind constraint" 
-	     (vcat [ppr tv <+> ppr (Var.tyVarKind tv), 
-	            ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
-	}
---    do	{ tv1 <- tcInstTyVar tv
---	; unifyType ty1 (mkTyVarTy tv1) } }
-
-
----------------------------
-newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
-newMethod inst_loc id tys = do
-    new_uniq <- newUnique
-    let
-	(theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
-	meth_id	    = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
-	inst        = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
-			      tci_theta = theta, tci_loc = inst_loc}
-	loc         = instLocSpan inst_loc
-    
-    return inst
-\end{code}
+newOverloadedLit :: CtOrigin
+		 -> HsOverLit Name
+		 -> TcRhoType
+		 -> TcM (HsOverLit TcId)
+newOverloadedLit orig 
+  lit@(OverLit { ol_val = val, ol_rebindable = rebindable
+	       , ol_witness = meth_name }) res_ty
+
+  | not rebindable
+  , Just expr <- shortCutLit val res_ty 
+	-- Do not generate a LitInst for rebindable syntax.  
+	-- Reason: If we do, tcSimplify will call lookupInst, which
+	--	   will call tcSyntaxName, which does unification, 
+	--	   which tcSimplify doesn't like
+  = return (lit { ol_witness = expr, ol_type = res_ty })
 
-\begin{code}
+  | otherwise
+  = do	{ hs_lit <- mkOverLit val
+	; let lit_ty = hsLitType hs_lit
+	; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
+	 	-- Overloaded literals must have liftedTypeKind, because
+	 	-- we're instantiating an overloaded function here,
+	 	-- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
+		-- However this'll be picked up by tcSyntaxOp if necessary
+	; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
+	; return (lit { ol_witness = witness, ol_type = res_ty }) }
+
+------------
 mkOverLit :: OverLitVal -> TcM HsLit
 mkOverLit (HsIntegral i) 
   = do	{ integer_ty <- tcMetaTy integerTyConName
@@ -575,144 +285,107 @@ mkOverLit (HsIsString s) = return (HsString s)
 \end{code}
 
 
+
+
 %************************************************************************
 %*									*
-\subsection{Zonking}
+		Re-mappable syntax
+    
+     Used only for arrow syntax -- find a way to nuke this
 %*									*
 %************************************************************************
 
-Zonking makes sure that the instance types are fully zonked.
+Suppose we are doing the -XNoImplicitPrelude thing, and we encounter
+a do-expression.  We have to find (>>) in the current environment, which is
+done by the rename. Then we have to check that it has the same type as
+Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
+this:
 
-\begin{code}
-zonkInst :: Inst -> TcM Inst
-zonkInst dict@(Dict {tci_pred = pred}) = do
-    new_pred <- zonkTcPredType pred
-    return (dict {tci_pred = new_pred})
-
-zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
-    new_id <- zonkId id
-	-- Essential to zonk the id in case it's a local variable
-	-- Can't use zonkIdOcc because the id might itself be
-	-- an InstId, in which case it won't be in scope
-
-    new_tys <- zonkTcTypes tys
-    new_theta <- zonkTcThetaType theta
-    return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
-	-- No need to zonk the tci_id
-
-zonkInst lit@(LitInst {tci_ty = ty}) = do
-    new_ty <- zonkTcType ty
-    return (lit {tci_ty = new_ty})
-
-zonkInst implic@(ImplicInst {})
-  = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
-    do 	{ givens'  <- zonkInsts (tci_given  implic)
-	; wanteds' <- zonkInsts (tci_wanted implic)
-	; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
-
-zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
-  = do { co' <- eitherEqInst eqinst 
-		  (\covar -> return (mkWantedCo covar)) 
-		  (\co    -> liftM mkGivenCo $ zonkTcType co)
-       ; ty1' <- zonkTcType ty1
-       ; ty2' <- zonkTcType ty2
-       ; return (eqinst {tci_co = co', tci_left = ty1', tci_right = ty2' })
-       }
-
-zonkInsts :: [Inst] -> TcRn [Inst]
-zonkInsts insts = mapM zonkInst insts
-\end{code}
+  (>>) :: HB m n mn => m a -> n b -> mn b
 
+So the idea is to generate a local binding for (>>), thus:
 
-%************************************************************************
-%*									*
-\subsection{Printing}
-%*									*
-%************************************************************************
+	let then72 :: forall a b. m a -> m b -> m b
+	    then72 = ...something involving the user's (>>)...
+	in
+	...the do-expression...
+
+Now the do-expression can proceed using then72, which has exactly
+the expected type.
 
-ToDo: improve these pretty-printing things.  The ``origin'' is really only
-relevant in error messages.
+In fact tcSyntaxName just generates the RHS for then72, because we only
+want an actual binding in the do-expression case. For literals, we can 
+just use the expression inline.
 
 \begin{code}
-instance Outputable Inst where
-    ppr inst = pprInst inst
-
-pprDictsTheta :: [Inst] -> SDoc
--- Print in type-like fashion (Eq a, Show b)
--- The Inst can be an implication constraint, but not a Method or LitInst
-pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
-
-pprDictsInFull :: [Inst] -> SDoc
--- Print in type-like fashion, but with source location
-pprDictsInFull dicts 
-  = vcat (map go dicts)
-  where
-    go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
-
-pprInsts :: [Inst] -> SDoc
--- Debugging: print the evidence :: type
-pprInsts insts = brackets (interpp'SP insts)
-
-pprInst, pprInstInFull :: Inst -> SDoc
--- Debugging: print the evidence :: type
-pprInst i@(EqInst {tci_left = ty1, tci_right = ty2}) 
-	= eitherEqInst i
-		(\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
-		(\co    -> text "Given"  <+> ppr co              <+> dcolon <+> ppr (EqPred ty1 ty2))
-pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon 
-		<+> braces (ppr (instType inst) <> implicWantedEqs)
-  where
-    name = instName inst
-    implicWantedEqs
-      | isImplicInst inst = text " &" <+> 
-                            ppr (filter isEqInst (tci_wanted inst))
-      | otherwise	  = empty
-
-pprInstInFull inst@(EqInst {}) = pprInst inst
-pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
-
-tidyInst :: TidyEnv -> Inst -> Inst
-tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
-  eq { tci_left  = tidyType env lty
-     , tci_right = tidyType env rty
-     , tci_co    = either Left (Right . tidyType env) co
-     }
-tidyInst env lit@(LitInst {tci_ty = ty})   = lit {tci_ty = tidyType env ty}
-tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
-tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
-tidyInst env implic@(ImplicInst {})
-  = implic { tci_tyvars = tvs' 
-	   , tci_given  = map (tidyInst env') (tci_given  implic)
-	   , tci_wanted = map (tidyInst env') (tci_wanted implic) }
-  where
-    (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
+tcSyntaxName :: CtOrigin
+	     -> TcType			-- Type to instantiate it at
+	     -> (Name, HsExpr Name)	-- (Standard name, user name)
+	     -> TcM (Name, HsExpr TcId)	-- (Standard name, suitable expression)
+--	*** NOW USED ONLY FOR CmdTop (sigh) ***
+-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
+-- So we do not call it from lookupInst, which is called from tcSimplify
 
-tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
--- This function doesn't assume that the tyvars are in scope
--- so it works like tidyOpenType, returning a TidyEnv
-tidyMoreInsts env insts
-  = (env', map (tidyInst env') insts)
-  where
-    env' = tidyFreeTyVars env (tyVarsOfInsts insts)
+tcSyntaxName orig ty (std_nm, HsVar user_nm)
+  | std_nm == user_nm
+  = do rhs <- newMethodFromName orig std_nm ty
+       return (std_nm, rhs)
 
-tidyInsts :: [Inst] -> (TidyEnv, [Inst])
-tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
+tcSyntaxName orig ty (std_nm, user_nm_expr) = do
+    std_id <- tcLookupId std_nm
+    let	
+	-- C.f. newMethodAtLoc
+	([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
+ 	sigma1		= substTyWith [tv] [ty] tau
+	-- Actually, the "tau-type" might be a sigma-type in the
+	-- case of locally-polymorphic methods.
+
+    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
+
+	-- Check that the user-supplied thing has the
+	-- same type as the standard one.  
+	-- Tiresome jiggling because tcCheckSigma takes a located expression
+     span <- getSrcSpanM
+     expr <- tcPolyExpr (L span user_nm_expr) sigma1
+     return (std_nm, unLoc expr)
 
-showLIE :: SDoc -> TcM ()	-- Debugging
-showLIE str
-  = do { lie_var <- getLIEVar ;
-	 lie <- readMutVar lie_var ;
-	 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
+syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
+               -> TcRn (TidyEnv, SDoc)
+syntaxNameCtxt name orig ty tidy_env = do
+    inst_loc <- getCtLoc orig
+    let
+	msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+> 
+				ptext (sLit "(needed by a syntactic construct)"),
+		    nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
+		    nest 2 (pprArisingAt inst_loc)]
+    return (tidy_env, msg)
 \end{code}
 
 
 %************************************************************************
 %*									*
-	Extending the instance environment
+		Instances
 %*									*
 %************************************************************************
 
 \begin{code}
+getOverlapFlag :: TcM OverlapFlag
+getOverlapFlag 
+  = do 	{ dflags <- getDOpts
+	; let overlap_ok    = dopt Opt_OverlappingInstances dflags
+	      incoherent_ok = dopt Opt_IncoherentInstances  dflags
+	      overlap_flag | incoherent_ok = Incoherent
+			   | overlap_ok    = OverlapOk
+			   | otherwise     = NoOverlap
+			   
+	; return overlap_flag }
+
+tcGetInstEnvs :: TcM (InstEnv, InstEnv)
+-- Gets both the external-package inst-env
+-- and the home-pkg inst env (includes module being compiled)
+tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
+		     return (eps_inst_env eps, tcg_inst_env env) }
+
 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
   -- Add new locally-defined instances
 tcExtendLocalInstEnv dfuns thing_inside
@@ -765,20 +438,9 @@ addLocalInst home_ie ispec
 		-- OK, now extend the envt
 	; return (extendInstEnv home_ie ispec') }
 
-getOverlapFlag :: TcM OverlapFlag
-getOverlapFlag 
-  = do 	{ dflags <- getDOpts
-	; let overlap_ok    = dopt Opt_OverlappingInstances dflags
-	      incoherent_ok = dopt Opt_IncoherentInstances  dflags
-	      overlap_flag | incoherent_ok = Incoherent
-			   | overlap_ok    = OverlapOk
-			   | otherwise     = NoOverlap
-			   
-	; return overlap_flag }
-
 traceDFuns :: [Instance] -> TcRn ()
 traceDFuns ispecs
-  = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
+  = traceTc "Adding instances:" (vcat (map pp ispecs))
   where
     pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
 	-- Print the dfun name itself too
@@ -800,427 +462,71 @@ addDictLoc ispec thing_inside
   where
    loc = getSrcLoc ispec
 \end{code}
-    
 
 %************************************************************************
 %*									*
-\subsection{Looking up Insts}
+	Simple functions over evidence variables
 %*									*
 %************************************************************************
 
 \begin{code}
-data LookupInstResult
-  = NoInstance
-  | GenInst [Inst] (LHsExpr TcId)	-- The expression and its needed insts
-
-lookupSimpleInst :: Inst -> TcM LookupInstResult
--- This is "simple" in that it returns NoInstance for implication constraints
-
--- It's important that lookupInst does not put any new stuff into
--- the LIE.  Instead, any Insts needed by the lookup are returned in
--- the LookupInstResult, where they can be further processed by tcSimplify
-
-lookupSimpleInst (EqInst {}) = return NoInstance
-
---------------------- Implications ------------------------
-lookupSimpleInst (ImplicInst {}) = return NoInstance
-
---------------------- Methods ------------------------
-lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
-  = do	{ (dict_app, dicts) <- getLIE $ instCallDicts loc theta
-	; let co_fn = dict_app <.> mkWpTyApps tys
-	; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
+hasEqualities :: [EvVar] -> Bool
+-- Has a bunch of canonical constraints (all givens) got any equalities in it?
+hasEqualities givens = any (has_eq . evVarPred) givens
   where
-    span = instLocSpan loc
-
---------------------- Literals ------------------------
--- Look for short cuts first: if the literal is *definitely* a 
--- int, integer, float or a double, generate the real thing here.
--- This is essential (see nofib/spectral/nucleic).
--- [Same shortcut as in newOverloadedLit, but we
---  may have done some unification by now] 		
-
-lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
-					          , ol_rebindable = rebindable }
-			  , tci_ty = ty, tci_loc = iloc})
-  | debugIsOn && rebindable = panic "lookupSimpleInst" -- A LitInst invariant
-  | Just witness <- shortCutLit lit_val ty
-  = do	{ let lit' = lit { ol_witness = witness, ol_type = ty }
-	; return (GenInst [] (L loc (HsOverLit lit'))) }
+    has_eq (EqPred {}) 	    = True
+    has_eq (IParam {}) 	    = False
+    has_eq (ClassP cls tys) = any has_eq (substTheta subst (classSCTheta cls))
+      where
+        subst = zipOpenTvSubst (classTyVars cls) tys
 
-  | otherwise
-  = do	{ hs_lit <- mkOverLit lit_val
-	; from_thing <- tcLookupId (hsOverLitName lit_val)
-		  -- Not rebindable, so hsOverLitName is the right thing
-    	; method_inst <- tcInstClassOp iloc from_thing [ty]
-	; let witness = HsApp (L loc (HsVar (instToId method_inst))) 
-			      (L loc (HsLit hs_lit))
-	      lit' = lit { ol_witness = witness, ol_type = ty }
-	; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
-  where
-    loc = instLocSpan iloc
-
---------------------- Dictionaries ------------------------
-lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
-  = do 	{ mb_result <- lookupPred pred
-	; case mb_result of {
-	    Nothing -> return NoInstance ;
-	    Just (dfun_id, mb_inst_tys) -> do
-
-    { use_stage <- getStage
-    ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
-    		      (topIdLvl dfun_id) (thLevel use_stage)
-
- 	-- It's possible that not all the tyvars are in
-	-- the substitution, tenv. For example:
-	--	instance C X a => D X where ...
-	-- (presumably there's a functional dependency in class C)
-	-- Hence mb_inst_tys :: Either TyVar TcType 
-
-    ; let inst_tv (Left tv)  = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
-	  inst_tv (Right ty) = return ty
-    ; tys <- mapM inst_tv mb_inst_tys
-    ; let
-    	(theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
-	src_loc	   = instLocSpan loc
-	dfun	   = HsVar dfun_id
-    ; if null theta then
-        return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
-      else do
-    { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
-    ; let co_fn = dict_app <.> mkWpTyApps tys
-    ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
-    }}}}
-
----------------
-lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
--- Look up a class constraint in the instance environment
-lookupPred pred@(ClassP clas tys)
-  = do	{ eps     <- getEps
-	; tcg_env <- getGblEnv
-	; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
-	; case lookupInstEnv inst_envs clas tys of {
-	    ([(ispec, inst_tys)], []) 
-		-> do	{ let dfun_id = is_dfun ispec
-			; traceTc (text "lookupInst success" <+> 
-				   vcat [text "dict" <+> ppr pred, 
-				         text "witness" <+> ppr dfun_id
-					 <+> ppr (idType dfun_id) ])
-				-- Record that this dfun is needed
-			; record_dfun_usage dfun_id
-			; return (Just (dfun_id, inst_tys)) } ;
-
-     	    (matches, unifs)
-		-> do	{ traceTc (text "lookupInst fail" <+> 
-				   vcat [text "dict" <+> ppr pred,
-				   	 text "matches" <+> ppr matches,
-				   	 text "unifs" <+> ppr unifs])
-		-- In the case of overlap (multiple matches) we report
-		-- NoInstance here.  That has the effect of making the 
-		-- context-simplifier return the dict as an irreducible one.
-		-- Then it'll be given to addNoInstanceErrs, which will do another
-		-- lookupInstEnv to get the detailed info about what went wrong.
-			; return Nothing }
-	}}
-
-lookupPred (IParam {}) = return Nothing	-- Implicit parameters
-lookupPred (EqPred {}) = panic "lookupPred EqPred"
-
-record_dfun_usage :: Id -> TcRn ()
-record_dfun_usage dfun_id 
-  = do	{ hsc_env <- getTopEnv
-	; let  dfun_name = idName dfun_id
-	       dfun_mod  = ASSERT( isExternalName dfun_name ) 
-	         	   nameModule dfun_name
-	; if isInternalName dfun_name ||    -- Internal name => defined in this module
-	     modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
-	  then return () -- internal, or in another package
-	   else do { tcg_env <- getGblEnv
-	  	   ; updMutVar (tcg_inst_uses tcg_env)
-			       (`addOneToNameSet` idName dfun_id) }}
-
-
-tcGetInstEnvs :: TcM (InstEnv, InstEnv)
--- Gets both the external-package inst-env
--- and the home-pkg inst env (includes module being compiled)
-tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
-		     return (eps_inst_env eps, tcg_inst_env env) }
-\end{code}
-
-
-
-%************************************************************************
-%*									*
-		Re-mappable syntax
-%*									*
-%************************************************************************
-
-Suppose we are doing the -XNoImplicitPrelude thing, and we encounter
-a do-expression.  We have to find (>>) in the current environment, which is
-done by the rename. Then we have to check that it has the same type as
-Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
-this:
-
-  (>>) :: HB m n mn => m a -> n b -> mn b
-
-So the idea is to generate a local binding for (>>), thus:
-
-	let then72 :: forall a b. m a -> m b -> m b
-	    then72 = ...something involving the user's (>>)...
-	in
-	...the do-expression...
-
-Now the do-expression can proceed using then72, which has exactly
-the expected type.
-
-In fact tcSyntaxName just generates the RHS for then72, because we only
-want an actual binding in the do-expression case. For literals, we can 
-just use the expression inline.
-
-\begin{code}
-tcSyntaxName :: InstOrigin
-	     -> TcType			-- Type to instantiate it at
-	     -> (Name, HsExpr Name)	-- (Standard name, user name)
-	     -> TcM (Name, HsExpr TcId)	-- (Standard name, suitable expression)
---	*** NOW USED ONLY FOR CmdTop (sigh) ***
--- NB: tcSyntaxName calls tcExpr, and hence can do unification.
--- So we do not call it from lookupInst, which is called from tcSimplify
-
-tcSyntaxName orig ty (std_nm, HsVar user_nm)
-  | std_nm == user_nm
-  = do id <- newMethodFromName orig ty std_nm
-       return (std_nm, HsVar id)
-
-tcSyntaxName orig ty (std_nm, user_nm_expr) = do
-    std_id <- tcLookupId std_nm
-    let	
-	-- C.f. newMethodAtLoc
-	([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
- 	sigma1		= substTyWith [tv] [ty] tau
-	-- Actually, the "tau-type" might be a sigma-type in the
-	-- case of locally-polymorphic methods.
+----------------
+tyVarsOfWanteds :: WantedConstraints -> TyVarSet
+tyVarsOfWanteds = foldrBag (unionVarSet . tyVarsOfWanted) emptyVarSet
 
-    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
+tyVarsOfWanted :: WantedConstraint -> TyVarSet
+tyVarsOfWanted (WcEvVar wev)   = tyVarsOfWantedEvVar wev
+tyVarsOfWanted (WcImplic impl) = tyVarsOfImplication impl
 
-	-- Check that the user-supplied thing has the
-	-- same type as the standard one.  
-	-- Tiresome jiggling because tcCheckSigma takes a located expression
-     span <- getSrcSpanM
-     expr <- tcPolyExpr (L span user_nm_expr) sigma1
-     return (std_nm, unLoc expr)
+tyVarsOfImplication :: Implication -> TyVarSet
+tyVarsOfImplication implic = tyVarsOfWanteds (ic_wanted implic)
+                             `minusVarSet` (ic_skols implic)
 
-syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
-               -> TcRn (TidyEnv, SDoc)
-syntaxNameCtxt name orig ty tidy_env = do
-    inst_loc <- getInstLoc orig
-    let
-	msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+> 
-				ptext (sLit "(needed by a syntactic construct)"),
-		    nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
-		    nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
-    
-    return (tidy_env, msg)
-\end{code}
+tyVarsOfWantedEvVar :: WantedEvVar -> TyVarSet
+tyVarsOfWantedEvVar (WantedEvVar ev _) = tyVarsOfEvVar ev
 
-%************************************************************************
-%*									*
-		EqInsts
-%*									*
-%************************************************************************
+tyVarsOfWantedEvVars :: Bag WantedEvVar -> TyVarSet
+tyVarsOfWantedEvVars = foldrBag (unionVarSet . tyVarsOfWantedEvVar) emptyVarSet
 
-Operations on EqInstCo.
+tyVarsOfEvVar :: EvVar -> TyVarSet
+tyVarsOfEvVar ev = tyVarsOfPred $ evVarPred ev
 
-\begin{code}
-mkGivenCo   :: Coercion -> EqInstCo
-mkGivenCo   =  Right
+tyVarsOfEvVars :: [EvVar] -> TyVarSet
+tyVarsOfEvVars = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet
 
-mkWantedCo  :: TcTyVar  -> EqInstCo
-mkWantedCo  =  Left
+---------------
+tidyWanteds :: TidyEnv -> WantedConstraints -> WantedConstraints
+tidyWanteds env = mapBag (tidyWanted env) 
 
-isWantedCo :: EqInstCo -> Bool
-isWantedCo (Left _) = True
-isWantedCo _        = False
+tidyWanted :: TidyEnv -> WantedConstraint -> WantedConstraint
+tidyWanted env (WcEvVar wev)     = WcEvVar (tidyWantedEvVar env wev)
+tidyWanted env (WcImplic implic) = WcImplic (tidyImplication env implic)
 
-eqInstCoType :: EqInstCo -> TcType
-eqInstCoType (Left cotv) = mkTyVarTy cotv
-eqInstCoType (Right co)  = co
-\end{code}
+tidyWantedEvVar :: TidyEnv -> WantedEvVar -> WantedEvVar
+tidyWantedEvVar env (WantedEvVar ev loc) = WantedEvVar (tidyEvVar env ev) loc
 
-Coercion transformations on EqInstCo.  These transformations work differently
-depending on whether a EqInstCo is for a wanted or local equality:
+tidyWantedEvVars :: TidyEnv -> Bag WantedEvVar -> Bag WantedEvVar
+tidyWantedEvVars env = mapBag (tidyWantedEvVar env)
 
-  Local : apply the inverse of the specified coercion
-  Wanted: obtain a fresh coercion hole (meta tyvar) and update the old hole
-          to be the specified coercion applied to the new coercion hole
+tidyEvVar :: TidyEnv -> EvVar -> EvVar
+tidyEvVar env v = setVarType v (tidyType env (varType v))
 
-\begin{code}
--- Coercion transformation: co = id
---
-mkIdEqInstCo :: EqInstCo -> Type -> TcM ()
-mkIdEqInstCo (Left cotv) t
-  = bindMetaTyVar cotv t
-mkIdEqInstCo (Right _) _
-  = return ()
-
--- Coercion transformation: co = sym co'
---
-mkSymEqInstCo :: EqInstCo -> (Type, Type) -> TcM EqInstCo
-mkSymEqInstCo (Left cotv) (ty1, ty2)
-  = do { cotv' <- newMetaCoVar ty1 ty2
-       ; bindMetaTyVar cotv (mkSymCoercion (TyVarTy cotv'))
-       ; return $ Left cotv'
-       }
-mkSymEqInstCo (Right co) _ 
-  = return $ Right (mkSymCoercion co)
-
--- Coercion transformation: co = co' |> given_co
---
-mkLeftTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
-mkLeftTransEqInstCo (Left cotv) given_co (ty1, ty2)
-  = do { cotv' <- newMetaCoVar ty1 ty2
-       ; bindMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co)
-       ; return $ Left cotv'
-       }
-mkLeftTransEqInstCo (Right co) given_co _ 
-  = return $ Right (co `mkTransCoercion` mkSymCoercion given_co)
-
--- Coercion transformation: co = given_co |> co'
---
-mkRightTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
-mkRightTransEqInstCo (Left cotv) given_co (ty1, ty2)
-  = do { cotv' <- newMetaCoVar ty1 ty2
-       ; bindMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv')
-       ; return $ Left cotv'
-       }
-mkRightTransEqInstCo (Right co) given_co _ 
-  = return $ Right (mkSymCoercion given_co `mkTransCoercion` co)
-
--- Coercion transformation: co = col cor
---
-mkAppEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type)
-              -> TcM (EqInstCo, EqInstCo)
-mkAppEqInstCo (Left cotv) (ty1_l, ty2_l) (ty1_r, ty2_r)
-  = do { cotv_l <- newMetaCoVar ty1_l ty2_l
-       ; cotv_r <- newMetaCoVar ty1_r ty2_r
-       ; bindMetaTyVar cotv (mkAppCoercion (TyVarTy cotv_l) (TyVarTy cotv_r))
-       ; return (Left cotv_l, Left cotv_r)
-       }
-mkAppEqInstCo (Right co) _ _
-  = return (Right $ mkLeftCoercion co, Right $ mkRightCoercion co)
-
--- Coercion transformation: co = con col -> cor
---
-mkTyConEqInstCo :: EqInstCo -> TyCon -> [(Type, Type)] -> TcM ([EqInstCo])
-mkTyConEqInstCo (Left cotv) con ty12s
-  = do { cotvs <- mapM (uncurry newMetaCoVar) ty12s
-       ; bindMetaTyVar cotv (mkTyConCoercion con (mkTyVarTys cotvs))
-       ; return (map Left cotvs)
-       }
-mkTyConEqInstCo (Right co) _ args
-  = return $ map (\mkCoes -> Right $ foldl (.) id mkCoes co) mkCoes
-    -- make cascades of the form 
-    --   mkRightCoercion (mkLeftCoercion .. (mkLeftCoercion co)..)
+tidyImplication :: TidyEnv -> Implication -> Implication
+tidyImplication env implic@(Implic { ic_skols = skols, ic_given = given
+                                   , ic_wanted = wanted })
+  = implic { ic_skols  = mkVarSet skols'
+           , ic_given  = map (tidyEvVar env') given
+           , ic_wanted = tidyWanteds env' wanted }
   where
-    n      = length args
-    mkCoes = [mkRightCoercion : replicate i mkLeftCoercion | i <- [n-1, n-2..0]]
-
--- Coercion transformation: co = col -> cor
---
-mkFunEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type)
-              -> TcM (EqInstCo, EqInstCo)
-mkFunEqInstCo (Left cotv) (ty1_l, ty2_l) (ty1_r, ty2_r)
-  = do { cotv_l <- newMetaCoVar ty1_l ty2_l
-       ; cotv_r <- newMetaCoVar ty1_r ty2_r
-       ; bindMetaTyVar cotv (mkFunCoercion (TyVarTy cotv_l) (TyVarTy cotv_r))
-       ; return (Left cotv_l, Left cotv_r)
-       }
-mkFunEqInstCo (Right co) _ _
-  = return (Right $ mkRightCoercion (mkLeftCoercion co), 
-            Right $ mkRightCoercion co)
-\end{code}
-
-Operations on entire EqInst.
-
-\begin{code}
--- |A wanted equality is unsolved as long as its cotv is unfilled.
---
-wantedEqInstIsUnsolved :: Inst -> TcM Bool
-wantedEqInstIsUnsolved (EqInst {tci_co = Left cotv})
-  = liftM not $ isFilledMetaTyVar cotv
-wantedEqInstIsUnsolved _ = return True
-
-eitherEqInst :: Inst 	            -- given or wanted EqInst
-	     -> (TcTyVar  -> a)     -- 	result if wanted
-	     -> (Coercion -> a)     --	result if given
-	     -> a		
-eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
-	= case either_co of
-		Left  covar -> withWanted covar
-		Right co    -> withGiven  co
-eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
-
-mkEqInst :: PredType -> EqInstCo -> TcM Inst
-mkEqInst (EqPred ty1 ty2) co
-	= do { uniq <- newUnique
-	     ; src_span <- getSrcSpanM
-	     ; err_ctxt <- getErrCtxt
-	     ; let loc  = InstLoc EqOrigin src_span err_ctxt
-	           name = mkName uniq src_span
-	           inst = EqInst { tci_left = ty1
-                                 , tci_right = ty2
-                                 , tci_co = co
-                                 , tci_loc = loc
-                                 , tci_name = name
-                                 } 
-	     ; return inst
-	     }
-	where 
-          mkName uniq src_span = mkInternalName uniq (mkVarOcc "co_ei") src_span
-mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
-
-mkWantedEqInst :: PredType -> TcM Inst
-mkWantedEqInst pred@(EqPred ty1 ty2)
-  = do { cotv <- newMetaCoVar ty1 ty2
-       ; mkEqInst pred (Left cotv)
-       }
-mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
-
--- Turn a wanted equality into a local that propagates the uninstantiated
--- coercion variable as witness.  We need this to propagate wanted irreds into
--- attempts to solve implication constraints.
---
-wantedToLocalEqInst :: Inst -> Inst
-wantedToLocalEqInst eq@(EqInst {tci_co = Left cotv})
-  = eq {tci_co = Right (mkTyVarTy cotv)}
-wantedToLocalEqInst eq = eq
-
--- Turn a wanted into a local EqInst (needed during type inference for
--- signatures) 
---
--- * Give it a name and change the coercion around.
---
-finalizeEqInst :: Inst			-- wanted
-	       -> TcM Inst		-- given
-finalizeEqInst wanted@(EqInst{tci_left = ty1, tci_right = ty2, 
-                              tci_name = name, tci_co = Left cotv})
-  = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
-
-         -- fill the coercion hole
-       ; writeMetaTyVar cotv (TyVarTy var)
-
-         -- set the new coercion
-       ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
-       ; return given
-       }
-
-finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
-
-eqInstType :: Inst -> TcType
-eqInstType inst = eitherEqInst inst mkTyVarTy id
-
-eqInstCoercion :: Inst -> EqInstCo
-eqInstCoercion = tci_co
-
-eqInstTys :: Inst -> (TcType, TcType)
-eqInstTys inst = (tci_left inst, tci_right inst)
-\end{code}
+    (env', skols') = mapAccumL tidyTyVarBndr env (varSetElems skols)
+\end{code}
\ No newline at end of file
diff --git a/compiler/typecheck/TcAnnotations.lhs b/compiler/typecheck/TcAnnotations.lhs
index 186e93f..1d495c0 100644
--- a/compiler/typecheck/TcAnnotations.lhs
+++ b/compiler/typecheck/TcAnnotations.lhs
@@ -46,6 +46,6 @@ annProvenanceToTarget mod ModuleAnnProvenance       = ModuleTarget mod
 
 annCtxt :: OutputableBndr id => LAnnDecl id -> SDoc
 annCtxt ann
-  = hang (ptext (sLit "In the annotation:")) 4 (ppr ann)
+  = hang (ptext (sLit "In the annotation:")) 2 (ppr ann)
 #endif
 \end{code}
\ No newline at end of file
diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs
index 2e59926..14e561b 100644
--- a/compiler/typecheck/TcArrows.lhs
+++ b/compiler/typecheck/TcArrows.lhs
@@ -10,14 +10,10 @@ module TcArrows ( tcProc ) where
 import {-# SOURCE #-}	TcExpr( tcMonoExpr, tcInferRho )
 
 import HsSyn
-import TcHsSyn
-
 import TcMatches
-
 import TcType
 import TcMType
 import TcBinds
-import TcSimplify
 import TcPat
 import TcUnify
 import TcRnMonad
@@ -44,19 +40,18 @@ import Control.Monad
 
 \begin{code}
 tcProc :: InPat Name -> LHsCmdTop Name		-- proc pat -> expr
-       -> BoxyRhoType				-- Expected type of whole proc expression
+       -> TcRhoType				-- Expected type of whole proc expression
        -> TcM (OutPat TcId, LHsCmdTop TcId, CoercionI)
 
 tcProc pat cmd exp_ty
   = newArrowScope $
-    do	{ ((exp_ty1, res_ty), coi) <- boxySplitAppTy exp_ty 
-	; ((arr_ty, arg_ty), coi1) <- boxySplitAppTy exp_ty1
+    do	{ (coi, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty 
+	; (coi1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
 	; let cmd_env = CmdEnv { cmd_arr = arr_ty }
 	; (pat', cmd') <- tcPat ProcExpr pat arg_ty res_ty $
-			  tcCmdTop cmd_env cmd []
-        ; let res_coi = mkTransCoI coi (mkAppTyCoI exp_ty1 coi1 res_ty IdCo)
-	; return (pat', cmd', res_coi) 
-        }
+			  tcCmdTop cmd_env cmd [] res_ty
+        ; let res_coi = mkTransCoI coi (mkAppTyCoI coi1 (IdCo res_ty))
+	; return (pat', cmd', res_coi) }
 \end{code}
 
 
@@ -187,7 +182,7 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats _maybe_rhs_sig
 		-- Check the patterns, and the GRHSs inside
 	; (pats', grhss') <- setSrcSpan mtch_loc			$
 			     tcPats LambdaExpr pats cmd_stk res_ty	$
-			     tc_grhss grhss
+			     tc_grhss grhss res_ty
 
 	; let match' = L mtch_loc (Match pats' Nothing grhss')
 	; return (HsLam (MatchGroup [match'] res_ty))
@@ -246,24 +241,18 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
 		--   -> a ((w,t1) .. tn) t
 	; let e_ty = mkFunTys [mkAppTys b [tup,s] | (_,_,b,tup,s) <- cmds_w_tys] 
 			      e_res_ty
+              free_tvs = tyVarsOfTypes (res_ty:cmd_stk)
 
 		-- Check expr
-	; (expr', lie) <- escapeArrowScope (getLIE (tcMonoExpr expr e_ty))
-	; loc <- getInstLoc (SigOrigin ArrowSkol)
-	; inst_binds <- tcSimplifyCheck loc [w_tv] [] lie
-
-		-- Check that the polymorphic variable hasn't been unified with anything
-		-- and is not free in res_ty or the cmd_stk  (i.e.  t, t1..tn)
-	; checkSigTyVarsWrt (tyVarsOfTypes (res_ty:cmd_stk)) [w_tv] 
+	; (inst_binds, expr') <- checkConstraints ArrowSkol free_tvs [w_tv] [] $
+                                 escapeArrowScope (tcMonoExpr expr e_ty)
 
 		-- OK, now we are in a position to unscramble 
 		-- the s1..sm and check each cmd
 	; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys
 
-	; return (HsArrForm (noLoc $ HsWrap (WpTyLam w_tv) 
-					       (unLoc $ mkHsDictLet inst_binds expr')) 
-			     fixity cmds')
-	}
+        ; let wrap = WpTyLam w_tv <.> mkWpLet inst_binds
+	; return (HsArrForm (mkLHsWrap wrap expr') fixity cmds') }
   where
  	-- Make the types	
 	--	b, ((e,s1) .. sm), s
@@ -340,15 +329,15 @@ cmdCtxt cmd = ptext (sLit "In the command:") <+> ppr cmd
 nonEmptyCmdStkErr :: HsExpr Name -> SDoc
 nonEmptyCmdStkErr cmd
   = hang (ptext (sLit "Non-empty command stack at command:"))
-	 4 (ppr cmd)
+       2 (ppr cmd)
 
 kappaUnderflow :: HsExpr Name -> SDoc
 kappaUnderflow cmd
   = hang (ptext (sLit "Command stack underflow at command:"))
-	 4 (ppr cmd)
+       2 (ppr cmd)
 
 badFormFun :: Int -> TcType -> SDoc
 badFormFun i tup_ty'
  = hang (ptext (sLit "The type of the") <+> speakNth i <+> ptext (sLit "argument of a command form has the wrong shape"))
-	4 (ptext (sLit "Argument type:") <+> ppr tup_ty')
+      2 (ptext (sLit "Argument type:") <+> ppr tup_ty')
 \end{code}
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index cf0e165..03fa83a 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -6,9 +6,9 @@
 
 \begin{code}
 module TcBinds ( tcLocalBinds, tcTopBinds, 
-                 tcHsBootSigs, tcMonoBinds, tcPolyBinds,
-                 TcPragFun, tcPrags, mkPragFun, 
-                 TcSigInfo(..), TcSigFun, mkTcSigFun,
+                 tcHsBootSigs, tcPolyBinds,
+                 PragFun, tcPrags, mkPragFun, 
+                 TcSigInfo(..), SigFun, mkSigFun,
                  badBootDeclErr ) where
 
 import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
@@ -18,7 +18,6 @@ import DynFlags
 import HsSyn
 
 import TcRnMonad
-import Inst
 import TcEnv
 import TcUnify
 import TcSimplify
@@ -27,7 +26,6 @@ import TcPat
 import TcMType
 import TcType
 import Coercion
-import VarEnv
 import TysPrim
 import Id
 import Var
@@ -122,22 +120,28 @@ tcLocalBinds (HsValBinds binds) thing_inside
         ; return (HsValBinds binds', thing) }
 
 tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
-  = do  { (thing, lie) <- getLIE thing_inside
-        ; (avail_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
+  = do  { (given_ips, ip_binds') <- mapAndUnzipM (wrapLocSndM tc_ip_bind) ip_binds
 
         -- If the binding binds ?x = E, we  must now 
         -- discharge any ?x constraints in expr_lie
-        ; dict_binds <- tcSimplifyIPs avail_ips lie
-        ; return (HsIPBinds (IPBinds ip_binds' dict_binds), thing) }
+        ; (ev_binds, result) <- checkConstraints (IPSkol ips) 
+                                  emptyVarSet [] -- No skolem tyvars and hence 
+                                                 -- no need for envt tyvars
+                                  given_ips $
+                                thing_inside
+
+        ; return (HsIPBinds (IPBinds ip_binds' ev_binds), result) }
   where
+    ips = [ip | L _ (IPBind ip _) <- ip_binds]
+
         -- I wonder if we should do these one at at time
         -- Consider     ?x = 4
         --              ?y = ?x + 1
-    tc_ip_bind (IPBind ip expr) = do
-        ty <- newFlexiTyVarTy argTypeKind
-        (ip', ip_inst) <- newIPDict (IPBindOrigin ip) ip ty
-        expr' <- tcMonoExpr expr ty
-        return (ip_inst, (IPBind ip' expr'))
+    tc_ip_bind (IPBind ip expr) 
+       = do { ty <- newFlexiTyVarTy argTypeKind
+            ; ip_id <- newIP ip ty
+            ; expr' <- tcMonoExpr expr ty
+            ; return (ip_id, (IPBind (IPName ip_id) expr')) }
 
 ------------------------
 tcValBinds :: TopLevelFlag 
@@ -151,7 +155,7 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
   = do  {       -- Typecheck the signature
         ; let { prag_fn = mkPragFun sigs (foldr (unionBags . snd) emptyBag binds)
               ; ty_sigs = filter isTypeLSig sigs
-              ; sig_fn  = mkTcSigFun ty_sigs }
+              ; sig_fn  = mkSigFun ty_sigs }
 
         ; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs)
                 -- No recovery from bad signatures, because the type sigs
@@ -162,15 +166,14 @@ tcValBinds top_lvl (ValBindsOut binds sigs) thing_inside
 
                 -- Extend the envt right away with all 
                 -- the Ids declared with type signatures
-        ; poly_rec <- doptM Opt_RelaxedPolyRec
         ; (binds', thing) <- tcExtendIdEnv poly_ids $
-                             tcBindGroups poly_rec top_lvl sig_fn prag_fn 
+                             tcBindGroups top_lvl sig_fn prag_fn 
                                           binds thing_inside
 
         ; return (ValBindsOut binds' sigs, thing) }
 
 ------------------------
-tcBindGroups :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
+tcBindGroups :: TopLevelFlag -> SigFun -> PragFun
              -> [(RecFlag, LHsBinds Name)] -> TcM thing
              -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 -- Typecheck a whole lot of value bindings,
@@ -179,18 +182,19 @@ tcBindGroups :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
 -- meaning of a group of bindings that mention each other, 
 -- ignoring type signatures (that part comes later)
 
-tcBindGroups _ _ _ _ [] thing_inside
+tcBindGroups _ _ _ [] thing_inside
   = do  { thing <- thing_inside
         ; return ([], thing) }
 
-tcBindGroups poly_rec top_lvl sig_fn prag_fn (group : groups) thing_inside
+tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside
   = do  { (group', (groups', thing))
-                <- tc_group poly_rec top_lvl sig_fn prag_fn group $ 
-                   tcBindGroups poly_rec top_lvl sig_fn prag_fn groups thing_inside
+                <- tc_group top_lvl sig_fn prag_fn group $ 
+                   tcBindGroups top_lvl sig_fn prag_fn groups thing_inside
         ; return (group' ++ groups', thing) }
 
 ------------------------
-tc_group :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
+tc_group :: forall thing. 
+            TopLevelFlag -> SigFun -> PragFun
          -> (RecFlag, LHsBinds Name) -> TcM thing
          -> TcM ([(RecFlag, LHsBinds TcId)], thing)
 
@@ -198,58 +202,46 @@ tc_group :: Bool -> TopLevelFlag -> TcSigFun -> TcPragFun
 -- We get a list of groups back, because there may 
 -- be specialisations etc as well
 
-tc_group _ top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
+tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
         -- A single non-recursive binding
         -- We want to keep non-recursive things non-recursive
         -- so that we desugar unlifted bindings correctly
- =  do  { (binds1, lie_binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn 
-    	  	   	      	     		     NonRecursive binds thing_inside
-        ; return ( [(NonRecursive, unitBag b) | b <- bagToList binds1]
-	  	     ++ [(Recursive, lie_binds)]  -- TcDictBinds have scrambled dependency order
-		 , thing) }
-
-tc_group poly_rec top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
-  | not poly_rec        -- Recursive group, normal Haskell 98 route
-  = do  { (binds1, lie_binds, thing) <- tc_haskell98 top_lvl sig_fn prag_fn 
-    	  	   	      	     		     Recursive binds thing_inside
-        ; return ([(Recursive, binds1 `unionBags` lie_binds)], thing) }
-
-  | otherwise           -- Recursive group, with -XRelaxedPolyRec
-  =     -- To maximise polymorphism (with -XRelaxedPolyRec), we do a new 
+ =  do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn NonRecursive NonRecursive
+                                      (bagToList binds)
+       ; thing <- tcExtendIdEnv ids thing_inside
+       ; return ( [(NonRecursive, binds1)], thing) }
+
+tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
+  =     -- To maximise polymorphism (assumes -XRelaxedPolyRec), we do a new 
         -- strongly-connected-component analysis, this time omitting 
         -- any references to variables with type signatures.
-        --
-        -- Notice that the bindInsts thing covers *all* the bindings in
-        -- the original group at once; an earlier one may use a later one!
-    do  { traceTc (text "tc_group rec" <+> pprLHsBinds binds)
-        ; (binds1,lie_binds,thing) <- bindLocalInsts top_lvl $
-                            go (stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds))
-        ; return ([(Recursive, binds1 `unionBags` lie_binds)], thing) }
+    do  { traceTc "tc_group rec" (pprLHsBinds binds)
+        ; (binds1, _ids, thing) <- go sccs
+    	     -- Here is where we should do bindInstsOfLocalFuns
+	     -- if we start having Methods again
+        ; return ([(Recursive, binds1)], thing) }
                 -- Rec them all together
   where
---  go :: SCC (LHsBind Name) -> TcM (LHsBinds TcId, [TcId], thing)
-    go (scc:sccs) = do  { (binds1, ids1) <- tc_scc scc
+    sccs :: [SCC (LHsBind Name)]
+    sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
+
+    go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
+    go (scc:sccs) = do  { (binds1, ids1)        <- tc_scc scc
                         ; (binds2, ids2, thing) <- tcExtendIdEnv ids1 $ go sccs
                         ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
     go []         = do  { thing <- thing_inside; return (emptyBag, [], thing) }
 
-    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive (unitBag bind)
-    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    (listToBag binds)
+    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
+    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
 
     tc_sub_group = tcPolyBinds top_lvl sig_fn prag_fn Recursive
 
-tc_haskell98 :: TopLevelFlag -> TcSigFun -> TcPragFun -> RecFlag
-             -> LHsBinds Name -> TcM a -> TcM (LHsBinds TcId, TcDictBinds, a)
-tc_haskell98 top_lvl sig_fn prag_fn rec_flag binds thing_inside
-  = bindLocalInsts top_lvl $ 
-    do { (binds1, ids) <- tcPolyBinds top_lvl sig_fn prag_fn rec_flag rec_flag binds
-       ; thing <- tcExtendIdEnv ids thing_inside
-       ; return (binds1, ids, thing) }
 
 ------------------------
+{-
 bindLocalInsts :: TopLevelFlag
-	       -> TcM (LHsBinds TcId, [TcId],      a)
-	       -> TcM (LHsBinds TcId, TcDictBinds, a)
+	       -> TcM (LHsBinds TcId, [TcId],    a)
+	       -> TcM (LHsBinds TcId, TcEvBinds, a)
 bindLocalInsts top_lvl thing_inside
   | isTopLevel top_lvl
   = do { (binds, _, thing) <- thing_inside; return (binds, emptyBag, thing) }
@@ -258,12 +250,13 @@ bindLocalInsts top_lvl thing_inside
         -- leave them to the tcSimplifyTop, and quite a bit faster too
 
   | otherwise   -- Nested case
-  = do  { ((binds, ids, thing), lie) <- getLIE thing_inside
-        ; lie_binds <- bindInstsOfLocalFuns lie ids
+  = do  { ((binds, ids, thing), lie) <- getConstraints thing_inside
+        ; lie_binds <- bindLocalMethods lie ids
         ; return (binds, lie_binds, thing) }
+-}
 
 ------------------------
-mkEdges :: TcSigFun -> LHsBinds Name
+mkEdges :: SigFun -> LHsBinds Name
         -> [(LHsBind Name, BKey, [BKey])]
 
 type BKey  = Int -- Just number off the bindings
@@ -290,12 +283,12 @@ bindersOfHsBind (AbsBinds {})                = panic "bindersOfHsBind AbsBinds"
 bindersOfHsBind (VarBind {})                 = panic "bindersOfHsBind VarBind"
 
 ------------------------
-tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragFun
-            -> RecFlag                  -- Whether the group is really recursive
-            -> RecFlag                  -- Whether it's recursive after breaking
-                                        -- dependencies based on type signatures
-            -> LHsBinds Name
-            -> TcM (LHsBinds TcId, [TcId])
+tcPolyBinds :: TopLevelFlag -> SigFun -> PragFun
+  	    -> RecFlag       -- Whether the group is really recursive
+  	    -> RecFlag       -- Whether it's recursive after breaking
+  	                     -- dependencies based on type signatures
+  	    -> [LHsBind Name]
+  	    -> TcM (LHsBinds TcId, [TcId])
 
 -- Typechecks a single bunch of bindings all together, 
 -- and generalises them.  The bunch may be only part of a recursive
@@ -307,74 +300,143 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> TcPragFun
 -- 
 -- Knows nothing about the scope of the bindings
 
-tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc binds
-  = let 
-        bind_list    = bagToList binds
-        binder_names = collectHsBindsBinders binds
-        loc          = getLoc (head bind_list)
-                -- TODO: location a bit awkward, but the mbinds have been
-                --       dependency analysed and may no longer be adjacent
-    in
-        -- SET UP THE MAIN RECOVERY; take advantage of any type sigs
-    setSrcSpan loc                              $
+tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
+  = setSrcSpan loc                              $
     recoverM (recoveryCode binder_names sig_fn) $ do 
+        -- Set up main recoer; take advantage of any type sigs
 
-  { traceTc (ptext (sLit "------------------------------------------------"))
-  ; traceTc (ptext (sLit "Bindings for") <+> ppr binder_names)
+    { traceTc "------------------------------------------------" empty
+    ; traceTc "Bindings for" (ppr binder_names)
 
-        -- TYPECHECK THE BINDINGS
-  ; ((binds', mono_bind_infos), lie_req) 
-        <- getLIE (tcMonoBinds bind_list sig_fn rec_tc)
-  ; traceTc (text "temp" <+> (ppr binds' $$ ppr lie_req))
+    ; tc_sig_fn <- tcInstSigs sig_fn binder_names
 
-        -- CHECK FOR UNLIFTED BINDINGS
+    ; dflags <- getDOpts
+    ; let plan = decideGeneralisationPlan dflags top_lvl binder_names bind_list tc_sig_fn
+    ; traceTc "Generalisation plan" (ppr plan)
+    ; (binds, poly_ids) <- case plan of
+         NoGen         -> tcPolyNoGen tc_sig_fn prag_fn rec_group rec_tc bind_list
+         InferGen mono -> tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_group rec_tc bind_list
+         CheckGen sig  -> tcPolyCheck sig prag_fn rec_group rec_tc bind_list
+
+	-- Check whether strict bindings are ok
         -- These must be non-recursive etc, and are not generalised
         -- They desugar to a case expression in the end
-  ; zonked_mono_tys <- zonkTcTypes (map getMonoType mono_bind_infos)
-  ; is_strict <- checkStrictBinds top_lvl rec_group binds' 
-                                  zonked_mono_tys mono_bind_infos
-  ; if is_strict then
-    do  { extendLIEs lie_req
-        ; let exports = zipWith mk_export mono_bind_infos zonked_mono_tys
-              mk_export (name, mb_sig,  mono_id) mono_ty 
-                = ([], the_id, mono_id, noSpecPrags)
-                              -- ToDo: prags for unlifted bindings
-	      	where
-                  the_id = case mb_sig of
-                             Just sig -> sig_id sig
-                             Nothing  -> mkLocalId name mono_ty
-
-        ; return ( unitBag $ L loc $ AbsBinds [] [] exports binds',
-                   [poly_id | (_, poly_id, _, _) <- exports]) } -- Guaranteed zonked
-
-    else do     -- The normal lifted case: GENERALISE
-  { dflags <- getDOpts 
-  ; (tyvars_to_gen, dicts, dict_binds)
-        <- addErrCtxt (genCtxt (bndrNames mono_bind_infos)) $
-           generalise dflags top_lvl bind_list sig_fn mono_bind_infos lie_req
-
-        -- BUILD THE POLYMORPHIC RESULT IDs
-  ; let dict_vars = map instToVar dicts -- May include equality constraints
-  ; exports <- mapM (mkExport top_lvl rec_group (length mono_bind_infos > 1)
-                              prag_fn tyvars_to_gen (map varType dict_vars))
-                    mono_bind_infos
-
-  ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
-  ; traceTc (text "binding:" <+> ppr (poly_ids `zip` map idType poly_ids))
-
-  ; let abs_bind = L loc $ AbsBinds tyvars_to_gen
-                                    dict_vars exports
-                                    (dict_binds `unionBags` binds')
-
-  ; return (unitBag abs_bind, poly_ids)       -- poly_ids are guaranteed zonked by mkExport
-  } }
+    ; checkStrictBinds top_lvl rec_group bind_list poly_ids
+
+	 -- Warn about missing signatures
+	 -- Do this only when we we have a type to offer
+    ; warn_missing_sigs <- doptM Opt_WarnMissingSigs
+    ; when (isTopLevel top_lvl && warn_missing_sigs) $
+      mapM_ missingSigWarn (filter no_sig poly_ids)
+
+    ; return (binds, poly_ids) }
+  where
+    no_sig id = isNothing (sig_fn (idName id))
+
+    binder_names = collectHsBindListBinders bind_list
+    loc = getLoc (head bind_list)
+         -- TODO: location a bit awkward, but the mbinds have been
+         --       dependency analysed and may no longer be adjacent
+
+tcPolyNoGen 
+  :: TcSigFun -> PragFun
+  -> RecFlag       -- Whether the group is really recursive
+  -> RecFlag       -- Whether it's recursive after breaking
+                   -- dependencies based on type signatures
+  -> [LHsBind Name]
+  -> TcM (LHsBinds TcId, [TcId])
+-- No generalisation whatsoever
+
+tcPolyNoGen tc_sig_fn prag_fn rec_group rec_tc bind_list
+  = do { (binds', mono_infos) <- tcMonoBinds tc_sig_fn True rec_tc bind_list
+       ; mono_ids' <- mapM tc_mono_info mono_infos
+       ; return (binds', mono_ids') }
+  where
+    tc_mono_info (name, _, mono_id)
+      = do { mono_ty' <- zonkTcTypeCarefully (idType mono_id)
+      	     -- Zonk, mainly to expose unboxed types to checkStrictBinds
+           ; let mono_id' = setIdType mono_id mono_ty'
+           ; (mono_id'', _specs) <- tcPrags rec_group False False
+                                           mono_id' (prag_fn name)
+           ; return mono_id'' } 
+	   -- NB: tcPrags generates and error message for
+	   --     specialisation pragmas for non-overloaded sigs
+	   -- So we can safely ignore _specs
+
+------------------
+tcPolyCheck :: TcSigInfo -> PragFun
+  	    -> RecFlag       -- Whether the group is really recursive
+  	    -> RecFlag       -- Whether it's recursive after breaking
+  	                     -- dependencies based on type signatures
+  	    -> [LHsBind Name]
+  	    -> TcM (LHsBinds TcId, [TcId])
+-- There is just one binding, 
+--   it binds a single variable,
+--   it has a signature,
+tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped
+                           , sig_theta = theta, sig_loc = loc })
+    prag_fn rec_group rec_tc bind_list
+  = do { ev_vars <- newEvVars theta
+
+       ; let skol_info = SigSkol (FunSigCtxt (idName id))
+       ; (ev_binds, (binds', [mono_info])) 
+            <- checkConstraints skol_info emptyVarSet tvs ev_vars $
+               tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs)    $
+               tcMonoBinds (\_ -> Just sig) False rec_tc bind_list
+
+       ; export <- mkExport rec_group False prag_fn tvs theta mono_info
+
+       ; let (_, poly_id, _, _) = export
+             abs_bind = L loc $ AbsBinds 
+                        { abs_tvs = tvs
+                        , abs_ev_vars = ev_vars, abs_ev_binds = ev_binds
+                        , abs_exports = [export], abs_binds = binds' }
+       ; return (unitBag abs_bind, [poly_id]) }
+
+tcPolyInfer 
+  :: TopLevelFlag 
+  -> Bool	  -- True <=> apply the monomorphism restriction
+  -> TcSigFun -> PragFun
+  -> RecFlag       -- Whether the group is really recursive
+  -> RecFlag       -- Whether it's recursive after breaking
+                   -- dependencies based on type signatures
+  -> [LHsBind Name]
+  -> TcM (LHsBinds TcId, [TcId])
+tcPolyInfer top_lvl mono sig_fn prag_fn rec_group rec_tc bind_list
+  = do { ((binds', mono_infos), wanted) 
+             <- getConstraints $
+                tcMonoBinds sig_fn False rec_tc bind_list
+
+       ; unifyCtxts [sig | (_, Just sig, _) <- mono_infos] 
+
+       ; let get_tvs | isTopLevel top_lvl = tyVarsOfType  
+                     | otherwise          = exactTyVarsOfType
+		     -- See Note [Silly type synonym] in TcType
+             tau_tvs = foldr (unionVarSet . get_tvs . getMonoType) emptyVarSet mono_infos
+
+       ; (qtvs, givens, ev_binds) <- simplifyInfer mono tau_tvs wanted
+
+       ; exports <- mapM (mkExport rec_group (length mono_infos > 1)
+                                   prag_fn qtvs (map evVarPred givens))
+                    mono_infos
+
+       ; let poly_ids = [poly_id | (_, poly_id, _, _) <- exports]
+       ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))
+
+       ; loc <- getSrcSpanM
+       ; let abs_bind = L loc $ AbsBinds { abs_tvs = qtvs
+                                         , abs_ev_vars = givens, abs_ev_binds = ev_binds
+                                         , abs_exports = exports, abs_binds = binds' }
+
+       ; return (unitBag abs_bind, poly_ids)   -- poly_ids are guaranteed zonked by mkExport
+  }
 
 
 --------------
-mkExport :: TopLevelFlag -> RecFlag
+mkExport :: RecFlag
 	 -> Bool	 -- More than one variable is bound, so we'll desugar to
 	    		 -- a tuple, so INLINE pragmas won't work
-         -> TcPragFun -> [TyVar] -> [TcType]
+         -> PragFun -> [TyVar] -> TcThetaType
          -> MonoBindInfo
          -> TcM ([TyVar], Id, Id, TcSpecPrags)
 -- mkExport generates exports with 
@@ -388,33 +450,30 @@ mkExport :: TopLevelFlag -> RecFlag
 
 -- Pre-condition: the inferred_tvs are already zonked
 
-mkExport top_lvl rec_group multi_bind prag_fn inferred_tvs dict_tys
+mkExport rec_group multi_bind prag_fn inferred_tvs theta
          (poly_name, mb_sig, mono_id)
-  = do  { warn_missing_sigs <- doptM Opt_WarnMissingSigs
-        ; let warn = isTopLevel top_lvl && warn_missing_sigs
-        ; (tvs, poly_id) <- mk_poly_id warn mb_sig
+  = do  { (tvs, poly_id) <- mk_poly_id mb_sig
                 -- poly_id has a zonked type
 
-        ; (poly_id', spec_prags) <- tcPrags rec_group multi_bind (notNull dict_tys)
-                                            poly_id (prag_fn poly_name)
+        ; (poly_id', spec_prags) <- tcPrags rec_group multi_bind (notNull theta)
+                                        poly_id (prag_fn poly_name)
                 -- tcPrags requires a zonked poly_id
 
         ; return (tvs, poly_id', mono_id, SpecPrags spec_prags) }
   where
-    poly_ty = mkForAllTys inferred_tvs (mkFunTys dict_tys (idType mono_id))
+    poly_ty = mkSigmaTy inferred_tvs theta (idType mono_id)
 
-    mk_poly_id warn Nothing    = do { poly_ty' <- zonkTcType poly_ty
-                                    ; missingSigWarn warn poly_name poly_ty'
-                                    ; return (inferred_tvs, mkLocalId poly_name poly_ty') }
-    mk_poly_id _    (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig)
-                                    ; return (tvs,  sig_id sig) }
+    mk_poly_id Nothing    = do { poly_ty' <- zonkTcTypeCarefully poly_ty
+                               ; return (inferred_tvs, mkLocalId poly_name poly_ty') }
+    mk_poly_id (Just sig) = do { tvs <- mapM zonk_tv (sig_tvs sig)
+                               ; return (tvs,  sig_id sig) }
 
     zonk_tv tv = do { ty <- zonkTcTyVar tv; return (tcGetTyVar "mkExport" ty) }
 
 ------------------------
-type TcPragFun = Name -> [LSig Name]
+type PragFun = Name -> [LSig Name]
 
-mkPragFun :: [LSig Name] -> LHsBinds Name -> TcPragFun
+mkPragFun :: [LSig Name] -> LHsBinds Name -> PragFun
 mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
   where
     prs = mapCatMaybes get_sig sigs
@@ -515,23 +574,23 @@ warnPrags id bad_sigs herald
 tcSpecPrag :: TcId -> Sig Name -> TcM TcSpecPrag
 tcSpecPrag poly_id prag@(SpecSig _ hs_ty inl) 
   = addErrCtxt (spec_ctxt prag) $
-    do  { let name = idName poly_id
-        ; spec_ty <- tcHsSigType (FunSigCtxt name) hs_ty
-        ; co_fn <- tcSubExp (SpecPragOrigin name) (idType poly_id) spec_ty
-        ; return (SpecPrag co_fn inl) }
+    do  { let name     = idName poly_id
+              sig_ctxt = FunSigCtxt name
+        ; spec_ty <- tcHsSigType sig_ctxt hs_ty
+        ; wrap <- tcSubType (SpecPragOrigin name) (SigSkol sig_ctxt)
+                            (idType poly_id) spec_ty
+        ; return (SpecPrag wrap inl) }
   where
     spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
 tcSpecPrag _ sig = pprPanic "tcSpecPrag" (ppr sig)
 
-
 --------------
 -- If typechecking the binds fails, then return with each
 -- signature-less binder given type (forall a.a), to minimise 
 -- subsequent error messages
-recoveryCode :: [Name] -> (Name -> Maybe [Name])
-             -> TcM (LHsBinds TcId, [Id])
+recoveryCode :: [Name] -> SigFun -> TcM (LHsBinds TcId, [Id])
 recoveryCode binder_names sig_fn
-  = do  { traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names)
+  = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)
         ; poly_ids <- mapM mk_dummy binder_names
         ; return (emptyBag, poly_ids) }
   where
@@ -540,63 +599,7 @@ recoveryCode binder_names sig_fn
         | otherwise            = return (mkLocalId name forall_a_a)    -- No signature
 
 forall_a_a :: TcType
-forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
-
-
--- Check that non-overloaded unlifted bindings are
---      a) non-recursive,
---      b) not top level, 
---      c) not a multiple-binding group (more or less implied by (a))
-
-checkStrictBinds :: TopLevelFlag -> RecFlag
-                 -> LHsBinds TcId -> [TcType] -> [MonoBindInfo]
-                 -> TcM Bool
-checkStrictBinds top_lvl rec_group mbind mono_tys infos
-  | unlifted || bang_pat
-  = do  { checkTc (isNotTopLevel top_lvl)
-                  (strictBindErr "Top-level" unlifted mbind)
-        ; checkTc (isNonRec rec_group)
-                  (strictBindErr "Recursive" unlifted mbind)
-        ; checkTc (isSingletonBag mbind)
-                  (strictBindErr "Multiple" unlifted mbind) 
-        -- This should be a checkTc, not a warnTc, but as of GHC 6.11
-        -- the versions of alex and happy available have non-conforming
-        -- templates, so the GHC build fails if it's an error:
-        ; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings
-        ; warnTc (warnUnlifted && not bang_pat)
-                 (unliftedMustBeBang mbind)
-        ; mapM_ check_sig infos
-        ; return True }
-  | otherwise
-  = return False
-  where
-    unlifted = any isUnLiftedType mono_tys
-    bang_pat = anyBag (isBangHsBind . unLoc) mbind
-    check_sig (_, Just sig, _) = checkTc (null (sig_tvs sig) && null (sig_theta sig))
-                                         (badStrictSig unlifted sig)
-    check_sig _                = return ()
-
-unliftedMustBeBang :: LHsBindsLR Var Var -> SDoc
-unliftedMustBeBang mbind
-  = hang (text "Bindings containing unlifted types must use an outermost bang pattern:")
-         4 (pprLHsBinds mbind)
- $$ text "*** This will be an error in GHC 7.2! Fix your code now!"
-
-strictBindErr :: String -> Bool -> LHsBindsLR Var Var -> SDoc
-strictBindErr flavour unlifted mbind
-  = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) 
-         4 (pprLHsBinds mbind)
-  where
-    msg | unlifted  = ptext (sLit "bindings for unlifted types")
-        | otherwise = ptext (sLit "bang-pattern bindings")
-
-badStrictSig :: Bool -> TcSigInfo -> SDoc
-badStrictSig unlifted sig
-  = hang (ptext (sLit "Illegal polymorphic signature in") <+> msg)
-         4 (ppr sig)
-  where
-    msg | unlifted  = ptext (sLit "an unlifted binding")
-        | otherwise = ptext (sLit "a bang-pattern binding")
+forall_a_a = mkForAllTy openAlphaTyVar (mkTyVarTy openAlphaTyVar)
 \end{code}
 
 
@@ -610,18 +613,20 @@ badStrictSig unlifted sig
 The signatures have been dealt with already.
 
 \begin{code}
-tcMonoBinds :: [LHsBind Name]
-            -> TcSigFun
+tcMonoBinds :: TcSigFun
+            -> Bool	-- True <=> no generalisation will be done for this binding
             -> RecFlag  -- Whether the binding is recursive for typechecking purposes
                         -- i.e. the binders are mentioned in their RHSs, and
                         --      we are not resuced by a type signature
+            -> [LHsBind Name]
             -> TcM (LHsBinds TcId, [MonoBindInfo])
 
-tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
+tcMonoBinds sig_fn no_gen is_rec
+           [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
                                 fun_matches = matches, bind_fvs = fvs })]
-            sig_fn              -- Single function binding,
-            NonRecursive        -- binder isn't mentioned in RHS,
-  | Nothing <- sig_fn name      -- ...with no type signature
+                             -- Single function binding, 
+  | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
+  , Nothing <- sig_fn name   -- ...with no type signature
   =     -- In this very special case we infer the type of the
         -- right hand side first (it may have a higher-rank type)
         -- and *then* make the monomorphic Id for the LHS
@@ -630,69 +635,24 @@ tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
     setSrcSpan b_loc    $
     do  { ((co_fn, matches'), rhs_ty) <- tcInfer (tcMatchesFun name inf matches)
 
-                -- Check for an unboxed tuple type
-                --      f = (# True, False #)
-                -- Zonk first just in case it's hidden inside a meta type variable
-                -- (This shows up as a (more obscure) kind error 
-                --  in the 'otherwise' case of tcMonoBinds.)
-        ; zonked_rhs_ty <- zonkTcType rhs_ty
-        ; checkTc (not (isUnboxedTupleType zonked_rhs_ty))
-                  (unboxedTupleErr name zonked_rhs_ty)
-
-        ; mono_name <- newLocalName name
-        ; let mono_id = mkLocalId mono_name zonked_rhs_ty
+        ; mono_id <- newLetBndr no_gen name rhs_ty
         ; return (unitBag (L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
                                               fun_matches = matches', bind_fvs = fvs,
                                               fun_co_fn = co_fn, fun_tick = Nothing })),
                   [(name, Nothing, mono_id)]) }
 
-tcMonoBinds [L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf, 
-                                fun_matches = matches })]
-            sig_fn              -- Single function binding
-            _
-  | Just scoped_tvs <- sig_fn name      -- ...with a type signature
-  =     -- When we have a single function binding, with a type signature
-        -- we can (a) use genuine, rigid skolem constants for the type variables
-        --        (b) bring (rigid) scoped type variables into scope
-    setSrcSpan b_loc    $
-    do  { tc_sig <- tcInstSig True name
-        ; mono_name <- newLocalName name
-        ; let mono_ty = sig_tau tc_sig
-              mono_id = mkLocalId mono_name mono_ty
-              rhs_tvs = [ (name, mkTyVarTy tv)
-                        | (name, tv) <- scoped_tvs `zip` sig_tvs tc_sig ]
-                        -- See Note [More instantiated than scoped]
-                        -- Note that the scoped_tvs and the (sig_tvs sig) 
-                        -- may have different Names. That's quite ok.
-
-	; traceTc (text "tcMoonBinds" <+> ppr scoped_tvs $$ ppr tc_sig)
-        ; (co_fn, matches') <- tcExtendTyVarEnv2 rhs_tvs $
-                               tcMatchesFun mono_name inf matches mono_ty
-	     -- Note that "mono_ty" might actually be a polymorphic type,
-	     -- if the original function had a signature like
-	     --    forall a. Eq a => forall b. Ord b => ....
-	     -- But that's ok: tcMatchesFun can deal with that
-	     -- It happens, too!  See Note [Polymorphic methods] in TcClassDcl.
-
-        ; let fun_bind' = FunBind { fun_id = L nm_loc mono_id, 
-                                    fun_infix = inf, fun_matches = matches',
-                                    bind_fvs = placeHolderNames, fun_co_fn = co_fn, 
-                                    fun_tick = Nothing }
-        ; return (unitBag (L b_loc fun_bind'),
-                  [(name, Just tc_sig, mono_id)]) }
-
-tcMonoBinds binds sig_fn _
-  = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn)) binds
+tcMonoBinds sig_fn no_gen _ binds
+  = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
 
         -- Bring the monomorphic Ids, into scope for the RHSs
         ; let mono_info  = getMonoBindInfo tc_binds
               rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
-                                -- A monomorphic binding for each term variable that lacks 
-                                -- a type sig.  (Ones with a sig are already in scope.)
+                    -- A monomorphic binding for each term variable that lacks 
+                    -- a type sig.  (Ones with a sig are already in scope.)
 
         ; binds' <- tcExtendIdEnv2 rhs_id_env $ do
-                    traceTc (text "tcMonoBinds" <+> vcat [ ppr n <+> ppr id <+> ppr (idType id) 
-                                                         | (n,id) <- rhs_id_env])
+                    traceTc "tcMonoBinds" $  vcat [ ppr n <+> ppr id <+> ppr (idType id) 
+                                                  | (n,id) <- rhs_id_env]
                     mapM (wrapLocM tcRhs) tc_binds
         ; return (listToBag binds', mono_info) }
 
@@ -720,62 +680,46 @@ type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
         -- Type signature (if any), and
         -- the monomorphic bound things
 
-bndrNames :: [MonoBindInfo] -> [Name]
-bndrNames mbi = [n | (n,_,_) <- mbi]
-
 getMonoType :: MonoBindInfo -> TcTauType
 getMonoType (_,_,mono_id) = idType mono_id
 
-tcLhs :: TcSigFun -> HsBind Name -> TcM TcMonoBind
-tcLhs sig_fn (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
-  = do  { mb_sig <- tcInstSig_maybe sig_fn name
-        ; mono_name <- newLocalName name
-        ; mono_ty   <- mk_mono_ty mb_sig
-        ; let mono_id = mkLocalId mono_name mono_ty
+tcLhs :: TcSigFun -> Bool -> HsBind Name -> TcM TcMonoBind
+tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
+  = do  { mono_id <- newLhsBndr mb_sig no_gen name
         ; return (TcFunBind (name, mb_sig, mono_id) (L nm_loc mono_id) inf matches) }
   where
-    mk_mono_ty (Just sig) = return (sig_tau sig)
-    mk_mono_ty Nothing    = newFlexiTyVarTy argTypeKind
-
-tcLhs sig_fn (PatBind { pat_lhs = pat, pat_rhs = grhss })
-  = do  { mb_sigs <- mapM (tcInstSig_maybe sig_fn) names
-        ; mono_pat_binds <- doptM Opt_MonoPatBinds
-                -- With -XMonoPatBinds, we do no generalisation of pattern bindings
-                -- But the signature can still be polymoprhic!
-                --      data T = MkT (forall a. a->a)
-                --      x :: forall a. a->a
-                --      MkT x = <rhs>
-                -- The function get_sig_ty decides whether the pattern-bound variables
-                -- should have exactly the type in the type signature (-XMonoPatBinds), 
-                -- or the instantiated version (-XMonoPatBinds)
-
-        ; let nm_sig_prs  = names `zip` mb_sigs
-              get_sig_ty | mono_pat_binds = idType . sig_id
-                         | otherwise      = sig_tau
-              tau_sig_env = mkNameEnv [ (name, get_sig_ty sig) 
-                                      | (name, Just sig) <- nm_sig_prs]
-              sig_tau_fn  = lookupNameEnv tau_sig_env
-
-              tc_pat exp_ty = tcLetPat sig_tau_fn pat exp_ty $
-                              mapM lookup_info nm_sig_prs
+    mb_sig = sig_fn name 
+
+tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
+  = do  { let tc_pat exp_ty = tcLetPat sig_fn no_gen pat exp_ty $
+                              mapM lookup_info (collectPatBinders pat)
 
                 -- After typechecking the pattern, look up the binder
                 -- names, which the pattern has brought into scope.
-              lookup_info :: (Name, Maybe TcSigInfo) -> TcM MonoBindInfo
-              lookup_info (name, mb_sig) = do { mono_id <- tcLookupId name
-                                              ; return (name, mb_sig, mono_id) }
+              lookup_info :: Name -> TcM MonoBindInfo
+              lookup_info name = do { mono_id <- tcLookupId name
+                                    ; return (name, sig_fn name, mono_id) }
 
         ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
                                      tcInfer tc_pat
 
         ; return (TcPatBind infos pat' grhss pat_ty) }
-  where
-    names = collectPatBinders pat
-
 
-tcLhs _ other_bind = pprPanic "tcLhs" (ppr other_bind)
+tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
         -- AbsBind, VarBind impossible
 
+-----------------
+newLhsBndr :: Maybe TcSigInfo -> Bool -> Name -> TcM TcId
+-- cf TcPat.tcPatBndr (LetPat case)
+newLhsBndr (Just sig) no_gen name
+  | no_gen    = return (sig_id sig)
+  | otherwise = do { mono_name <- newLocalName name
+                   ; return (mkLocalId mono_name (sig_tau sig)) }
+
+newLhsBndr Nothing no_gen name
+  = do { mono_ty <- newFlexiTyVarTy argTypeKind
+       ; newLetBndr no_gen name mono_ty }
+
 -------------------
 tcRhs :: TcMonoBind -> TcM (HsBind TcId)
 -- When we are doing pattern bindings, or multiple function bindings at a time
@@ -785,15 +729,15 @@ tcRhs :: TcMonoBind -> TcM (HsBind TcId)
 tcRhs (TcFunBind (_,_,mono_id) fun' inf matches)
   = do  { (co_fn, matches') <- tcMatchesFun (idName mono_id) inf 
                                             matches (idType mono_id)
-        ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches',
-                            bind_fvs = placeHolderNames, fun_co_fn = co_fn,
-                            fun_tick = Nothing }) }
+        ; return (FunBind { fun_id = fun', fun_infix = inf, fun_matches = matches'
+                          , fun_co_fn = co_fn 
+                          , bind_fvs = placeHolderNames, fun_tick = Nothing }) }
 
 tcRhs (TcPatBind _ pat' grhss pat_ty)
   = do  { grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
                     tcGRHSsPat grhss pat_ty
-        ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty, 
-                            bind_fvs = placeHolderNames }) }
+        ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty 
+                          , bind_fvs = placeHolderNames }) }
 
 
 ---------------------
@@ -812,68 +756,6 @@ getMonoBindInfo tc_binds
 %*                                                                      *
 %************************************************************************
 
-\begin{code}
-generalise :: DynFlags -> TopLevelFlag 
-           -> [LHsBind Name] -> TcSigFun 
-           -> [MonoBindInfo] -> [Inst]
-           -> TcM ([TyVar], [Inst], TcDictBinds)
--- The returned [TyVar] are all ready to quantify
-
-generalise dflags top_lvl bind_list sig_fn mono_infos lie_req
-  | isMonoGroup dflags top_lvl bind_list sigs
-  = do  { extendLIEs lie_req
-        ; return ([], [], emptyBag) }
-
-  | isRestrictedGroup dflags bind_list sig_fn   -- RESTRICTED CASE
-  =     -- Check signature contexts are empty 
-    do  { checkTc (all is_mono_sig sigs)
-                  (restrictedBindCtxtErr bndrs)
-
-        -- Now simplify with exactly that set of tyvars
-        -- We have to squash those Methods
-        ; (qtvs, binds) <- tcSimplifyRestricted doc top_lvl bndrs 
-                                                tau_tvs lie_req
-
-        -- Check that signature type variables are OK
-        ; final_qtvs <- checkSigsTyVars qtvs sigs
-
-        ; return (final_qtvs, [], binds) }
-
-  | null sigs   -- UNRESTRICTED CASE, NO TYPE SIGS
-  = tcSimplifyInfer doc tau_tvs lie_req
-
-  | otherwise   -- UNRESTRICTED CASE, WITH TYPE SIGS
-  = do  { sig_lie <- unifyCtxts sigs    -- sigs is non-empty; sig_lie is zonked
-        ; let   -- The "sig_avails" is the stuff available.  We get that from
-                -- the context of the type signature, BUT ALSO the lie_avail
-                -- so that polymorphic recursion works right (see Note [Polymorphic recursion])
-                local_meths = [mkMethInst sig mono_id | (_, Just sig, mono_id) <- mono_infos]
-                sig_avails = sig_lie ++ local_meths
-                loc = sig_loc (head sigs)
-
-        -- Check that the needed dicts can be
-        -- expressed in terms of the signature ones
-        ; (qtvs, binds) <- tcSimplifyInferCheck loc tau_tvs sig_avails lie_req
-        
-        -- Check that signature type variables are OK
-        ; final_qtvs <- checkSigsTyVars qtvs sigs
-
-        ; return (final_qtvs, sig_lie, binds) }
-  where
-    bndrs   = bndrNames mono_infos
-    sigs    = [sig | (_, Just sig, _) <- mono_infos]
-    get_tvs | isTopLevel top_lvl = tyVarsOfType  -- See Note [Silly type synonym] in TcType
-            | otherwise          = exactTyVarsOfType
-    tau_tvs = foldr (unionVarSet . get_tvs . getMonoType) emptyVarSet mono_infos
-    is_mono_sig sig = null (sig_theta sig)
-    doc = ptext (sLit "type signature(s) for") <+> pprBinders bndrs
-
-    mkMethInst (TcSigInfo { sig_id = poly_id, sig_tvs = tvs, 
-                            sig_theta = theta, sig_loc = loc }) mono_id
-      = Method {tci_id = mono_id, tci_oid = poly_id, tci_tys = mkTyVarTys tvs,
-                tci_theta = theta, tci_loc = loc}
-\end{code}
-
 unifyCtxts checks that all the signature contexts are the same
 The type signatures on a mutually-recursive group of definitions
 must all have the same context (or none).
@@ -887,19 +769,17 @@ We unify them because, with polymorphic recursion, their types
 might not otherwise be related.  This is a rather subtle issue.
 
 \begin{code}
-unifyCtxts :: [TcSigInfo] -> TcM [Inst]
+unifyCtxts :: [TcSigInfo] -> TcM ()
 -- Post-condition: the returned Insts are full zonked
-unifyCtxts [] = panic "unifyCtxts []"
-unifyCtxts (sig1 : sigs)        -- Argument is always non-empty
-  = do  { traceTc $ text "unifyCtxts" <+> ppr (sig1 : sigs)
-	; mapM_ unify_ctxt sigs
-        ; theta <- zonkTcThetaType (sig_theta sig1)
-        ; newDictBndrs (sig_loc sig1) theta }
+unifyCtxts [] = return ()
+unifyCtxts (sig1 : sigs)
+  = do  { traceTc "unifyCtxts" (ppr (sig1 : sigs))
+	; mapM_ unify_ctxt sigs }
   where
     theta1 = sig_theta sig1
     unify_ctxt :: TcSigInfo -> TcM ()
     unify_ctxt sig@(TcSigInfo { sig_theta = theta })
-        = setSrcSpan (instLocSpan (sig_loc sig))        $
+        = setSrcSpan (sig_loc sig)                      $
           addErrCtxt (sigContextsCtxt sig1 sig)         $
           do { cois <- unifyTheta theta1 theta
              ; -- Check whether all coercions are identity coercions
@@ -912,65 +792,6 @@ unifyCtxts (sig1 : sigs)        -- Argument is always non-empty
                checkTc (all isIdentityCoI cois)
                        (ptext (sLit "Mutually dependent functions have syntactically distinct contexts"))
              }
-
-checkSigsTyVars :: [TcTyVar] -> [TcSigInfo] -> TcM [TcTyVar]
-checkSigsTyVars qtvs sigs 
-  = do  { gbl_tvs <- tcGetGlobalTyVars
-        ; sig_tvs_s <- mapM (check_sig gbl_tvs) sigs
-
-        ; let   -- Sigh.  Make sure that all the tyvars in the type sigs
-                -- appear in the returned ty var list, which is what we are
-                -- going to generalise over.  Reason: we occasionally get
-                -- silly types like
-                --      type T a = () -> ()
-                --      f :: T a
-                --      f () = ()
-                -- Here, 'a' won't appear in qtvs, so we have to add it
-                sig_tvs = foldl extendVarSetList emptyVarSet sig_tvs_s
-                all_tvs = varSetElems (extendVarSetList sig_tvs qtvs)
-        ; return all_tvs }
-  where
-    check_sig gbl_tvs (TcSigInfo {sig_id = id, sig_tvs = tvs, 
-                                  sig_theta = theta, sig_tau = tau})
-      = addErrCtxt (ptext (sLit "In the type signature for") <+> quotes (ppr id))       $
-        addErrCtxtM (sigCtxt id tvs theta tau)                                          $
-        do { tvs' <- checkDistinctTyVars tvs
-           ; when (any (`elemVarSet` gbl_tvs) tvs')
-                  (bleatEscapedTvs gbl_tvs tvs tvs')
-           ; return tvs' }
-
-checkDistinctTyVars :: [TcTyVar] -> TcM [TcTyVar]
--- (checkDistinctTyVars tvs) checks that the tvs from one type signature
--- are still all type variables, and all distinct from each other.  
--- It returns a zonked set of type variables.
--- For example, if the type sig is
---      f :: forall a b. a -> b -> b
--- we want to check that 'a' and 'b' haven't 
---      (a) been unified with a non-tyvar type
---      (b) been unified with each other (all distinct)
-
-checkDistinctTyVars sig_tvs
-  = do  { zonked_tvs <- mapM zonkSigTyVar sig_tvs
-        ; foldlM_ check_dup emptyVarEnv (sig_tvs `zip` zonked_tvs)
-        ; return zonked_tvs }
-  where
-    check_dup :: TyVarEnv TcTyVar -> (TcTyVar, TcTyVar) -> TcM (TyVarEnv TcTyVar)
-        -- The TyVarEnv maps each zonked type variable back to its
-        -- corresponding user-written signature type variable
-    check_dup acc (sig_tv, zonked_tv)
-        = case lookupVarEnv acc zonked_tv of
-                Just sig_tv' -> bomb_out sig_tv sig_tv'
-
-                Nothing -> return (extendVarEnv acc zonked_tv sig_tv)
-
-    bomb_out sig_tv1 sig_tv2
-       = do { env0 <- tcInitTidyEnv
-            ; let (env1, tidy_tv1) = tidyOpenTyVar env0 sig_tv1
-                  (env2, tidy_tv2) = tidyOpenTyVar env1 sig_tv2
-                  msg = ptext (sLit "Quantified type variable") <+> quotes (ppr tidy_tv1) 
-                         <+> ptext (sLit "is unified with another quantified type variable") 
-                         <+> quotes (ppr tidy_tv2)
-            ; failWithTcM (env2, msg) }
 \end{code}
 
 
@@ -1128,68 +949,65 @@ but two instantiated type variables, c' and b'.
 We assume that the scoped ones are at the *front* of sig_tvs,
 and remember the names from the original HsForAllTy in the TcSigFun.
 
+Note [Signature skolems]
+~~~~~~~~~~~~~~~~~~~~~~~~
+When instantiating a type signature, we do so with either skolems or
+SigTv meta-type variables depending on the use_skols boolean.  This
+variable is set True when we are typechecking a single function
+binding; and False for pattern bindings and a group of several
+function bindings.
+
+Reason: in the latter cases, the "skolems" can be unified together, 
+        so they aren't properly rigid in the type-refinement sense.
+NB: unless we are doing H98, each function with a sig will be done
+    separately, even if it's mutually recursive, so use_skols will be True
+
+
+Note [Only scoped tyvars are in the TyVarEnv]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We are careful to keep only the *lexically scoped* type variables in
+the type environment.  Why?  After all, the renamer has ensured
+that only legal occurrences occur, so we could put all type variables
+into the type env.
+
+But we want to check that two distinct lexically scoped type variables
+do not map to the same internal type variable.  So we need to know which
+the lexically-scoped ones are... and at the moment we do that by putting
+only the lexically scoped ones into the environment.
+
+Note [Instantiate sig with fresh variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's vital to instantiate a type signature with fresh variables.
+For example:
+      type T = forall a. [a] -> [a]
+      f :: T; 
+      f = g where { g :: T; g = <rhs> }
+
+ We must not use the same 'a' from the defn of T at both places!!
+(Instantiation is only necessary because of type synonyms.  Otherwise,
+it's all cool; each signature has distinct type variables from the renamer.)
 
 \begin{code}
-type TcSigFun = Name -> Maybe [Name]    -- Maps a let-binder to the list of
-                                        -- type variables brought into scope
-                                        -- by its type signature.
-                                        -- Nothing => no type signature
+type SigFun = Name -> Maybe ([Name], SrcSpan)
+         -- Maps a let-binder to the list of
+         -- type variables brought into scope
+         -- by its type signature, plus location
+         -- Nothing => no type signature
 
-mkTcSigFun :: [LSig Name] -> TcSigFun
+mkSigFun :: [LSig Name] -> SigFun
 -- Search for a particular type signature
 -- Precondition: the sigs are all type sigs
 -- Precondition: no duplicates
-mkTcSigFun sigs = lookupNameEnv env
+mkSigFun sigs = lookupNameEnv env
   where
     env = mkNameEnv (mapCatMaybes mk_pair sigs)
-    mk_pair (L _ (TypeSig (L _ name) lhs_ty)) = Just (name, hsExplicitTvs lhs_ty)
-    mk_pair (L _ (IdSig id))                  = Just (idName id, [])
-    mk_pair _                                 = Nothing    
+    mk_pair (L loc (TypeSig (L _ name) lhs_ty)) = Just (name, (hsExplicitTvs lhs_ty, loc))
+    mk_pair (L loc (IdSig id))                  = Just (idName id, ([], loc))
+    mk_pair _                                   = Nothing    
         -- The scoped names are the ones explicitly mentioned
         -- in the HsForAll.  (There may be more in sigma_ty, because
         -- of nested type synonyms.  See Note [More instantiated than scoped].)
         -- See Note [Only scoped tyvars are in the TyVarEnv]
-
----------------
-data TcSigInfo
-  = TcSigInfo {
-        sig_id     :: TcId,             --  *Polymorphic* binder for this value...
-
-        sig_tvs    :: [TcTyVar],        -- Instantiated type variables
-                                        -- See Note [Instantiate sig]
-
-        sig_theta  :: TcThetaType,      -- Instantiated theta
-        sig_tau    :: TcTauType,        -- Instantiated tau
-        sig_loc    :: InstLoc           -- The location of the signature
-    }
-
-
---      Note [Only scoped tyvars are in the TyVarEnv]
--- We are careful to keep only the *lexically scoped* type variables in
--- the type environment.  Why?  After all, the renamer has ensured
--- that only legal occurrences occur, so we could put all type variables
--- into the type env.
---
--- But we want to check that two distinct lexically scoped type variables
--- do not map to the same internal type variable.  So we need to know which
--- the lexically-scoped ones are... and at the moment we do that by putting
--- only the lexically scoped ones into the environment.
-
-
---      Note [Instantiate sig]
--- It's vital to instantiate a type signature with fresh variables.
--- For example:
---      type S = forall a. a->a
---      f,g :: S
---      f = ...
---      g = ...
--- Here, we must use distinct type variables when checking f,g's right hand sides.
--- (Instantiation is only necessary because of type synonyms.  Otherwise,
--- it's all cool; each signature has distinct type variables from the renamer.)
-
-instance Outputable TcSigInfo where
-    ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
-        = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> ppr theta <+> ptext (sLit "=>") <+> ppr tau
 \end{code}
 
 \begin{code}
@@ -1203,77 +1021,137 @@ tcTySig (L _ (IdSig id))
 tcTySig s = pprPanic "tcTySig" (ppr s)
 
 -------------------
-tcInstSig_maybe :: TcSigFun -> Name -> TcM (Maybe TcSigInfo)
--- Instantiate with *meta* type variables; 
--- this signature is part of a multi-signature group
-tcInstSig_maybe sig_fn name 
-  = case sig_fn name of
-        Nothing -> return Nothing
-        Just _scoped_tvs -> do   { tc_sig <- tcInstSig False name
-                                 ; return (Just tc_sig) }
-        -- NB: the _scoped_tvs may be non-empty, but we can 
-        -- just ignore them.  See Note [Scoped tyvars].
-
-tcInstSig :: Bool -> Name -> TcM TcSigInfo
--- Instantiate the signature, with either skolems or meta-type variables
--- depending on the use_skols boolean.  This variable is set True
--- when we are typechecking a single function binding; and False for
--- pattern bindings and a group of several function bindings.
--- Reason: in the latter cases, the "skolems" can be unified together, 
---         so they aren't properly rigid in the type-refinement sense.
--- NB: unless we are doing H98, each function with a sig will be done
---     separately, even if it's mutually recursive, so use_skols will be True
---
--- We always instantiate with fresh uniques,
--- although we keep the same print-name
---      
---      type T = forall a. [a] -> [a]
---      f :: T; 
---      f = g where { g :: T; g = <rhs> }
+tcInstSigs :: SigFun -> [Name] -> TcM TcSigFun
+tcInstSigs sig_fn bndrs
+  = do { prs <- mapMaybeM (tcInstSig sig_fn use_skols) bndrs
+       ; return (lookupNameEnv (mkNameEnv prs)) }
+  where
+    use_skols = isSingleton bndrs	-- See Note [Signature skolems]
+
+tcInstSig :: SigFun -> Bool -> Name -> TcM (Maybe (Name, TcSigInfo))
+-- For use_skols :: Bool see Note [Signature skolems]
 --
--- We must not use the same 'a' from the defn of T at both places!!
+-- We must instantiate with fresh uniques, 
+-- (see Note [Instantiate sig with fresh variables])
+-- although we keep the same print-name.
 
-tcInstSig use_skols name
+tcInstSig sig_fn use_skols name
+  | Just (scoped_tvs, loc) <- sig_fn name
   = do  { poly_id <- tcLookupId name    -- Cannot fail; the poly ids are put into 
                                         -- scope when starting the binding group
-	; let skol_info = SigSkol (FunSigCtxt name)
-        ; (tvs, theta, tau) <- tcInstSigType use_skols skol_info (idType poly_id)
-        ; loc <- getInstLoc (SigOrigin skol_info)
-        ; return (TcSigInfo { sig_id = poly_id,
-                              sig_tvs = tvs, sig_theta = theta, sig_tau = tau, 
-                              sig_loc = loc }) }
-
--------------------
-isMonoGroup :: DynFlags -> TopLevelFlag -> [LHsBind Name]
-            -> [TcSigInfo] ->  Bool
--- No generalisation at all
-isMonoGroup dflags top_lvl binds sigs
-  =  (dopt Opt_MonoPatBinds dflags && any is_pat_bind binds)
-  || (dopt Opt_MonoLocalBinds dflags && null sigs && not (isTopLevel top_lvl))
+        ; (tvs, theta, tau) <- tcInstSigType use_skols name (idType poly_id)
+        ; let sig = TcSigInfo { sig_id = poly_id
+	  	 	      , sig_scoped = scoped_tvs
+                              , sig_tvs = tvs, sig_theta = theta, sig_tau = tau
+                              , sig_loc = loc }
+        ; return (Just (name, sig)) } 
+  | otherwise
+  = return Nothing
+
+-------------------------------
+data GeneralisationPlan 
+  = NoGen		-- No generalisation, no AbsBinds
+  | InferGen Bool	-- Implicit generalisation; there is an AbsBinds
+    	     		--   True <=> apply the MR; generalise only unconstrained type vars
+  | CheckGen TcSigInfo	-- Explicit generalisation; there is an AbsBinds
+
+-- A consequence of the no-AbsBinds choice (NoGen) is that there is
+-- no "polymorphic Id" and "monmomorphic Id"; there is just the one
+
+instance Outputable GeneralisationPlan where
+  ppr NoGen        = ptext (sLit "NoGen")
+  ppr (InferGen b) = ptext (sLit "InferGen") <+> ppr b
+  ppr (CheckGen s) = ptext (sLit "CheckGen") <+> ppr s
+
+decideGeneralisationPlan 
+   :: DynFlags -> TopLevelFlag -> [Name] -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
+decideGeneralisationPlan dflags top_lvl _bndrs binds sig_fn
+  | mono_pat_binds                         = NoGen
+  | Just sig <- one_funbind_with_sig binds = if null (sig_tvs sig) && null (sig_theta sig)
+                                             then NoGen	      -- Optimise common case
+                                             else CheckGen sig
+  | (dopt Opt_MonoLocalBinds dflags 
+      && isNotTopLevel top_lvl)      	   = NoGen
+  | otherwise                              = InferGen mono_restriction
+
+--  | all no_sig bndrs    	     	   = InferGen mono_restriction
+--  | otherwise            	     	   = NoGen   -- A mixture of function 
+--    				       		     -- and pattern bindings
   where
-    is_pat_bind (L _ (PatBind {})) = True
-    is_pat_bind _                  = False
+    mono_pat_binds = dopt Opt_MonoPatBinds dflags 
+                  && any (is_pat_bind . unLoc) binds
 
--------------------
-isRestrictedGroup :: DynFlags -> [LHsBind Name] -> TcSigFun -> Bool
-isRestrictedGroup dflags binds sig_fn
-  = mono_restriction && not all_unrestricted
-  where 
-    mono_restriction = dopt Opt_MonomorphismRestriction dflags
-    all_unrestricted = all (unrestricted . unLoc) binds
-    has_sig n = isJust (sig_fn n)
-
-    unrestricted (PatBind {})                                    = False
-    unrestricted (VarBind { var_id = v })                        = has_sig v
-    unrestricted (FunBind { fun_id = v, fun_matches = matches }) = unrestricted_match matches 
-                                                                 || has_sig (unLoc v)
-    unrestricted (AbsBinds {})
-        = panic "isRestrictedGroup/unrestricted AbsBinds"
-
-    unrestricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = False
+    mono_restriction = dopt Opt_MonomorphismRestriction dflags 
+                    && any (restricted . unLoc) binds
+
+    no_sig n = isNothing (sig_fn n)
+
+    -- With OutsideIn, all nested bindings are monomorphic
+    -- except a single function binding with a signature
+    one_funbind_with_sig [L _ FunBind { fun_id = v }] = sig_fn (unLoc v)
+    one_funbind_with_sig _                            = Nothing
+
+    -- The Haskell 98 monomorphism resetriction
+    restricted (PatBind {})                              = True
+    restricted (VarBind { var_id = v })                  = no_sig v
+    restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m
+                                                           && no_sig (unLoc v)
+    restricted (AbsBinds {}) = panic "isRestrictedGroup/unrestricted AbsBinds"
+
+    restricted_match (MatchGroup (L _ (Match [] _ _) : _) _) = True
+    restricted_match _                                       = False
         -- No args => like a pattern binding
-    unrestricted_match _                                       = True
         -- Some args => a function binding
+
+    is_pat_bind (PatBind {}) = True
+    is_pat_bind _            = False
+
+-------------------
+checkStrictBinds :: TopLevelFlag -> RecFlag
+                 -> [LHsBind Name] -> [Id]
+                 -> TcM ()
+-- Check that non-overloaded unlifted bindings are
+--      a) non-recursive,
+--      b) not top level, 
+--      c) not a multiple-binding group (more or less implied by (a))
+
+checkStrictBinds top_lvl rec_group binds poly_ids
+  | unlifted || bang_pat
+  = do  { checkTc (isNotTopLevel top_lvl)
+                  (strictBindErr "Top-level" unlifted binds)
+        ; checkTc (isNonRec rec_group)
+                  (strictBindErr "Recursive" unlifted binds)
+        ; checkTc (isSingleton binds)
+                  (strictBindErr "Multiple" unlifted binds) 
+        -- This should be a checkTc, not a warnTc, but as of GHC 6.11
+        -- the versions of alex and happy available have non-conforming
+        -- templates, so the GHC build fails if it's an error:
+        ; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings
+        ; warnTc (warnUnlifted && not bang_pat)
+                 (unliftedMustBeBang binds) }
+  | otherwise
+  = return ()
+  where
+    unlifted = any is_unlifted poly_ids
+    bang_pat = any (isBangHsBind . unLoc) binds
+    is_unlifted id = case tcSplitForAllTys (idType id) of
+                       (_, rho) -> isUnLiftedType rho
+
+unliftedMustBeBang :: [LHsBind Name] -> SDoc
+unliftedMustBeBang binds
+  = hang (text "Bindings containing unlifted types should use an outermost bang pattern:")
+       2 (pprBindList binds)
+
+strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
+strictBindErr flavour unlifted binds
+  = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) 
+       2 (pprBindList binds)
+  where
+    msg | unlifted  = ptext (sLit "bindings for unlifted types")
+        | otherwise = ptext (sLit "bang-pattern bindings")
+
+pprBindList :: [LHsBind Name] -> SDoc
+pprBindList binds = vcat (map ppr binds)
 \end{code}
 
 
@@ -1289,7 +1167,7 @@ isRestrictedGroup dflags binds sig_fn
 -- and on RHS, when pat is TcId and grhss is still Name
 patMonoBindsCtxt :: OutputableBndr id => LPat id -> GRHSs Name -> SDoc
 patMonoBindsCtxt pat grhss
-  = hang (ptext (sLit "In a pattern binding:")) 4 (pprPatBind pat grhss)
+  = hang (ptext (sLit "In a pattern binding:")) 2 (pprPatBind pat grhss)
 
 -----------------------------------------------
 sigContextsCtxt :: TcSigInfo -> TcSigInfo -> SDoc
@@ -1302,31 +1180,34 @@ sigContextsCtxt sig1 sig2
     id1 = sig_id sig1
     id2 = sig_id sig2
 
-
 -----------------------------------------------
-unboxedTupleErr :: Name -> Type -> SDoc
-unboxedTupleErr name ty
-  = hang (ptext (sLit "Illegal binding of unboxed tuple"))
-         4 (ppr name <+> dcolon <+> ppr ty)
+{- 
+badStrictSig :: Bool -> TcSigInfo -> SDoc
+badStrictSig unlifted sig
+  = hang (ptext (sLit "Illegal polymorphic signature in") <+> msg)
+       2 (ppr sig)
+  where
+    msg | unlifted  = ptext (sLit "an unlifted binding")
+        | otherwise = ptext (sLit "a bang-pattern binding")
 
------------------------------------------------
-restrictedBindCtxtErr :: [Name] -> SDoc
-restrictedBindCtxtErr binder_names
-  = hang (ptext (sLit "Illegal overloaded type signature(s)"))
-       4 (vcat [ptext (sLit "in a binding group for") <+> pprBinders binder_names,
+restrictedBindSigErr :: [Name] -> SDoc
+restrictedBindSigErr binder_names
+  = hang (ptext (sLit "Illegal type signature(s)"))
+       2 (vcat [ptext (sLit "in a binding group for") <+> pprBinders binder_names,
                 ptext (sLit "that falls under the monomorphism restriction")])
 
 genCtxt :: [Name] -> SDoc
 genCtxt binder_names
   = ptext (sLit "When generalising the type(s) for") <+> pprBinders binder_names
+-}
 
-missingSigWarn :: Bool -> Name -> Type -> TcM ()
-missingSigWarn False _    _  = return ()
-missingSigWarn True  name ty
+missingSigWarn :: TcId -> TcM ()
+missingSigWarn id
   = do  { env0 <- tcInitTidyEnv
-        ; let (env1, tidy_ty) = tidyOpenType env0 ty
+        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)
         ; addWarnTcM (env1, mk_msg tidy_ty) }
   where
+    name = idName id
     mk_msg ty = vcat [ptext (sLit "Definition but no type signature for") <+> quotes (ppr name),
                       sep [ptext (sLit "Inferred type:") <+> pprHsVar name <+> dcolon <+> ppr ty]]
 \end{code}
diff --git a/compiler/typecheck/TcCanonical.lhs b/compiler/typecheck/TcCanonical.lhs
new file mode 100644
index 0000000..e0c8520
--- /dev/null
+++ b/compiler/typecheck/TcCanonical.lhs
@@ -0,0 +1,701 @@
+\begin{code}
+module TcCanonical(
+    mkCanonical, mkCanonicals, canWanteds, canGivens, canOccursCheck 
+ ) where
+
+#include "HsVersions.h"
+
+import BasicTypes 
+import Type
+import TcRnTypes
+
+import TcType
+import TcErrors
+import Coercion
+import Class
+import TyCon
+import TypeRep
+import Name
+import Var
+import Outputable
+import Control.Monad    ( when, zipWithM )
+import MonadUtils
+import Control.Applicative ( (<|>) )
+
+import VarSet
+import Bag
+
+import Control.Monad  ( unless )
+import TcSMonad  -- The TcS Monad 
+\end{code}
+
+Note [Canonicalisation]
+~~~~~~~~~~~~~~~~~~~~~~~
+* Converts (Constraint f) _which_does_not_contain_proper_implications_ to CanonicalCts
+* Unary: treats individual constraints one at a time
+* Does not do any zonking
+* Lives in TcS monad so that it can create new skolem variables
+
+
+%************************************************************************
+%*                                                                      *
+%*        Flattening (eliminating all function symbols)                 *
+%*                                                                      *
+%************************************************************************
+
+Note [Flattening]
+~~~~~~~~~~~~~~~~~~~~
+  flatten ty  ==>   (xi, cc)
+    where
+      xi has no type functions
+      cc = Auxiliary given (equality) constraints constraining
+           the fresh type variables in xi.  Evidence for these 
+           is always the identity coercion, because internally the
+           fresh flattening skolem variables are actually identified
+           with the types they have been generated to stand in for.
+
+Note that it is flatten's job to flatten *every type function it sees*.
+flatten is only called on *arguments* to type functions, by canEqGiven.
+
+Recall that in comments we use alpha[flat = ty] to represent a
+flattening skolem variable alpha which has been generated to stand in
+for ty.
+
+----- Example of flattening a constraint: ------
+  flatten (List (F (G Int)))  ==>  (xi, cc)
+    where
+      xi  = List alpha
+      cc  = { G Int ~ beta[flat = G Int],
+              F beta ~ alpha[flat = F beta] }
+Here
+  * alpha and beta are 'flattening skolem variables'.
+  * All the constraints in cc are 'given', and all their coercion terms 
+    are the identity.
+
+NB: Flattening Skolems only occur in canonical constraints, which
+are never zonked, so we don't need to worry about zonking doing
+accidental unflattening.
+
+NB: Note that (unlike the OutsideIn(X) draft of 7 May 2010) we are
+actually doing the SAME thing here no matter whether we are flattening
+a wanted or a given constraint.  In both cases we simply generate some
+flattening skolem variables and some extra given constraints; we never
+generate actual unification variables or non-identity coercions.
+Hopefully this will work, although SPJ had some vague worries about
+unification variables from wanted constraints finding their way into
+the generated given constraints...?
+
+Note that we prefer to leave type synonyms unexpanded when possible,
+so when the flattener encounters one, it first asks whether its
+transitive expansion contains any type function applications.  If so,
+it expands the synonym and proceeds; if not, it simply returns the
+unexpanded synonym.
+
+TODO: caching the information about whether transitive synonym
+expansions contain any type function applications would speed things
+up a bit; right now we waste a lot of energy traversing the same types
+multiple times.
+
+\begin{code}
+-- Flatten a bunch of types all at once.
+flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], CanonicalCts)
+flattenMany ctxt tys 
+  = do { (xis, cts_s) <- mapAndUnzipM (flatten ctxt) tys
+       ; return (xis, andCCans cts_s) }
+
+-- Flatten a type to get rid of type function applications, returning
+-- the new type-function-free type, and a collection of new equality
+-- constraints.  See Note [Flattening] for more detail.  This needs to
+-- be in the TcS monad so we can generate new flattening skolem
+-- variables.
+flatten :: CtFlavor -> TcType -> TcS (Xi, CanonicalCts)
+
+flatten ctxt ty 
+  | Just ty' <- tcView ty
+  = do { (xi, ccs) <- flatten ctxt ty'
+	-- Preserve type synonyms if possible
+	-- We can tell if t' is function-free by
+	-- whether there are any floated constraints
+       ; if isEmptyCCan ccs then
+             return (ty, emptyCCan)  
+         else
+             return (xi, ccs) }
+
+flatten _ v@(TyVarTy _)
+  = return (v, emptyCCan)
+
+flatten ctxt (AppTy ty1 ty2)
+  = do { (xi1,c1) <- flatten ctxt ty1
+       ; (xi2,c2) <- flatten ctxt ty2
+       ; return (mkAppTy xi1 xi2, c1 `andCCan` c2) }
+
+flatten ctxt (FunTy ty1 ty2)
+  = do { (xi1,c1) <- flatten ctxt ty1
+       ; (xi2,c2) <- flatten ctxt ty2
+       ; return (mkFunTy xi1 xi2, c1 `andCCan` c2) }
+
+flatten fl (TyConApp tc tys)
+  -- For a normal type constructor or data family application, we just
+  -- recursively flatten the arguments.
+  | not (isSynFamilyTyCon tc)
+    = do { (xis,ccs) <- flattenMany fl tys
+         ; return (mkTyConApp tc xis, ccs) }
+
+  -- Otherwise, it's a type function application, and we have to
+  -- flatten it away as well, and generate a new given equality constraint
+  -- between the application and a newly generated flattening skolem variable.
+  | otherwise
+    = ASSERT( tyConArity tc <= length tys )	-- Type functions are saturated
+      do { (xis, ccs) <- flattenMany fl tys
+         ; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis
+	       	 -- The type function might be *over* saturated
+		 -- in which case the remaining arguments should
+		 -- be dealt with by AppTys
+               fam_ty = mkTyConApp tc xi_args 
+               fam_co = fam_ty -- identity 
+
+         ; xi_skol <- newFlattenSkolemTy fam_ty
+         ; cv <- newGivOrDerCoVar fam_ty xi_skol fam_co 
+
+         ; let ceq_given = CFunEqCan { cc_id     = cv 
+                                     , cc_flavor = mkGivenFlavor fl UnkSkol
+                                     , cc_fun    = tc 
+                                     , cc_tyargs = xi_args 
+                                     , cc_rhs    = xi_skol
+                                     }
+                 -- ceq_given : F xi_args ~ xi_skol
+
+         ; return ( foldl AppTy xi_skol xi_rest
+                  , ccs `extendCCans` ceq_given) }
+
+flatten ctxt (PredTy pred) 
+  = do { (pred',ccs) <- flattenPred ctxt pred
+       ; return (PredTy pred', ccs) }
+
+flatten ctxt ty@(ForAllTy {})
+-- We allow for-alls when, but only when, no type function
+-- applications inside the forall involve the bound type variables
+  = do { let (tvs, rho) = splitForAllTys ty
+       ; (rho', ccs) <- flatten ctxt rho
+       ; let bad_eqs  = filterBag is_bad ccs
+             is_bad c = tyVarsOfCanonical c `intersectsVarSet` tv_set
+             tv_set   = mkVarSet tvs
+       ; unless (isEmptyBag bad_eqs)
+                (flattenForAllErrorTcS ctxt ty bad_eqs)
+       ; return (mkForAllTys tvs rho', ccs)  }
+
+---------------
+flattenPred :: CtFlavor -> TcPredType -> TcS (TcPredType, CanonicalCts)
+flattenPred ctxt (ClassP cls tys)
+  = do { (tys', ccs) <- flattenMany ctxt tys
+       ; return (ClassP cls tys', ccs) }
+flattenPred ctxt (IParam nm ty)
+  = do { (ty', ccs) <- flatten ctxt ty
+       ; return (IParam nm ty', ccs) }
+flattenPred ctxt (EqPred ty1 ty2)
+  = do { (ty1', ccs1) <- flatten ctxt ty1
+       ; (ty2', ccs2) <- flatten ctxt ty2
+       ; return (EqPred ty1' ty2', ccs1 `andCCan` ccs2) }
+\end{code}
+
+%************************************************************************
+%*                                                                      *
+%*                Canonicalising given constraints                      *
+%*                                                                      *
+%************************************************************************
+
+\begin{code}
+canWanteds :: [WantedEvVar] -> TcS CanonicalCts 
+canWanteds = fmap andCCans . mapM (\(WantedEvVar ev loc) -> mkCanonical (Wanted loc) ev)
+
+canGivens :: GivenLoc -> [EvVar] -> TcS CanonicalCts
+canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc)) givens
+                          ; return (andCCans ccs) }
+
+mkCanonicals :: CtFlavor -> [EvVar] -> TcS CanonicalCts 
+mkCanonicals fl vs = fmap andCCans (mapM (mkCanonical fl) vs)
+
+mkCanonical :: CtFlavor -> EvVar -> TcS CanonicalCts 
+mkCanonical fl ev = case evVarPred ev of 
+                        ClassP clas tys -> canClass fl ev clas tys 
+                        IParam ip ty    -> canIP    fl ev ip ty
+                        EqPred ty1 ty2  -> canEq    fl ev ty1 ty2 
+                         
+
+canClass :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS CanonicalCts 
+canClass fl v cn tys 
+  = do { (xis,ccs) <- flattenMany fl tys 
+       ; return $ ccs `extendCCans` CDictCan { cc_id = v 
+                                             , cc_flavor = fl 
+                                             , cc_class = cn 
+                                             , cc_tyargs = xis } }
+canIP :: CtFlavor -> EvVar -> IPName Name -> TcType -> TcS CanonicalCts 
+canIP fl v nm ty 
+  = return $ singleCCan $ CIPCan { cc_id = v
+                                 , cc_flavor = fl
+                                 , cc_ip_nm = nm
+                                 , cc_ip_ty = ty } 
+
+
+-----------------
+canEq :: CtFlavor -> EvVar -> Type -> Type -> TcS CanonicalCts 
+canEq fl cv ty1 ty2 
+  | tcEqType ty1 ty2	-- Dealing with equality here avoids
+    	     	 	-- later spurious occurs checks for a~a
+  = do { when (isWanted fl) (setWantedCoBind cv ty1)
+       ; return emptyCCan }
+
+-- If one side is a variable, orient and flatten, 
+-- WITHOUT expanding type synonyms, so that we tend to 
+-- substitute a~Age rather than a~Int when type Age=Ing
+canEq fl cv (TyVarTy tv1) ty2 = canEqLeaf fl cv (VarCls tv1) (classify ty2)
+canEq fl cv ty1 (TyVarTy tv2) = canEqLeaf fl cv (classify ty1) (VarCls tv2)
+
+canEq fl cv (TyConApp fn tys) ty2 
+  | isSynFamilyTyCon fn, length tys == tyConArity fn
+  = canEqLeaf fl cv (FunCls fn tys) (classify ty2)
+canEq fl cv ty1 (TyConApp fn tys)
+  | isSynFamilyTyCon fn, length tys == tyConArity fn
+  = canEqLeaf fl cv (classify ty1) (FunCls fn tys) 
+
+-- Split up an equality between function types into two equalities.
+canEq fl cv (FunTy s1 t1) (FunTy s2 t2)
+  = do { (argv, resv) <- 
+             if isWanted fl then 
+                 do { argv <- newWantedCoVar s1 s2 
+                    ; resv <- newWantedCoVar t1 t2 
+                    ; setWantedCoBind cv $ 
+                      mkFunCoercion (mkCoVarCoercion argv) (mkCoVarCoercion resv) 
+                    ; return (argv,resv) } 
+             else let [arg,res] = decomposeCo 2 (mkCoVarCoercion cv) 
+                  in do { argv <- newGivOrDerCoVar s1 s2 arg 
+                        ; resv <- newGivOrDerCoVar t1 t2 res
+                        ; return (argv,resv) } 
+       ; cc1 <- canEq fl argv s1 s2 -- inherit original kinds and locations
+       ; cc2 <- canEq fl resv t1 t2
+       ; return (cc1 `andCCan` cc2) }
+
+
+canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2) 
+  | isAlgTyCon tc1 && isAlgTyCon tc2
+  , tc1 == tc2
+  , length tys1 == length tys2
+  = -- Generate equalities for each of the corresponding arguments
+    do { argsv <- if isWanted fl then
+                    do { argsv <- zipWithM newWantedCoVar tys1 tys2
+                            ; setWantedCoBind cv $ mkTyConCoercion tc1 (map mkCoVarCoercion argsv)
+                            ; return argsv } 
+                  else 
+                    let cos = decomposeCo (length tys1) (mkCoVarCoercion cv) 
+                    in zipWith3M newGivOrDerCoVar tys1 tys2 cos
+       ; andCCans <$> zipWith3M (canEq fl) argsv tys1 tys2 }
+
+-- See Note [Equality between type applications]
+--     Note [Care with type applications] in TcUnify
+canEq fl cv ty1 ty2
+  | Just (s1,t1) <- tcSplitAppTy_maybe ty1
+  , Just (s2,t2) <- tcSplitAppTy_maybe ty2
+    = do { (cv1,cv2) <- 
+             if isWanted fl 
+             then do { cv1 <- newWantedCoVar s1 s2 
+                     ; cv2 <- newWantedCoVar t1 t2 
+                     ; setWantedCoBind cv $ 
+                       mkAppCoercion (mkCoVarCoercion cv1) (mkCoVarCoercion cv2) 
+                     ; return (cv1,cv2) } 
+             else let co1 = mkLeftCoercion  $ mkCoVarCoercion cv 
+                      co2 = mkRightCoercion $ mkCoVarCoercion cv
+                  in do { cv1 <- newGivOrDerCoVar s1 s2 co1 
+                        ; cv2 <- newGivOrDerCoVar t1 t2 co2 
+                        ; return (cv1,cv2) } 
+         ; cc1 <- canEq fl cv1 s1 s2 
+         ; cc2 <- canEq fl cv2 t1 t2 
+         ; return (cc1 `andCCan` cc2) } 
+
+canEq fl _ s1@(ForAllTy {}) s2@(ForAllTy {}) 
+ | Wanted {} <- fl 
+ = misMatchErrorTcS fl s1 s2
+ | otherwise 
+ = do { traceTcS "Ommitting decomposition of given polytype equality" (pprEq s1 s2)
+      ; return emptyCCan }
+
+-- Finally expand any type synonym applications.
+canEq fl cv ty1 ty2 | Just ty1' <- tcView ty1 = canEq fl cv ty1' ty2
+canEq fl cv ty1 ty2 | Just ty2' <- tcView ty2 = canEq fl cv ty1 ty2'
+
+canEq fl _ ty1 ty2 
+  = misMatchErrorTcS fl ty1 ty2
+\end{code}
+
+Note [Equality between type applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If we see an equality of the form s1 t1 ~ s2 t2 we can always split
+it up into s1 ~ s2 /\ t1 ~ t2, since s1 and s2 can't be type
+functions (type functions use the TyConApp constructor, which never
+shows up as the LHS of an AppTy).  Other than type functions, types
+in Haskell are always 
+
+  (1) generative: a b ~ c d implies a ~ c, since different type
+      constructors always generate distinct types
+
+  (2) injective: a b ~ a d implies b ~ d; we never generate the
+      same type from different type arguments.
+
+
+Note [Kinding] 
+~~~~~~~~~~~~~~
+The canonicalizer assumes that it's provided with well-kinded equalities
+as wanted or given, that is LHS kind and the RHS kind agree, modulo subkinding.
+
+Both canonicalization and interaction solving must preserve this invariant. 
+DV: TODO TODO: Check! 
+
+Note [Canonical ordering for equality constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Implemented as (<+=) below:
+
+  - Type function applications always come before anything else.  
+  - Variables always come before non-variables (other than type
+      function applications).
+
+Note that we don't need to unfold type synonyms on the RHS to check
+the ordering; that is, in the rules above it's OK to consider only
+whether something is *syntactically* a type function application or
+not.  To illustrate why this is OK, suppose we have an equality of the
+form 'tv ~ S a b c', where S is a type synonym which expands to a
+top-level application of the type function F, something like
+
+  type S a b c = F d e
+
+Then to canonicalize 'tv ~ S a b c' we flatten the RHS, and since S's
+expansion contains type function applications the flattener will do
+the expansion and then generate a skolem variable for the type
+function application, so we end up with something like this:
+
+  tv ~ x
+  F d e ~ x
+
+where x is the skolem variable.  This is one extra equation than
+absolutely necessary (we could have gotten away with just 'F d e ~ tv'
+if we had noticed that S expanded to a top-level type function
+application and flipped it around in the first place) but this way
+keeps the code simpler.
+
+Unlike the OutsideIn(X) draft of May 7, 2010, we do not care about the
+ordering of tv ~ tv constraints.  There are several reasons why we
+might:
+
+  (1) In order to be able to extract a substitution that doesn't
+      mention untouchable variables after we are done solving, we might
+      prefer to put touchable variables on the left. However, in and
+      of itself this isn't necessary; we can always re-orient equality
+      constraints at the end if necessary when extracting a substitution.
+
+  (2) To ensure termination we might think it necessary to put
+      variables in lexicographic order. However, this isn't actually 
+      necessary as outlined below.
+
+While building up an inert set of canonical constraints, we maintain
+the invariant that the equality constraints in the inert set form an
+acyclic rewrite system when viewed as L-R rewrite rules.  Moreover,
+the given constraints form an idempotent substitution (i.e. none of
+the variables on the LHS occur in any of the RHS's, and type functions
+never show up in the RHS at all), the wanted constraints also form an
+idempotent substitution, and finally the LHS of a given constraint
+never shows up on the RHS of a wanted constraint.  There may, however,
+be a wanted LHS that shows up in a given RHS, since we do not rewrite
+given constraints with wanted constraints.
+
+Suppose we have an inert constraint set
+
+
+  tg_1 ~ xig_1         -- givens
+  tg_2 ~ xig_2
+  ...
+  tw_1 ~ xiw_1         -- wanteds
+  tw_2 ~ xiw_2
+  ...
+
+where each t_i can be either a type variable or a type function
+application. Now suppose we take a new canonical equality constraint,
+t' ~ xi' (note among other things this means t' does not occur in xi')
+and try to react it with the existing inert set.  We show by induction
+on the number of t_i which occur in t' ~ xi' that this process will
+terminate.
+
+There are several ways t' ~ xi' could react with an existing constraint:
+
+TODO: finish this proof.  The below was for the case where the entire
+inert set is an idempotent subustitution...
+
+(b) We could have t' = t_j for some j.  Then we obtain the new
+    equality xi_j ~ xi'; note that neither xi_j or xi' contain t_j.  We
+    now canonicalize the new equality, which may involve decomposing it
+    into several canonical equalities, and recurse on these.  However,
+    none of the new equalities will contain t_j, so they have fewer
+    occurrences of the t_i than the original equation.
+
+(a) We could have t_j occurring in xi' for some j, with t' /=
+    t_j. Then we substitute xi_j for t_j in xi' and continue.  However,
+    since none of the t_i occur in xi_j, we have decreased the
+    number of t_i that occur in xi', since we eliminated t_j and did not
+    introduce any new ones.
+
+\begin{code}
+data TypeClassifier 
+  = VarCls TcTyVar	-- Type variable
+  | FunCls TyCon [Type]	-- Type function, exactly saturated
+  | OtherCls TcType	-- Neither of the above
+
+unClassify :: TypeClassifier -> TcType
+unClassify (VarCls tv)     = TyVarTy tv
+unClassify (FunCls fn tys) = TyConApp fn tys
+unClassify (OtherCls ty)   = ty
+
+classify :: TcType -> TypeClassifier
+classify (TyVarTy tv)      = VarCls tv
+classify (TyConApp tc tys) | isSynFamilyTyCon tc
+                           , tyConArity tc == length tys
+                           = FunCls tc tys
+classify ty                | Just ty' <- tcView ty
+	                   = case classify ty' of
+                               OtherCls {} -> OtherCls ty
+                               var_or_fn   -> var_or_fn
+                           | otherwise 
+                           = OtherCls ty
+
+-- See note [Canonical ordering for equality constraints].
+reOrient :: TypeClassifier -> TypeClassifier -> Bool	
+-- (t1 `reOrient` t2) responds True 
+--   iff we should flip to (t2~t1)
+-- We try to say False if possible, to minimise evidence generation
+--
+-- Postcondition: After re-orienting, first arg is not OTherCls
+reOrient (OtherCls {}) (FunCls {})   = True
+reOrient (OtherCls {}) (VarCls {})   = True
+reOrient (OtherCls {}) (OtherCls {}) = panic "reOrient"  -- One must be Var/Fun
+
+reOrient (FunCls {})   (VarCls tv2)   = isMetaTyVar tv2
+  -- See Note [No touchables as FunEq RHS] in TcSMonad
+  -- For convenience we enforce the stronger invariant that no 
+  -- meta type variable is the RHS of a function equality
+reOrient (FunCls {}) _                = False   -- Fun/Other on rhs
+
+
+reOrient (VarCls tv1) (FunCls {}) = not (isMetaTyVar tv1)
+reOrient (VarCls {})  (OtherCls {}) = False
+
+-- Variables-variables are oriented according to their kind 
+-- so that the invariant of CTyEqCan has the best chance of
+-- holding:   tv ~ xi
+--   * If tv is a MetaTyVar, then typeKind xi <: typeKind tv 
+--              a skolem,    then typeKind xi =  typeKind tv 
+reOrient (VarCls tv1) (VarCls tv2)
+  | k1 `eqKind` k2 = False
+  | otherwise      = k1 `isSubKind` k2 
+  where
+    k1 = tyVarKind tv1
+    k2 = tyVarKind tv2
+
+------------------
+canEqLeaf :: CtFlavor -> CoVar 
+          -> TypeClassifier -> TypeClassifier -> TcS CanonicalCts 
+-- Canonicalizing "leaf" equality constraints which cannot be
+-- decomposed further (ie one of the types is a variable or
+-- saturated type function application).  
+
+  -- Preconditions: 
+  --    * one of the two arguments is not OtherCls
+  --    * the two types are not equal (looking through synonyms)
+canEqLeaf fl cv cls1 cls2 
+  | cls1 `reOrient` cls2 
+  = do { cv' <- if isWanted fl 
+                then do { cv' <- newWantedCoVar s2 s1 
+                        ; setWantedCoBind cv $ mkSymCoercion (mkCoVarCoercion cv') 
+                        ; return cv' } 
+                else newGivOrDerCoVar s2 s1 (mkSymCoercion (mkCoVarCoercion cv)) 
+       ; canEqLeafOriented fl cv' cls2 s1 }
+
+  | otherwise
+  = canEqLeafOriented fl cv cls1 s2
+  where
+    s1 = unClassify cls1  
+    s2 = unClassify cls2  
+
+------------------
+canEqLeafOriented :: CtFlavor -> CoVar 
+                  -> TypeClassifier -> TcType -> TcS CanonicalCts 
+-- First argument is not OtherCls
+canEqLeafOriented fl cv cls1@(FunCls fn tys) s2 
+  | not (kindAppResult (tyConKind fn) tys `eqKind` typeKind s2 )
+  = kindErrorTcS fl (unClassify cls1) s2
+  | otherwise 
+  = ASSERT2( isSynFamilyTyCon fn, ppr (unClassify cls1) )
+    do { (xis1,ccs1) <- flattenMany fl tys -- flatten type function arguments
+       ; (xi2,ccs2)  <- flatten fl s2      -- flatten entire RHS
+       ; let final_cc = CFunEqCan { cc_id     = cv 
+                                  , cc_flavor = fl 
+                                  , cc_fun    = fn
+                                  , cc_tyargs = xis1 
+                                  , cc_rhs    = xi2 }
+       ; return $ ccs1 `andCCan` ccs2 `extendCCans` final_cc }
+
+-- Otherwise, we have a variable on the left, so we flatten the RHS
+-- and then do an occurs check.
+canEqLeafOriented fl cv (VarCls tv) s2 
+  | not (k1 `eqKind` k2 || (isMetaTyVar tv && k2 `isSubKind` k1))
+      -- Establish the kind invariant for CTyEqCan
+  = kindErrorTcS fl (mkTyVarTy tv) s2
+
+  | otherwise
+  = do { (xi2,ccs2) <- flatten fl s2      -- flatten RHS
+       ; xi2' <- canOccursCheck fl tv xi2 -- do an occurs check, and return a possibly 
+                                          -- unfolded version of the RHS, if we had to 
+                                          -- unfold any type synonyms to get rid of tv.
+       ; let final_cc = CTyEqCan { cc_id     = cv 
+                                 , cc_flavor = fl
+                                 , cc_tyvar  = tv
+                                 , cc_rhs    = xi2'
+                                 } 
+       ; return $ ccs2 `extendCCans` final_cc }
+  where
+    k1 = tyVarKind tv
+    k2 = typeKind s2
+
+canEqLeafOriented _ cv (OtherCls ty1) ty2 
+  = pprPanic "canEqLeaf" (ppr cv $$ ppr ty1 $$ ppr ty2)
+
+-- See Note [Type synonyms and canonicalization].
+-- Check whether the given variable occurs in the given type.  We may
+-- have needed to do some type synonym unfolding in order to get rid
+-- of the variable, so we also return the unfolded version of the
+-- type, which is guaranteed to be syntactically free of the given
+-- type variable.  If the type is already syntactically free of the
+-- variable, then the same type is returned.
+--
+-- Precondition: the two types are not equal (looking though synonyms)
+canOccursCheck :: CtFlavor -> TcTyVar -> Xi -> TcS Xi
+canOccursCheck gw tv xi 
+  | Just xi' <- expandAway tv xi = return xi'
+  | otherwise = occursCheckErrorTcS gw tv xi
+\end{code}
+
+@expandAway tv xi@ expands synonyms in xi just enough to get rid of
+occurrences of tv, if that is possible; otherwise, it returns Nothing.
+For example, suppose we have
+  type F a b = [a]
+Then
+  expandAway b (F Int b) = Just [Int]
+but
+  expandAway a (F a Int) = Nothing
+
+We don't promise to do the absolute minimum amount of expanding
+necessary, but we try not to do expansions we don't need to.  We
+prefer doing inner expansions first.  For example,
+  type F a b = (a, Int, a, [a])
+  type G b   = Char
+We have
+  expandAway b (F (G b)) = F Char
+even though we could also expand F to get rid of b.
+
+\begin{code}
+expandAway :: TcTyVar -> Xi -> Maybe Xi
+expandAway tv t@(TyVarTy tv') 
+  | tv == tv' = Nothing
+  | otherwise = Just t
+expandAway tv xi
+  | not (tv `elemVarSet` tyVarsOfType xi) = Just xi
+expandAway tv (AppTy ty1 ty2) 
+  = mkAppTy <$> expandAway tv ty1 <*> expandAway tv ty2
+expandAway tv (FunTy ty1 ty2)
+  = mkFunTy <$> expandAway tv ty1 <*> expandAway tv ty2
+expandAway _ (ForAllTy {}) = error "blorg"  -- TODO
+expandAway _ (PredTy {})   = error "flerg"  -- TODO
+
+-- For a type constructor application, first try expanding away the
+-- offending variable from the arguments.  If that doesn't work, next
+-- see if the type constructor is a type synonym, and if so, expand
+-- it and try again.
+expandAway tv ty@(TyConApp tc tys)
+    = (mkTyConApp tc <$> mapM (expandAway tv) tys) <|> (tcView ty >>= expandAway tv)
+\end{code}
+
+Note [Type synonyms and canonicalization]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+We treat type synonym applications as xi types, that is, they do not
+count as type function applications.  However, we do need to be a bit
+careful with type synonyms: like type functions they may not be
+generative or injective.  However, unlike type functions, they are
+parametric, so there is no problem in expanding them whenever we see
+them, since we do not need to know anything about their arguments in
+order to expand them; this is what justifies not having to treat them
+as specially as type function applications.  The thing that causes
+some subtleties is that we prefer to leave type synonym applications
+*unexpanded* whenever possible, in order to generate better error
+messages.
+
+If we encounter an equality constraint with type synonym applications
+on both sides, or a type synonym application on one side and some sort
+of type application on the other, we simply must expand out the type
+synonyms in order to continue decomposing the equality constraint into
+primitive equality constraints.  For example, suppose we have
+
+  type F a = [Int]
+
+and we encounter the equality
+
+  F a ~ [b]
+
+In order to continue we must expand F a into [Int], giving us the
+equality
+
+  [Int] ~ [b]
+
+which we can then decompose into the more primitive equality
+constraint
+
+  Int ~ b.
+
+However, if we encounter an equality constraint with a type synonym
+application on one side and a variable on the other side, we should
+NOT (necessarily) expand the type synonym, since for the purpose of
+good error messages we want to leave type synonyms unexpanded as much
+as possible.
+
+However, there is a subtle point with type synonyms and the occurs
+check that takes place for equality constraints of the form tv ~ xi.
+As an example, suppose we have
+
+  type F a = Int
+
+and we come across the equality constraint
+
+  a ~ F a
+
+This should not actually fail the occurs check, since expanding out
+the type synonym results in the legitimate equality constraint a ~
+Int.  We must actually do this expansion, because unifying a with F a
+will lead the type checker into infinite loops later.  Put another
+way, canonical equality constraints should never *syntactically*
+contain the LHS variable in the RHS type.  However, we don't always
+need to expand type synonyms when doing an occurs check; for example,
+the constraint
+
+  a ~ F b
+
+is obviously fine no matter what F expands to. And in this case we
+would rather unify a with F b (rather than F b's expansion) in order
+to get better error messages later.
+
+So, when doing an occurs check with a type synonym application on the
+RHS, we use some heuristics to find an expansion of the RHS which does
+not contain the variable from the LHS.  In particular, given
+
+  a ~ F t1 ... tn
+
+we first try expanding each of the ti to types which no longer contain
+a.  If this turns out to be impossible, we next try expanding F
+itself, and so on.
+
+
+
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 13b6300..85a9431 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -21,7 +21,7 @@ import Inst
 import InstEnv
 import TcEnv
 import TcBinds
-import TcSimplify
+import TcUnify
 import TcHsType
 import TcMType
 import TcType
@@ -34,6 +34,7 @@ import MkId
 import Id
 import Name
 import Var
+import VarSet
 import NameEnv
 import NameSet
 import Outputable
@@ -169,11 +170,10 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 	      (tyvars, _, _, op_items) = classBigSig clas
 	      rigid_info  = ClsSkol clas
 	      prag_fn	  = mkPragFun sigs default_binds
-	      sig_fn	  = mkTcSigFun sigs
+	      sig_fn	  = mkSigFun sigs
 	      clas_tyvars = tcSkolSigTyVars rigid_info tyvars
 	      pred  	  = mkClassPred clas (mkTyVarTys clas_tyvars)
-	; inst_loc <- getInstLoc (SigOrigin rigid_info)
-	; this_dict <- newDictBndr inst_loc pred
+	; this_dict <- newEvVar pred
 
 	; let tc_dm = tcDefMeth clas clas_tyvars
 				this_dict default_binds
@@ -186,8 +186,8 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 
 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
     
-tcDefMeth :: Class -> [TyVar] -> Inst -> LHsBinds Name
-          -> TcSigFun -> TcPragFun -> ClassOpItem
+tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
+          -> SigFun -> PragFun -> ClassOpItem
           -> TcM (Maybe (LHsBind Id))
 -- Generate code for polymorphic default methods only (hence DefMeth)
 -- (Generic default methods have turned into instance decls by now.)
@@ -208,7 +208,7 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
 		-- See Note [Silly default-method bind]
 		-- (possibly out of date)
 
-	; let meth_bind = findMethodBind sel_name local_dm_name binds_in
+	; let meth_bind = findMethodBind sel_name binds_in
 			  `orElse` pprPanic "tcDefMeth" (ppr sel_id)
 		-- dm_info = DefMeth dm_name only if there is a binding in binds_in
 
@@ -225,42 +225,49 @@ tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
                   <+> quotes (ppr sel_name))
 
         ; liftM Just $
-          tcInstanceMethodBody (instLoc this_dict) 
-                               tyvars [this_dict]
-                               ([], emptyBag)
+          tcInstanceMethodBody (ClsSkol clas)
+                               tyvars 
+                               [this_dict]
+                               Nothing
                                dm_id_w_inline local_dm_id
                                dm_sig_fn IsDefaultMethod meth_bind }
 
 ---------------
-tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst]
-		     -> ([Inst], LHsBinds Id) -> Id -> Id
-          	     -> TcSigFun -> TcSpecPrags -> LHsBind Name 
+tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
+		     -> Maybe EvBind
+                     -> Id -> Id
+          	     -> SigFun -> TcSpecPrags -> LHsBind Name 
           	     -> TcM (LHsBind Id)
-tcInstanceMethodBody inst_loc tyvars dfun_dicts
-		     (this_dict, this_bind) meth_id local_meth_id
-		     meth_sig_fn spec_prags bind@(L loc _)
+tcInstanceMethodBody skol_info tyvars dfun_ev_vars
+		     this_dict meth_id local_meth_id
+		     meth_sig_fn specs 
+                     (L loc bind)
   = do	{       -- Typecheck the binding, first extending the envt
 		-- so that when tcInstSig looks up the local_meth_id to find
 		-- its signature, we'll find it in the environment
-	; ((tc_bind, _), lie) <- getLIE $
-				 tcExtendIdEnv [local_meth_id] $
-	        		 tcPolyBinds TopLevel meth_sig_fn no_prag_fn 
-				 	     NonRecursive NonRecursive
-				 	     (unitBag bind)
-
-	; let avails = this_dict ++ dfun_dicts
-		-- Only need the this_dict stuff if there are type 
-		-- variables involved; otherwise overlap is not possible
-		-- See Note [Subtle interaction of recursion and overlap]
-		-- in TcInstDcls
-	; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie
-
-	; let full_bind = AbsBinds tyvars dfun_lam_vars
-     				  [(tyvars, meth_id, local_meth_id, spec_prags)]
-				  (this_bind `unionBags` lie_binds 
-				   `unionBags` tc_bind)
-
-	      dfun_lam_vars = map instToVar dfun_dicts	-- Includes equalities
+	  let full_given = case this_dict of
+                             Nothing -> dfun_ev_vars
+			     Just (EvBind dict _) -> dict : dfun_ev_vars
+              lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
+			     -- Substitue the local_meth_name for the binder
+			     -- NB: the binding is always a FunBind
+
+	; (ev_binds, (tc_bind, _)) 
+               <- checkConstraints skol_info emptyVarSet tyvars full_given $
+		  tcExtendIdEnv [local_meth_id] $
+	          tcPolyBinds TopLevel meth_sig_fn no_prag_fn 
+		  	     NonRecursive NonRecursive
+		  	     [lm_bind]
+
+        -- Add the binding for this_dict, if we have one
+        ; ev_binds' <- case this_dict of
+                         Nothing                -> return ev_binds
+                         Just (EvBind self rhs) -> extendTcEvBinds ev_binds self rhs
+
+	; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
+                                   , abs_exports = [(tyvars, meth_id, local_meth_id, specs)]
+				   , abs_ev_binds = ev_binds'
+                                   , abs_binds = tc_bind }
 
         ; return (L loc full_bind) } 
   where
@@ -293,18 +300,16 @@ instantiateMethod clas sel_id inst_tys
 
 
 ---------------------------
--- The renamer just puts the selector ID as the binder in the method binding
--- but we must use the method name; so we substitute it here.  Crude but simple.
-findMethodBind	:: Name -> Name 	-- Selector and method name
+findMethodBind	:: Name  	        -- Selector name
           	-> LHsBinds Name 	-- A group of bindings
-		-> Maybe (LHsBind Name)	-- The binding, with meth_name replacing sel_name
-findMethodBind sel_name meth_name binds
+		-> Maybe (LHsBind Name)	-- The binding
+findMethodBind sel_name binds
   = foldlBag mplus Nothing (mapBag f binds)
   where 
-	f (L loc1 bind@(FunBind { fun_id = L loc2 op_name }))
-	         | op_name == sel_name
-		 = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
-	f _other = Nothing
+    f bind@(L _ (FunBind { fun_id = L _ op_name }))
+             | op_name == sel_name
+    	     = Just bind
+    f _other = Nothing
 \end{code}
 
 Note [Polymorphic methods]
@@ -364,8 +369,8 @@ gives rise to the instance declarations
 	  op Unit      = ...
 
 \begin{code}
-mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
-mkGenericDefMethBind clas inst_tys sel_id meth_name
+mkGenericDefMethBind :: Class -> [Type] -> Id -> TcM (LHsBind Name)
+mkGenericDefMethBind clas inst_tys sel_id
   = 	-- A generic default method
     	-- If the method is defined generically, we can only do the job if the
 	-- instance declaration is for a single-parameter type class with
@@ -383,7 +388,8 @@ mkGenericDefMethBind clas inst_tys sel_id meth_name
 
 		-- Rename it before returning it
 	; (rn_rhs, _) <- rnLExpr rhs
-        ; return (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rn_rhs]) }
+        ; return (noLoc $ mkFunBind (noLoc (idName sel_id))
+                                    [mkSimpleMatch [] rn_rhs]) }
   where
     rhs = mkGenericRhs sel_id clas_tyvar tycon
 
@@ -595,7 +601,7 @@ notGeneric tycon
 badGenericInstanceType :: LHsBinds Name -> SDoc
 badGenericInstanceType binds
   = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
-	  nest 4 (ppr binds)]
+	  nest 2 (ppr binds)]
 
 missingGenericInstances :: [Name] -> SDoc
 missingGenericInstances missing
@@ -604,7 +610,7 @@ missingGenericInstances missing
 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
 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)),
+	  nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
 	  ptext (sLit "All the type patterns for a generic type constructor must be identical")
     ]
   where 
diff --git a/compiler/typecheck/TcDefaults.lhs b/compiler/typecheck/TcDefaults.lhs
index 9d1f85a..97d51a1 100644
--- a/compiler/typecheck/TcDefaults.lhs
+++ b/compiler/typecheck/TcDefaults.lhs
@@ -76,7 +76,7 @@ check_instance :: Type -> Class -> TcM Bool
   -- Check that ty is an instance of cls
   -- We only care about whether it worked or not; return a boolean
 check_instance ty cls
-  = do	{ (_, mb_res) <- tryTc (tcSimplifyDefault [mkClassPred cls [ty]])
+  = do	{ (_, mb_res) <- tryTc (simplifyDefault [mkClassPred cls [ty]])
 	; return (isJust mb_res) }
     
 defaultDeclCtxt :: SDoc
@@ -85,14 +85,14 @@ defaultDeclCtxt = ptext (sLit "When checking the types in a default declaration"
 dupDefaultDeclErr :: [Located (DefaultDecl Name)] -> SDoc
 dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things)
   = hang (ptext (sLit "Multiple default declarations"))
-      4  (vcat (map pp dup_things))
+       2 (vcat (map pp dup_things))
   where
     pp (L locn (DefaultDecl _)) = ptext (sLit "here was another default declaration") <+> ppr locn
 dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"
 
 polyDefErr :: LHsType Name -> SDoc
 polyDefErr ty 
-  = hang (ptext (sLit "Illegal polymorphic type in default declaration") <> colon) 4 (ppr ty) 
+  = hang (ptext (sLit "Illegal polymorphic type in default declaration") <> colon) 2 (ppr ty) 
 
 badDefaultTy :: Type -> [Class] -> SDoc
 badDefaultTy ty deflt_clss
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index c4c8854..8fa8c0b 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -68,10 +68,11 @@ Overall plan
 
 3.  Add the derived bindings, generating InstInfos
 
+
 \begin{code}
 -- DerivSpec is purely  local to this module
 data DerivSpec  = DS { ds_loc     :: SrcSpan 
-		     , ds_orig    :: InstOrigin 
+		     , ds_orig    :: CtOrigin 
 		     , ds_name    :: Name
 		     , ds_tvs     :: [TyVar] 
 		     , ds_theta   :: ThetaType
@@ -84,14 +85,27 @@ data DerivSpec  = DS { ds_loc     :: SrcSpan
 	--	 df :: forall tvs. theta => C tys
 	-- The Name is the name for the DFun we'll build
 	-- The tyvars bind all the variables in the theta
-	-- For family indexes, the tycon in 
+	-- For type families, the tycon in 
 	--	 in ds_tys is the *family* tycon
 	--	 in ds_tc, ds_tc_args is the *representation* tycon
 	-- For non-family tycons, both are the same
 
 	-- ds_newtype = True  <=> Newtype deriving
 	--		False <=> Vanilla deriving
+\end{code}
+
+Example:
 
+     newtype instance T [a] = MkT (Tree a) deriving( C s )
+==>  
+     axiom T [a] = :RTList a
+     axiom :RTList a = Tree a
+
+     DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
+        , ds_tc = :RTList, ds_tc_args = [a]
+        , ds_newtype = True }
+
+\begin{code}
 type DerivContext = Maybe ThetaType
    -- Nothing 	 <=> Vanilla deriving; infer the context of the instance decl
    -- Just theta <=> Standalone deriving: context supplied by programmer
@@ -287,7 +301,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
     do	{   	-- Fish the "deriving"-related information out of the TcEnv
 		-- And make the necessary "equations".
 	  is_boot <- tcIsHsBoot
-	; traceTc (text "tcDeriving" <+> ppr is_boot)
+	; traceTc "tcDeriving" (ppr is_boot)
 	; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
 
 	; overlap_flag <- getOverlapFlag
@@ -454,21 +468,21 @@ deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
 deriveStandalone (L loc (DerivDecl deriv_ty))
   = setSrcSpan loc                   $
     addErrCtxt (standaloneCtxt deriv_ty)  $
-    do { traceTc (text "standalone deriving decl for" <+> ppr deriv_ty)
+    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
        ; (tvs, theta, tau) <- tcHsInstHead deriv_ty
-       ; traceTc (text "standalone deriving;"
-              <+> text "tvs:" <+> ppr tvs
-              <+> text "theta:" <+> ppr theta
-              <+> text "tau:" <+> ppr tau)
+       ; traceTc "Standalone deriving;" $ vcat
+              [ text "tvs:" <+> ppr tvs
+              , text "theta:" <+> ppr theta
+              , text "tau:" <+> ppr tau ]
        ; (cls, inst_tys) <- checkValidInstance deriv_ty tvs theta tau
 		-- C.f. TcInstDcls.tcLocalInstDecl1
 
        ; let cls_tys = take (length inst_tys - 1) inst_tys
              inst_ty = last inst_tys
-       ; traceTc (text "standalone deriving;"
-              <+> text "class:" <+> ppr cls
-              <+> text "class types:" <+> ppr cls_tys
-              <+> text "type:" <+> ppr inst_ty)
+       ; traceTc "Standalone deriving:" $ vcat
+              [ text "class:" <+> ppr cls
+              , text "class types:" <+> ppr cls_tys
+              , text "type:" <+> ppr inst_ty ]
        ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
                    (Just theta) }
 
@@ -518,7 +532,7 @@ deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
 	-- Type families can't be partially applied
 	-- e.g.   newtype instance T Int a = MkT [a] deriving( Monad )
 	-- Note [Deriving, type families, and partial applications]
-	; checkTc (not (isOpenTyCon tc) || n_args_to_drop == 0)
+	; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
 		  (typeFamilyPapErr tc cls cls_tys inst_ty)
 
 	; mkEqnHelp DerivOrigin (varSetElems univ_tvs) cls cls_tys inst_ty Nothing } }
@@ -571,7 +585,7 @@ After all, we can write it out
       ... etc ...	
 
 \begin{code}
-mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
+mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type
           -> DerivContext	-- Just    => context supplied (standalone deriving)
 				-- Nothing => context inferred (deriving on data decl)
           -> TcRn EarlyDerivSpec
@@ -583,7 +597,7 @@ mkEqnHelp :: InstOrigin -> [TyVar] -> Class -> [Type] -> Type
 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
   , isAlgTyCon tycon	-- Check for functions, primitive types etc
-  = do	{ (rep_tc, rep_tc_args) <- tcLookupFamInstExact tycon tc_args
+  = do	{ (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args
 	          -- Be careful to test rep_tc here: in the case of families, 
 	          -- we want to check the instance tycon, not the family tycon
 
@@ -611,48 +625,6 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta
 	       (ptext (sLit "The last argument of the instance must be a data or newtype application")))
 \end{code}
 
-Note [Looking up family instances for deriving]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-tcLookupFamInstExact is an auxiliary lookup wrapper which requires
-that looked-up family instances exist.  If called with a vanilla
-tycon, the old type application is simply returned.
-
-If we have
-  data instance F () = ... deriving Eq
-  data instance F () = ... deriving Eq
-then tcLookupFamInstExact will be confused by the two matches;
-but that can't happen because tcInstDecls1 doesn't call tcDeriving
-if there are any overlaps.
-
-There are two other things that might go wrong with the lookup.
-First, we might see a standalone deriving clause
-	deriving Eq (F ())
-when there is no data instance F () in scope. 
-
-Note that it's OK to have
-  data instance F [a] = ...
-  deriving Eq (F [(a,b)])
-where the match is not exact; the same holds for ordinary data types
-with standalone deriving declrations.
-
-\begin{code}
-tcLookupFamInstExact :: TyCon -> [Type] -> TcM (TyCon, [Type])
-tcLookupFamInstExact tycon tys
-  | not (isOpenTyCon tycon)
-  = return (tycon, tys)
-  | otherwise
-  = do { maybeFamInst <- tcLookupFamInst tycon tys
-       ; case maybeFamInst of
-           Nothing      -> famInstNotFound tycon tys
-           Just famInst -> return famInst
-       }
-
-famInstNotFound :: TyCon -> [Type] -> TcM a
-famInstNotFound tycon tys 
-  = failWithTc (ptext (sLit "No family instance for")
-			<+> quotes (pprTypeApp tycon tys))
-\end{code}
-
 
 %************************************************************************
 %*									*
@@ -661,7 +633,7 @@ famInstNotFound tycon tys
 %************************************************************************
 
 \begin{code}
-mkDataTypeEqn :: InstOrigin
+mkDataTypeEqn :: CtOrigin
               -> DynFlags
               -> [Var]                  -- Universally quantified type variables in the instance
               -> Class                  -- Class for which we need to derive an instance
@@ -686,7 +658,7 @@ mkDataTypeEqn orig dflags tvs cls cls_tys
     bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
 
 mk_data_eqn, mk_typeable_eqn
-   :: InstOrigin -> [TyVar] -> Class 
+   :: CtOrigin -> [TyVar] -> Class 
    -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
    -> TcM EarlyDerivSpec
 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
@@ -743,7 +715,6 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaTy
 -- before being used in the instance declaration
 inferConstraints _ cls inst_tys rep_tc rep_tc_args
   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
-    pprTrace "ic" (ppr rep_tc $$ ppr rep_tc_tvs $$ ppr (tyConStupidTheta rep_tc) $$ ppr stupid_constraints) $
     stupid_constraints ++ extra_constraints
     ++ sc_constraints ++ con_arg_constraints
   where
@@ -946,17 +917,32 @@ functorLikeClassKeys :: [Unique]
 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
 
 cond_functorOK :: Bool -> Condition
--- OK for Functor class
+-- OK for Functor/Foldable/Traversable class
 -- Currently: (a) at least one argument
 --            (b) don't use argument contravariantly
 --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
 --            (d) optionally: don't use function types
+--            (e) no "stupid context" on data type
 cond_functorOK allowFunctions (dflags, rep_tc) 
   | not (dopt Opt_DeriveFunctor dflags)
   = Just (ptext (sLit "You need -XDeriveFunctor to derive an instance for this class"))
+
+  | null tc_tvs
+  = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) 
+          <+> ptext (sLit "has no parameters"))
+
+  | not (null bad_stupid_theta)
+  = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) 
+          <+> ptext (sLit "has a class context") <+> pprTheta bad_stupid_theta)
+
   | otherwise
   = msum (map check_con data_cons)	-- msum picks the first 'Just', if any
   where
+    tc_tvs            = tyConTyVars rep_tc
+    Just (_, last_tv) = snocView tc_tvs
+    bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
+    is_bad pred       = last_tv `elemVarSet` tyVarsOfPred pred
+
     data_cons = tyConDataCons rep_tc
     check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
 
@@ -1053,7 +1039,7 @@ a context for the Data instances:
 %************************************************************************
 
 \begin{code}
-mkNewTypeEqn :: InstOrigin -> DynFlags -> [Var] -> Class
+mkNewTypeEqn :: CtOrigin -> DynFlags -> [Var] -> Class
              -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
              -> DerivContext
              -> TcRn EarlyDerivSpec
@@ -1061,7 +1047,7 @@ mkNewTypeEqn orig dflags tvs
              cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
   | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
-  = do	{ traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)
+  = do	{ traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
 	; dfun_name <- new_dfun_name cls tycon
   	; loc <- getSrcSpanM
 	; let spec = DS { ds_loc = loc, ds_orig = orig
@@ -1242,7 +1228,7 @@ inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
 inferInstanceContexts _ [] = return []
 
 inferInstanceContexts oflag infer_specs
-  = do	{ traceTc (text "inferInstanceContexts" <+> vcat (map pprDerivSpec infer_specs))
+  = do	{ traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
 	; iterate_deriv 1 initial_solutions }
   where
     ------------------------------------------------------------------
@@ -1285,21 +1271,26 @@ inferInstanceContexts oflag infer_specs
 		 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
       = setSrcSpan loc	$
 	addErrCtxt (derivInstCtxt clas inst_tys) $ 
-	do { theta <- tcSimplifyDeriv orig tyvars deriv_rhs
-	   	-- checkValidInstance tyvars theta clas inst_tys
-		-- Not necessary; see Note [Exotic derived instance contexts]
-		-- 		  in TcSimplify
-
-		  -- Check for a bizarre corner case, when the derived instance decl should
+	do {      -- Check for a bizarre corner case, when the derived instance decl should
 		  -- have form 	instance C a b => D (T a) where ...
 		  -- Note that 'b' isn't a parameter of T.  This gives rise to all sorts
 		  -- of problems; in particular, it's hard to compare solutions for
-		  -- equality when finding the fixpoint.  So I just rule it out for now.
+		  -- equality when finding the fixpoint.  Moreover, simplifyDeriv
+		  -- has an assert failure because it finds a TyVar when it expects
+		  -- only TcTyVars.  So I just rule it out for now.  I'm not 
+		  -- even sure how it can arise.
+		  
  	   ; let tv_set = mkVarSet tyvars
-	         weird_preds = [pred | pred <- theta, not (tyVarsOfPred pred `subVarSet` tv_set)]  
+	         weird_preds = [pred | pred <- deriv_rhs
+                                     , not (tyVarsOfPred pred `subVarSet` tv_set)]  
 	   ; mapM_ (addErrTc . badDerivedPred) weird_preds	
 
-           ; traceTc (text "TcDeriv" <+> (ppr deriv_rhs $$ ppr theta))
+           ; theta <- simplifyDeriv orig tyvars deriv_rhs
+	   	-- checkValidInstance tyvars theta clas inst_tys
+		-- Not necessary; see Note [Exotic derived instance contexts]
+		-- 		  in TcSimplify
+		
+           ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
 		-- Claim: the result instance declaration is guaranteed valid
 		-- Hence no need to call:
 		--   checkValidInstance tyvars theta clas inst_tys
@@ -1420,12 +1411,14 @@ genInst standalone_deriv oflag spec
     rep_tycon   = ds_tc spec
     rep_tc_args = ds_tc_args spec
     co1 = case tyConFamilyCoercion_maybe rep_tycon of
-    	      Nothing     -> IdCo
 	      Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
+    	      Nothing     -> id_co
+	      -- Not a family => rep_tycon = main tycon
     co2 = case newTyConCo_maybe rep_tycon of
-              Nothing     -> IdCo	-- The newtype is transparent; no need for a cast
 	      Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
+              Nothing     -> id_co  -- The newtype is transparent; no need for a cast
     co = co1 `mkTransCoI` co2
+    id_co = IdCo (mkTyConApp rep_tycon rep_tc_args)
 
 -- Example: newtype instance N [a] = N1 (Tree a) 
 --          deriving instance Eq b => Eq (N [(b,b)])
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 67e65af..d6177b4 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -17,7 +17,8 @@ module TcEnv(
 	tcLookupLocatedGlobal,	tcLookupGlobal, 
 	tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
 	tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
-	tcLookupLocatedClass, tcLookupFamInst,
+	tcLookupLocatedClass, 
+	tcLookupFamInst, tcLookupDataFamInst,
 	
 	-- Local environment
 	tcExtendKindEnv, tcExtendKindEnvTvs,
@@ -26,7 +27,7 @@ module TcEnv(
 	tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2, 
 	tcLookup, tcLookupLocated, tcLookupLocalIds, 
 	tcLookupId, tcLookupTyVar, getScopedTyVarBinds,
-	lclEnvElts, getInLocalScope, findGlobals, 
+	getInLocalScope,
 	wrongThingErr, pprBinders,
 
 	tcExtendRecEnv,    	-- For knot-tying
@@ -34,6 +35,9 @@ module TcEnv(
 	-- Rules
  	tcExtendRules,
 
+	-- Defaults
+	tcGetDefaultTys,
+
 	-- Global type variables
 	tcGetGlobalTyVars,
 
@@ -49,12 +53,13 @@ module TcEnv(
 #include "HsVersions.h"
 
 import HsSyn
-import TcIface
 import IfaceEnv
 import TcRnMonad
 import TcMType
 import TcType
--- import TcSuspension
+import TcIface	
+import PrelNames
+import TysWiredIn
 -- import qualified Type
 import Id
 import Coercion
@@ -71,6 +76,7 @@ import Class
 import Name
 import NameEnv
 import HscTypes
+import DynFlags
 import SrcLoc
 import Outputable
 import Unique
@@ -191,7 +197,7 @@ tcLookupLocatedTyCon = addLocM tcLookupTyCon
 --
 tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (TyCon, [Type]))
 tcLookupFamInst tycon tys
-  | not (isOpenTyCon tycon)
+  | not (isFamilyTyCon tycon)
   = return Nothing
   | otherwise
   = do { env <- getGblEnv
@@ -202,8 +208,50 @@ tcLookupFamInst tycon tys
 	   ((fam_inst, rep_tys):_) 
              -> return $ Just (famInstTyCon fam_inst, rep_tys)
        }
+
+tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
+-- Find the instance of a data famliy
+-- Note [Looking up family instances for deriving]
+tcLookupDataFamInst tycon tys
+  | not (isFamilyTyCon tycon)
+  = return (tycon, tys)
+  | otherwise
+  = ASSERT( isAlgTyCon tycon )
+    do { maybeFamInst <- tcLookupFamInst tycon tys
+       ; case maybeFamInst of
+           Nothing      -> famInstNotFound tycon tys
+           Just famInst -> return famInst }
+
+famInstNotFound :: TyCon -> [Type] -> TcM a
+famInstNotFound tycon tys 
+  = failWithTc (ptext (sLit "No family instance for")
+			<+> quotes (pprTypeApp tycon tys))
 \end{code}
 
+Note [Looking up family instances for deriving]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcLookupFamInstExact is an auxiliary lookup wrapper which requires
+that looked-up family instances exist.  If called with a vanilla
+tycon, the old type application is simply returned.
+
+If we have
+  data instance F () = ... deriving Eq
+  data instance F () = ... deriving Eq
+then tcLookupFamInstExact will be confused by the two matches;
+but that can't happen because tcInstDecls1 doesn't call tcDeriving
+if there are any overlaps.
+
+There are two other things that might go wrong with the lookup.
+First, we might see a standalone deriving clause
+	deriving Eq (F ())
+when there is no data instance F () in scope. 
+
+Note that it's OK to have
+  data instance F [a] = ...
+  deriving Eq (F [(a,b)])
+where the match is not exact; the same holds for ordinary data types
+with standalone deriving declrations.
+
 \begin{code}
 instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
     lookupThing = tcLookupGlobal
@@ -263,8 +311,8 @@ tcLookupLocated = addLocM tcLookup
 
 tcLookup :: Name -> TcM TcTyThing
 tcLookup name = do
-    local_env <- getLclEnv
-    case lookupNameEnv (tcl_env local_env) name of
+    local_env <- getLclTypeEnv
+    case lookupNameEnv local_env name of
 	Just thing -> return thing
 	Nothing    -> AGlobal <$> tcLookupGlobal name
 
@@ -300,15 +348,10 @@ tcLookupLocalIds ns = do
 			-> ASSERT( lvl == lvl1 ) id
 		_ -> pprPanic "tcLookupLocalIds" (ppr name)
 
-lclEnvElts :: TcLclEnv -> [TcTyThing]
-lclEnvElts env = nameEnvElts (tcl_env env)
-
 getInLocalScope :: TcM (Name -> Bool)
   -- Ids only
-getInLocalScope = do
-    env <- getLclEnv
-    let lcl_env = tcl_env env
-    return (`elemNameEnv` lcl_env)
+getInLocalScope = do { lcl_env <- getLclTypeEnv
+                     ; return (`elemNameEnv` lcl_env) }
 \end{code}
 
 \begin{code}
@@ -344,7 +387,7 @@ tcExtendTyVarEnv2 binds thing_inside = do
 	-- Here, g mustn't be generalised.  This is also important during
 	-- class and instance decls, when we mustn't generalise the class tyvars
 	-- when typechecking the methods.
-    gtvs' <- tc_extend_gtvs gtvs new_tv_set
+    gtvs' <- tcExtendGlobalTyVars gtvs new_tv_set
     setLclEnv (env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}) thing_inside
 
 getScopedTyVarBinds :: TcM [(Name, TcType)]
@@ -389,110 +432,22 @@ tc_extend_local_id_env		-- This is the guy who does the work
 --	(c) The call to tyVarsOfTypes is ok without looking through refs
 
 tc_extend_local_id_env env th_lvl names_w_ids thing_inside
-  = do	{ traceTc (text "env2")
-	; traceTc (text "env3" <+> ppr extra_env)
-	; gtvs' <- tc_extend_gtvs (tcl_tyvars env) extra_global_tyvars
+  = do	{ traceTc "env2" (ppr extra_env)
+	; gtvs' <- tcExtendGlobalTyVars (tcl_tyvars env) extra_global_tyvars
 	; let env' = env {tcl_env = le', tcl_tyvars = gtvs', tcl_rdr = rdr_env'}
 	; setLclEnv env' thing_inside }
   where
     extra_global_tyvars = tcTyVarsOfTypes [idType id | (_,id) <- names_w_ids]
     extra_env	    = [ (name, ATcId { tct_id = id, 
-    				       tct_level = th_lvl,
-    				       tct_type = id_ty, 
-    				       tct_co = case isRefineableTy id_ty of
-						  (True,_) -> Unrefineable
-						  (_,True) -> Rigid idHsWrapper
-						  _        -> Wobbly})
-    		      | (name,id) <- names_w_ids, let id_ty = idType id]
+    				       tct_level = th_lvl })
+    		      | (name,id) <- names_w_ids]
     le'		    = extendNameEnvList (tcl_env env) extra_env
     rdr_env'	    = extendLocalRdrEnvList (tcl_rdr env) [name | (name,_) <- names_w_ids]
-\end{code}
 
-
-\begin{code}
------------------------
--- findGlobals looks at the value environment and finds values
--- whose types mention the offending type variable.  It has to be 
--- careful to zonk the Id's type first, so it has to be in the monad.
--- We must be careful to pass it a zonked type variable, too.
-
-findGlobals :: TcTyVarSet
-            -> TidyEnv 
-            -> TcM (TidyEnv, [SDoc])
-
-findGlobals tvs tidy_env = do
-    lcl_env <- getLclEnv
-    go tidy_env [] (lclEnvElts lcl_env)
-  where
-    go tidy_env acc [] = return (tidy_env, acc)
-    go tidy_env acc (thing : things) = do
-        (tidy_env1, maybe_doc) <- find_thing ignore_it tidy_env thing
-	case maybe_doc of
-	  Just d  -> go tidy_env1 (d:acc) things
-	  Nothing -> go tidy_env1 acc     things
-
-    ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
-
------------------------
-find_thing :: (TcType -> Bool) -> TidyEnv -> TcTyThing
-           -> TcM (TidyEnv, Maybe SDoc)
-find_thing ignore_it tidy_env (ATcId { tct_id = id }) = do
-    id_ty <- zonkTcType  (idType id)
-    if ignore_it id_ty then
-	return (tidy_env, Nothing)
-     else let
-	(tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
-	msg = sep [ppr id <+> dcolon <+> ppr tidy_ty, 
-		   nest 2 (parens (ptext (sLit "bound at") <+>
-			 	   ppr (getSrcLoc id)))]
-     in
-      return (tidy_env', Just msg)
-
-find_thing ignore_it tidy_env (ATyVar tv ty) = do
-    tv_ty <- zonkTcType ty
-    if ignore_it tv_ty then
-	return (tidy_env, Nothing)
-     else let
-	-- The name tv is scoped, so we don't need to tidy it
-	(tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
-	msg = sep [ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff, nest 2 bound_at]
-
-	eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, 
-		   getOccName tv == getOccName tv' = empty
-		 | otherwise = equals <+> ppr tidy_ty
-		-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
-	bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
-     in
-       return (tidy_env1, Just msg)
-
-find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
-\end{code}
-
-%************************************************************************
-%*									*
-\subsection{The global tyvars}
-%*									*
-%************************************************************************
-
-\begin{code}
-tc_extend_gtvs :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
-tc_extend_gtvs gtvs extra_global_tvs = do
-    global_tvs <- readMutVar gtvs
-    newMutVar (global_tvs `unionVarSet` extra_global_tvs)
-\end{code}
-
-@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
-To improve subsequent calls to the same function it writes the zonked set back into
-the environment.
-
-\begin{code}
-tcGetGlobalTyVars :: TcM TcTyVarSet
-tcGetGlobalTyVars = do
-    (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
-    gbl_tvs  <- readMutVar gtv_var
-    gbl_tvs' <- zonkTcTyVarsAndFV (varSetElems gbl_tvs)
-    writeMutVar gtv_var gbl_tvs'
-    return gbl_tvs'
+tcExtendGlobalTyVars :: IORef VarSet -> VarSet -> TcM (IORef VarSet)
+tcExtendGlobalTyVars gtv_var extra_global_tvs
+  = do { global_tvs <- readMutVar gtv_var
+       ; newMutVar (global_tvs `unionVarSet` extra_global_tvs) }
 \end{code}
 
 
@@ -582,6 +537,58 @@ thTopLevelId id = isGlobalId id || isExternalName (idName id)
 
 %************************************************************************
 %*									*
+                 getDefaultTys										
+%*									*
+%************************************************************************
+
+\begin{code}
+tcGetDefaultTys :: Bool		-- True <=> interactive context
+                -> TcM ([Type], -- Default types
+                        (Bool,	-- True <=> Use overloaded strings
+                         Bool)) -- True <=> Use extended defaulting rules
+tcGetDefaultTys interactive
+  = do	{ dflags <- getDOpts
+        ; let ovl_strings = dopt Opt_OverloadedStrings dflags
+              extended_defaults = interactive
+                               || dopt Opt_ExtendedDefaultRules dflags
+				        -- See also Trac #1974 
+              flags = (ovl_strings, extended_defaults)
+    
+        ; mb_defaults <- getDeclaredDefaultTys
+	; case mb_defaults of {
+	   Just tys -> return (tys, flags) ;
+	   	   	       	-- User-supplied defaults
+	   Nothing  -> do
+
+	-- No use-supplied default
+	-- Use [Integer, Double], plus modifications
+	{ integer_ty <- tcMetaTy integerTyConName
+	; checkWiredInTyCon doubleTyCon
+	; string_ty <- tcMetaTy stringTyConName
+        ; let deflt_tys = opt_deflt extended_defaults unitTy  -- Note [Default unitTy]
+			  ++ [integer_ty, doubleTy]
+			  ++ opt_deflt ovl_strings string_ty
+        ; return (deflt_tys, flags) } } }
+  where
+    opt_deflt True  ty = [ty]
+    opt_deflt False _  = []
+\end{code}
+
+Note [Default unitTy]
+~~~~~~~~~~~~~~~~~~~~~
+In interative mode (or with -XExtendedDefaultRules) we add () as the first type we
+try when defaulting.  This has very little real impact, except in the following case.
+Consider: 
+	Text.Printf.printf "hello"
+This has type (forall a. IO a); it prints "hello", and returns 'undefined'.  We don't
+want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to
+default the 'a' to (), rather than to Integer (which is what would otherwise happen;
+and then GHCi doesn't attempt to print the ().  So in interactive mode, we add
+() to the list of defaulting types.  See Trac #1200.
+
+
+%************************************************************************
+%*									*
 \subsection{The InstInfo type}
 %*									*
 %************************************************************************
@@ -612,6 +619,7 @@ data InstBindings a
 	[LSig a]		-- User pragmas recorded for generating 
 				-- specialised instances
 	Bool			-- True <=> This code came from a standalone deriving clause
+                                --          Used only to improve error messages
 
   | NewTypeDerived      -- Used for deriving instances of newtypes, where the
 			-- witness dictionary is identical to the argument 
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
new file mode 100644
index 0000000..533520f
--- /dev/null
+++ b/compiler/typecheck/TcErrors.lhs
@@ -0,0 +1,704 @@
+\begin{code}
+module TcErrors( 
+       reportUnsolved, reportUnsolvedImplication, reportUnsolvedDeriv,
+       reportUnsolvedWantedEvVars, warnDefaulting, typeExtraInfoMsg,
+       kindErrorTcS, misMatchErrorTcS, flattenForAllErrorTcS,
+       occursCheckErrorTcS, solverDepthErrorTcS
+  ) where
+
+#include "HsVersions.h"
+
+import TcRnMonad
+import TcMType
+import TcSMonad
+import TcType
+import Inst
+import InstEnv
+
+import TyCon
+import Name
+import NameEnv
+import Id	( idType )
+import HsExpr	( pprMatchContext )
+import Var
+import VarSet
+import VarEnv
+import SrcLoc
+import Bag
+import ListSetOps( equivClasses )
+import Util
+import Unique
+import FastString
+import Outputable
+import DynFlags
+import StaticFlags( opt_PprStyle_Debug )
+import Data.List( partition )
+import Control.Monad( unless )
+\end{code}
+
+%************************************************************************
+%*									*
+\section{Errors and contexts}
+%*									*
+%************************************************************************
+
+ToDo: for these error messages, should we note the location as coming
+from the insts, or just whatever seems to be around in the monad just
+now?
+
+\begin{code}
+reportUnsolved :: (CanonicalCts, Bag Implication) -> TcM ()
+reportUnsolved (unsolved_flats, unsolved_implics)
+  | isEmptyBag unsolved
+  = return ()
+  | otherwise
+  = do { env0 <- tcInitTidyEnv
+       ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWanteds unsolved)
+             tidy_unsolved = tidyWanteds tidy_env unsolved
+             err_ctxt = CEC { cec_encl = [] 
+                            , cec_extra = empty
+                            , cec_tidy = tidy_env } 
+       ; traceTc "reportUnsolved" (ppr unsolved)
+       ; reportTidyWanteds err_ctxt tidy_unsolved }
+  where
+    unsolved = mkWantedConstraints unsolved_flats unsolved_implics
+
+reportUnsolvedWantedEvVars :: Bag WantedEvVar -> TcM ()
+reportUnsolvedWantedEvVars wanteds
+  | isEmptyBag wanteds 
+  = return ()
+  | otherwise
+  = do { env0 <- tcInitTidyEnv
+       ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfWantedEvVars wanteds)
+             tidy_unsolved = tidyWantedEvVars tidy_env wanteds
+             err_ctxt = CEC { cec_encl  = [] 
+                            , cec_extra = empty
+                            , cec_tidy  = tidy_env } 
+       ; groupErrs (reportFlat err_ctxt) (bagToList tidy_unsolved) }
+
+reportUnsolvedDeriv :: [PredType] -> WantedLoc -> TcM ()
+reportUnsolvedDeriv unsolved loc
+  | null unsolved
+  = return ()
+  | otherwise
+  = do { env0 <- tcInitTidyEnv
+       ; let tidy_env      = tidyFreeTyVars env0 (tyVarsOfTheta unsolved)
+             tidy_unsolved = map (tidyPred tidy_env) unsolved
+             err_ctxt = CEC { cec_encl  = [] 
+                            , cec_extra = alt_fix
+                            , cec_tidy  = tidy_env } 
+       ; reportFlat err_ctxt tidy_unsolved loc }
+  where
+    alt_fix = vcat [ptext (sLit "Alternatively, use a standalone 'deriving instance' declaration,"),
+                    nest 2 $ ptext (sLit "so you can specify the instance context yourself")]
+
+reportUnsolvedImplication :: Implication -> TcM ()
+reportUnsolvedImplication implic
+  = do { env0 <- tcInitTidyEnv
+       ; let tidy_env    = tidyFreeTyVars env0 (tyVarsOfImplication implic)
+             tidy_implic = tidyImplication tidy_env implic
+             new_tidy_env = foldNameEnv add tidy_env (ic_env implic)
+             err_ctxt = CEC { cec_encl = [tidy_implic]
+                            , cec_extra = empty
+                            , cec_tidy = new_tidy_env } 
+       ; reportTidyWanteds err_ctxt (ic_wanted tidy_implic) }
+  where
+    -- Extend the tidy env with a mapping from tyvars to the
+    -- names the user originally used.  At the moment we do this
+    -- from the type env, but it might be better to record the
+    -- scoped type variable in the Implication.  Urgh.
+    add (ATyVar name ty) (occ_env, var_env)
+       | Just tv <- tcGetTyVar_maybe ty
+       , not (getUnique name `elemVarEnvByKey` var_env)
+       = case tidyOccName occ_env (nameOccName name) of
+	    (occ_env', occ') ->  (occ_env', extendVarEnv var_env tv tv')
+		where
+		  tv'   = setTyVarName tv name'
+		  name' = tidyNameOcc name occ'
+    add _ tidy_env = tidy_env      
+
+data ReportErrCtxt 
+    = CEC { cec_encl :: [Implication]  -- Enclosing implications
+                	       	       --   (innermost first)
+          , cec_tidy :: TidyEnv
+          , cec_extra :: SDoc	       -- Add this to each error message
+      }
+
+reportTidyImplic :: ReportErrCtxt -> Implication -> TcM ()
+reportTidyImplic ctxt implic
+  = reportTidyWanteds ctxt' (ic_wanted implic)
+  where
+    ctxt' = ctxt { cec_encl = implic : cec_encl ctxt }
+  
+reportTidyWanteds :: ReportErrCtxt -> WantedConstraints -> TcM ()
+reportTidyWanteds ctxt unsolved
+  = do { let (flats, implics) = splitWanteds unsolved
+             (ambigs, others) = partition is_ambiguous (bagToList flats)
+       ; groupErrs (reportFlat ctxt) others
+       ; mapBagM_ (reportTidyImplic ctxt) implics
+       ; ifErrsM (return ()) $
+       	   -- Only report ambiguity if no other errors happened
+	   -- See Note [Avoiding spurious errors]
+         reportAmbigErrs ctxt skols ambigs }
+  where
+    skols = foldr (unionVarSet . ic_skols) emptyVarSet (cec_encl ctxt)
+ 
+	-- Treat it as "ambiguous" if 
+	--   (a) it is a class constraint
+        --   (b) it constrains only type variables
+	--       (else we'd prefer to report it as "no instance for...")
+        --   (c) it mentions type variables that are not skolems
+    is_ambiguous d = isTyVarClassPred pred
+                  && not (tyVarsOfPred pred `subVarSet` skols)
+		  where   
+                     pred = wantedEvVarPred d
+
+reportFlat :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
+reportFlat ctxt flats loc
+  = do { unless (null dicts) $ reportDictErrs ctxt dicts loc
+       ; unless (null eqs)   $ reportEqErrs   ctxt eqs   loc
+       ; unless (null ips)   $ reportIPErrs   ctxt ips   loc
+       ; ASSERT( null others ) return () }
+  where
+    (dicts, non_dicts) = partition isClassPred flats
+    (eqs, non_eqs)     = partition isEqPred    non_dicts
+    (ips, others)      = partition isIPPred    non_eqs
+
+--------------------------------------------
+--      Support code 
+--------------------------------------------
+
+groupErrs :: ([PredType] -> WantedLoc -> TcM ()) -- Deal with one group
+	  -> [WantedEvVar]		         -- Unsolved wanteds
+          -> TcM ()
+-- Group together insts with the same origin
+-- We want to report them together in error messages
+
+groupErrs _ [] 
+  = return ()
+groupErrs report_err (wanted : wanteds)
+  = do	{ setCtLoc the_loc $ report_err the_vars the_loc
+	; groupErrs report_err others }
+  where
+   the_loc           = wantedEvVarLoc wanted
+   the_key	     = mk_key the_loc
+   the_vars          = map wantedEvVarPred (wanted:friends)
+   (friends, others) = partition is_friend wanteds
+   is_friend friend  = mk_key (wantedEvVarLoc friend) == the_key
+
+   mk_key :: WantedLoc -> (SrcSpan, String)
+   mk_key loc = (ctLocSpan loc, showSDoc (ppr (ctLocOrigin loc)))
+	-- It may seem crude to compare the error messages,
+	-- but it makes sure that we combine just what the user sees,
+	-- and it avoids need equality on InstLocs.
+
+-- Add the "arising from..." part to a message about bunch of dicts
+addArising :: WantedLoc -> SDoc -> SDoc
+addArising loc msg = msg $$ nest 2 (pprArising loc)
+
+pprWithArising :: [WantedEvVar] -> (WantedLoc, SDoc)
+-- Print something like
+--    (Eq a) arising from a use of x at y
+--    (Show a) arising froma use of p at q
+-- Also return a location for the erroe message
+pprWithArising [] 
+  = panic "pprWithArising"
+pprWithArising [WantedEvVar ev loc] 
+  = (loc, pprEvVarTheta [ev] <+> pprArising loc)
+pprWithArising ev_vars
+  = (first_loc, vcat (map ppr_one ev_vars))
+  where
+    first_loc = wantedEvVarLoc (head ev_vars)
+    ppr_one (WantedEvVar v loc) 
+       = parens (pprPred (evVarPred v)) <+> pprArisingAt loc
+
+addErrorReport :: ReportErrCtxt -> SDoc -> TcM ()
+addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt)
+
+pprErrCtxtLoc :: ReportErrCtxt -> SDoc
+pprErrCtxtLoc ctxt 
+  = case map (ctLocOrigin . ic_loc) (cec_encl ctxt) of
+       []           -> ptext (sLit "the top level")	-- Should not happen
+       (orig:origs) -> ppr_skol orig $$ 
+                       vcat [ ptext (sLit "or") <+> ppr_skol orig | orig <- origs ]
+  where
+    ppr_skol (PatSkol dc _) = ptext (sLit "the data constructor") <+> quotes (ppr dc)
+    ppr_skol skol_info      = pprSkolInfo skol_info
+
+couldNotDeduce :: [EvVar] -> [PredType] -> SDoc
+couldNotDeduce givens wanteds
+  = sep [ ptext (sLit "Could not deduce") <+> pprTheta wanteds
+        , nest 2 $ ptext (sLit "from the context") 
+                     <+> pprEvVarTheta givens]
+
+getUserGivens :: ReportErrCtxt -> Maybe [EvVar]
+-- Just gs => Say "could not deduce ... from gs"
+-- Nothing => No interesting givens, say something else
+getUserGivens (CEC {cec_encl = ctxt})
+  | null user_givens = Nothing
+  | otherwise        = Just user_givens
+  where 
+    givens = foldl (\gs ic -> ic_given ic ++ gs) [] ctxt
+    user_givens | opt_PprStyle_Debug = givens
+                | otherwise          = filterOut isSelfDict givens
+       -- In user mode, don't show the "self-dict" given
+       -- which is only added to do co-inductive solving
+       -- Rather an awkward hack, but there we are
+       -- This is the only use of isSelfDict, so it's not in an inner loop
+\end{code}
+
+
+%************************************************************************
+%*									*
+                Implicit parameter errors
+%*									*
+%************************************************************************
+
+\begin{code}
+reportIPErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
+reportIPErrs ctxt ips loc
+  = addErrorReport ctxt $ addArising loc msg
+  where
+    msg | Just givens <- getUserGivens ctxt
+        = couldNotDeduce givens ips
+        | otherwise
+        = sep [ ptext (sLit "Unbound implicit parameter") <> plural ips
+              , nest 2 (pprTheta ips) ] 
+\end{code}
+
+
+%************************************************************************
+%*									*
+                Equality errors
+%*									*
+%************************************************************************
+
+\begin{code}
+reportEqErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()
+reportEqErrs ctxt eqs loc = mapM_ (reportEqErr ctxt loc) eqs 
+
+reportEqErr :: ReportErrCtxt -> WantedLoc -> PredType -> TcM ()
+reportEqErr ctxt loc pred@(EqPred ty1 ty2)
+  | Just tv1 <- tcGetTyVar_maybe ty1 = reportTyVarEqErr ctxt loc tv1 ty2
+  | Just tv2 <- tcGetTyVar_maybe ty2 = reportTyVarEqErr ctxt loc tv2 ty1
+  | otherwise	-- Neither side is a type variable
+    		-- Since the unsolved constraint is canonical, 
+		-- it must therefore be of form (F tys ~ ty)
+  = addErrorReport ctxt (msg $$ mkTyFunInfoMsg ty1 ty2)
+  where
+    msg = case getUserGivens ctxt of
+            Just givens -> couldNotDeduce givens [pred]
+            Nothing     -> misMatchMsg ty1 ty2
+
+reportEqErr _ _ _ = panic "reportEqErr"	  -- Must be equality pred
+
+reportTyVarEqErr :: ReportErrCtxt -> WantedLoc
+                 -> TcTyVar -> TcType -> TcM ()
+reportTyVarEqErr ctxt loc tv1 ty2
+  | not is_meta1
+  , Just tv2 <- tcGetTyVar_maybe ty2
+  , isMetaTyVar tv2
+  = -- sk ~ alpha: swap
+    reportTyVarEqErr ctxt loc tv2 ty1
+
+  | not is_meta1
+  = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match
+    addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
+
+  -- So tv is a meta tyvar, and presumably it is
+  -- an *untouchable* meta tyvar, else it'd have been unified
+  | not (k2 `isSubKind` k1)   	 -- Kind error
+  = addErrorReport ctxt $ (kindErrorMsg (mkTyVarTy tv1) ty2)
+
+  -- Check for skolem escape
+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
+  , let esc_skols = varSetElems (tyVarsOfType ty2 `intersectVarSet` ic_skols implic)
+        implic_loc = ic_loc implic
+  , not (null esc_skols)
+  = setCtLoc implic_loc $	-- Override the error message location from the
+    	     			-- place the equality arose to the implication site
+    do { (env1, env_sigs) <- findGlobals ctxt (unitVarSet tv1)
+       ; let msg = misMatchMsg ty1 ty2
+             esc_doc | isSingleton esc_skols 
+                     = ptext (sLit "because this skolem type variable would escape:")
+                     | otherwise
+                     = ptext (sLit "because these skolem type variables would escape:")
+             extra1 = vcat [ nest 2 $ esc_doc <+> pprQuotedList esc_skols
+                           , sep [ (if isSingleton esc_skols 
+                                      then ptext (sLit "This skolem is")
+                                      else ptext (sLit "These skolems are"))
+                                   <+> ptext (sLit "bound by")
+                                 , nest 2 $ pprSkolInfo (ctLocOrigin implic_loc) ] ]
+       ; addErrTcM (env1, msg $$ extra1 $$ mkEnvSigMsg (ppr tv1) env_sigs) }
+
+  -- Nastiest case: attempt to unify an untouchable variable
+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context
+  , let implic_loc = ic_loc implic
+        given      = ic_given implic
+  = setCtLoc (ic_loc implic) $
+    do { let (env1, msg) = misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2
+             extra = vcat [ ptext (sLit "because") <+> ppr tv1 <+> ptext (sLit "is untouchable")
+                          , ptext (sLit "inside the constraints") <+> pprEvVarTheta given 
+                          , nest 2 (ptext (sLit "bound at")
+                             <+> pprSkolInfo (ctLocOrigin implic_loc)) ]
+       ; addErrTcM (env1, msg $$ extra) }
+
+  | otherwise	   -- I'm not sure how this can happen!
+  = addErrTcM (misMatchMsgWithExtras (cec_tidy ctxt) ty1 ty2)
+  where         
+    is_meta1 = isMetaTyVar tv1
+    k1 	     = tyVarKind tv1
+    k2 	     = typeKind ty2
+    ty1      = mkTyVarTy tv1
+
+mkTyFunInfoMsg :: TcType -> TcType -> SDoc
+-- See Note [Non-injective type functions]
+mkTyFunInfoMsg ty1 ty2
+  | Just (tc1,_) <- tcSplitTyConApp_maybe ty1
+  , Just (tc2,_) <- tcSplitTyConApp_maybe ty2
+  , tc1 == tc2, isSynFamilyTyCon tc1
+  = ptext (sLit "NB:") <+> quotes (ppr tc1) 
+    <+> ptext (sLit "is a type function") <> (pp_inj tc1)
+  | otherwise = empty
+  where       
+    pp_inj tc | isInjectiveTyCon tc = empty
+              | otherwise = ptext (sLit (", and may not be injective"))
+
+misMatchMsgWithExtras :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
+-- This version is used by TcSimplify too, which doesn't track the
+-- expected/acutal thing, so we just have ty1 ty2 here
+-- NB: The types are already tidied
+misMatchMsgWithExtras env ty1 ty2
+  = (env2, sep [ misMatchMsg ty1 ty2, nest 2 (extra1 $$ extra2) ])
+  where
+    (env1, extra1) = typeExtraInfoMsg env ty1
+    (env2, extra2) = typeExtraInfoMsg env1 ty2
+
+misMatchMsg :: TcType -> TcType -> SDoc	   -- Types are already tidy
+misMatchMsg ty1 ty2 = sep [ ptext (sLit "Couldn't match type") <+> quotes (ppr ty1)
+	                  , nest 15 $ ptext (sLit "with") <+> quotes (ppr ty2)]
+
+kindErrorMsg :: TcType -> TcType -> SDoc   -- Types are already tidy
+kindErrorMsg ty1 ty2
+  = vcat [ ptext (sLit "Kind incompatibility when matching types:")
+         , nest 2 (vcat [ ppr ty1 <+> dcolon <+> ppr k1
+                        , ppr ty2 <+> dcolon <+> ppr k2 ]) ]
+  where
+    k1 = typeKind ty1
+    k2 = typeKind ty2
+
+typeExtraInfoMsg :: TidyEnv -> Type -> (TidyEnv, SDoc)
+-- Shows a bit of extra info about skolem constants
+typeExtraInfoMsg env ty 
+  | Just tv <- tcGetTyVar_maybe ty
+  , isTcTyVar tv
+  , isSkolemTyVar tv || isSigTyVar tv
+  , not (isUnk tv)
+  , let (env1, tv1) = tidySkolemTyVar env tv
+  = (env1, pprSkolTvBinding tv1)
+  where
+typeExtraInfoMsg env _ty = (env, empty)		-- Normal case
+\end{code}
+
+Note [Non-injective type functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's very confusing to get a message like
+     Couldn't match expected type `Depend s'
+            against inferred type `Depend s1'
+so mkTyFunInfoMsg adds:
+       NB: `Depend' is type function, and hence may not be injective
+
+Warn of loopy local equalities that were dropped.
+
+
+%************************************************************************
+%*									*
+                 Type-class errors
+%*									*
+%************************************************************************
+
+\begin{code}
+reportDictErrs :: ReportErrCtxt -> [PredType] -> WantedLoc -> TcM ()	
+reportDictErrs ctxt wanteds loc
+  = do { inst_envs <- tcGetInstEnvs
+       ; let (others, overlaps) = partitionWith (check_overlap inst_envs) wanteds
+       ; unless (null others) $
+         addErrorReport ctxt (mk_no_inst_err others) 
+       ; mapM_ (addErrorReport ctxt) overlaps }
+  where
+    check_overlap :: (InstEnv,InstEnv) -> PredType -> Either PredType SDoc
+	-- Right msg  => overlap message
+	-- Left  inst => no instance
+    check_overlap inst_envs pred@(ClassP clas tys)
+	= case lookupInstEnv inst_envs clas tys of
+		([], _) -> Left pred		-- No match
+		-- The case of exactly one match and no unifiers means a
+		-- successful lookup.  That can't happen here, because dicts
+		-- only end up here if they didn't match in Inst.lookupInst
+		([_],[])
+		 | debugIsOn -> pprPanic "check_overlap" (ppr pred)
+		res -> Right (mk_overlap_msg pred res)
+    check_overlap _ _ = panic "check_overlap"
+
+    mk_overlap_msg pred (matches, unifiers)
+      = ASSERT( not (null matches) )
+        vcat [	addArising loc (ptext (sLit "Overlapping instances for") 
+				<+> pprPred pred)
+    	     ,	sep [ptext (sLit "Matching instances") <> colon,
+    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])]
+	     ,	if not (isSingleton matches)
+    		then 	-- Two or more matches
+		     empty
+    		else 	-- One match, plus some unifiers
+		ASSERT( not (null unifiers) )
+		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
+	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))),
+			      ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
+			      ptext (sLit "when compiling the other instance declarations")])]
+      where
+    	ispecs = [ispec | (ispec, _) <- matches]
+
+    mk_no_inst_err :: [PredType] -> SDoc
+    mk_no_inst_err wanteds
+      | Just givens <- getUserGivens ctxt
+      = vcat [ addArising loc $ couldNotDeduce givens wanteds
+	     , show_fixes (fix1 : fixes2) ]
+
+      | otherwise	-- Top level 
+      = vcat [ addArising loc $
+	       ptext (sLit "No instance") <> plural wanteds
+		    <+> ptext (sLit "for") <+> pprTheta wanteds
+	     , show_fixes fixes2 ]
+
+      where
+    	fix1 = sep [ ptext (sLit "add") <+> pprTheta wanteds 
+                          <+> ptext (sLit "to the context of")
+	           , nest 2 $ pprErrCtxtLoc ctxt ]
+
+    	fixes2 | null instance_dicts = []
+	       | otherwise	     = [sep [ptext (sLit "add an instance declaration for"),
+				        pprTheta instance_dicts]]
+	instance_dicts = filterOut isTyVarClassPred wanteds
+		-- Insts for which it is worth suggesting an adding an 
+		-- instance declaration.  Exclude tyvar dicts.
+
+	show_fixes :: [SDoc] -> SDoc
+	show_fixes []     = empty
+	show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), 
+				 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
+
+reportAmbigErrs :: ReportErrCtxt -> TcTyVarSet -> [WantedEvVar] -> TcM ()
+reportAmbigErrs ctxt skols ambigs 
+-- Divide into groups that share a common set of ambiguous tyvars
+  = mapM_ report (equivClasses cmp ambigs_w_tvs)
+  where
+    ambigs_w_tvs = [ (d, varSetElems (tyVarsOfWantedEvVar d `minusVarSet` skols))
+                   | d <- ambigs ]
+    cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
+
+    report :: [(WantedEvVar, [TcTyVar])] -> TcM ()
+    report pairs
+       = setCtLoc loc $
+         do { let main_msg = sep [ text "Ambiguous type variable" <> plural tvs
+	         	           <+> pprQuotedList tvs
+                                   <+> text "in the constraint" <> plural pairs <> colon
+                                 , nest 2 pp_wanteds ]
+             ; (tidy_env, mono_msg) <- mkMonomorphismMsg ctxt tvs
+            ; addErrTcM (tidy_env, main_msg $$ mono_msg) }
+       where
+         (_, tvs) : _ = pairs
+         (loc, pp_wanteds) = pprWithArising (map fst pairs)
+
+mkMonomorphismMsg :: ReportErrCtxt -> [TcTyVar] -> TcM (TidyEnv, SDoc)
+-- There's an error with these Insts; if they have free type variables
+-- it's probably caused by the monomorphism restriction. 
+-- Try to identify the offending variable
+-- ASSUMPTION: the Insts are fully zonked
+mkMonomorphismMsg ctxt inst_tvs
+  = do	{ dflags <- getDOpts
+	; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs)
+	; return (tidy_env, mk_msg dflags docs) }
+  where
+    mk_msg _ _ | any isRuntimeUnk inst_tvs
+        =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
+                   (pprWithCommas ppr inst_tvs),
+                ptext (sLit "Use :print or :force to determine these types")]
+    mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
+			-- This happens in things like
+			--	f x = show (read "foo")
+			-- where monomorphism doesn't play any role
+    mk_msg dflags docs 
+	= vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
+		nest 2 (vcat docs),
+		monomorphism_fix dflags]
+
+monomorphism_fix :: DynFlags -> SDoc
+monomorphism_fix dflags
+  = ptext (sLit "Probable fix:") <+> vcat
+	[ptext (sLit "give these definition(s) an explicit type signature"),
+	 if dopt Opt_MonomorphismRestriction dflags
+           then ptext (sLit "or use -XNoMonomorphismRestriction")
+           else empty]	-- Only suggest adding "-XNoMonomorphismRestriction"
+			-- if it is not already set!
+
+
+-----------------------
+-- findGlobals looks at the value environment and finds values whose
+-- types mention any of the offending type variables.  It has to be
+-- careful to zonk the Id's type first, so it has to be in the monad.
+-- We must be careful to pass it a zonked type variable, too.
+
+mkEnvSigMsg :: SDoc -> [SDoc] -> SDoc
+mkEnvSigMsg what env_sigs
+ | null env_sigs = empty
+ | otherwise = vcat [ ptext (sLit "The following variables have types that mention") <+> what
+                    , nest 2 (vcat env_sigs) ]
+
+findGlobals :: ReportErrCtxt
+            -> TcTyVarSet
+            -> TcM (TidyEnv, [SDoc])
+
+findGlobals ctxt tvs 
+  = do { lcl_ty_env <- case cec_encl ctxt of 
+                        []    -> getLclTypeEnv
+                        (i:_) -> return (ic_env i)
+       ; go (cec_tidy ctxt) [] (nameEnvElts lcl_ty_env) }
+  where
+    go tidy_env acc [] = return (tidy_env, acc)
+    go tidy_env acc (thing : things) = do
+        (tidy_env1, maybe_doc) <- find_thing tidy_env ignore_it thing
+	case maybe_doc of
+	  Just d  -> go tidy_env1 (d:acc) things
+	  Nothing -> go tidy_env1 acc     things
+
+    ignore_it ty = tvs `disjointVarSet` tyVarsOfType ty
+
+-----------------------
+find_thing :: TidyEnv -> (TcType -> Bool)
+           -> TcTyThing -> TcM (TidyEnv, Maybe SDoc)
+find_thing tidy_env ignore_it (ATcId { tct_id = id })
+  = do { id_ty <- zonkTcType  (idType id)
+       ; if ignore_it id_ty then
+	   return (tidy_env, Nothing)
+         else do 
+       { let (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty
+	     msg = sep [ ppr id <+> dcolon <+> ppr tidy_ty
+		       , nest 2 (parens (ptext (sLit "bound at") <+>
+			 	   ppr (getSrcLoc id)))]
+       ; return (tidy_env', Just msg) } }
+
+find_thing tidy_env ignore_it (ATyVar tv ty)
+  = do { tv_ty <- zonkTcType ty
+       ; if ignore_it tv_ty then
+	    return (tidy_env, Nothing)
+         else do
+       { let -- The name tv is scoped, so we don't need to tidy it
+	    (tidy_env1, tidy_ty) = tidyOpenType  tidy_env tv_ty
+            msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
+                      , nest 2 bound_at]
+
+	    eq_stuff | Just tv' <- tcGetTyVar_maybe tv_ty 
+		     , getOccName tv == getOccName tv' = empty
+		     | otherwise = equals <+> ppr tidy_ty
+		-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
+	    bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
+ 
+       ; return (tidy_env1, Just msg) } }
+
+find_thing _ _ thing = pprPanic "find_thing" (ppr thing)
+
+warnDefaulting :: [WantedEvVar] -> Type -> TcM ()
+warnDefaulting wanteds default_ty
+  = do { warn_default <- doptM Opt_WarnTypeDefaults
+       ; setCtLoc loc $ warnTc warn_default warn_msg }
+  where
+	-- Tidy them first
+    warn_msg  = vcat [ ptext (sLit "Defaulting the following constraint(s) to type") <+>
+				quotes (ppr default_ty),
+		      nest 2 ppr_wanteds ]
+    (loc, ppr_wanteds) = pprWithArising wanteds
+\end{code}
+
+%************************************************************************
+%*									*
+                 Error from the canonicaliser
+%*									*
+%************************************************************************
+
+\begin{code}
+kindErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
+kindErrorTcS fl ty1 ty2
+  = wrapErrTcS        $ 
+    setCtFlavorLoc fl $ 
+    do { env0 <- tcInitTidyEnv
+       ; let (env1, ty1') = tidyOpenType env0 ty1
+             (env2, ty2') = tidyOpenType env1 ty2
+       ; failWithTcM (env2, kindErrorMsg ty1' ty2') }
+
+misMatchErrorTcS :: CtFlavor -> TcType -> TcType -> TcS a
+misMatchErrorTcS fl ty1 ty2
+  = wrapErrTcS        $ 
+    setCtFlavorLoc fl $ 
+    do { env0 <- tcInitTidyEnv
+       ; let (env1, ty1') = tidyOpenType env0 ty1
+             (env2, ty2') = tidyOpenType env1 ty2
+             (env3, msg)  = misMatchMsgWithExtras env2 ty1' ty2'
+       ; failWithTcM (env3, inaccessible_msg $$ msg) }
+  where
+    inaccessible_msg 
+      = case fl of 
+          Given loc -> hang (ptext (sLit "Inaccessible code in"))
+                          2 (mk_what loc)
+          _         -> empty
+    mk_what loc 
+      = case ctLocOrigin loc of
+          PatSkol dc mc -> sep [ ptext (sLit "a pattern with constructor") 
+                                   <+> quotes (ppr dc) <> comma
+                               , ptext (sLit "in") <+> pprMatchContext mc ]
+	  other_skol -> pprSkolInfo other_skol
+
+occursCheckErrorTcS :: CtFlavor -> TcTyVar -> TcType -> TcS a
+occursCheckErrorTcS fl tv ty
+  = wrapErrTcS           $ 
+    setCtFlavorLoc fl $ 
+    do	{ env0          <- tcInitTidyEnv
+	; let (env1, tv') = tidyOpenTyVar env0 tv
+	      (env2, ty') = tidyOpenType env1 ty
+	      extra = sep [ppr tv', char '=', ppr ty']
+	; failWithTcM (env2, hang msg 2 extra) }
+  where
+    msg = text $ "Occurs check: cannot construct the infinite type:"
+
+setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a
+setCtFlavorLoc (Wanted  loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing
+setCtFlavorLoc (Given loc)   thing = setCtLoc loc thing
+
+solverDepthErrorTcS :: Int -> [CanonicalCt] -> TcS a
+solverDepthErrorTcS depth stack
+  | null stack	    -- Shouldn't happen unless you say -fcontext-stack=0
+  = wrapErrTcS $ failWith msg
+  | otherwise
+  = wrapErrTcS $ 
+    setCtFlavorLoc (cc_flavor top_item) $
+    do { env0 <- tcInitTidyEnv
+       ; let ev_vars  = map cc_id stack
+             env1     = tidyFreeTyVars env0 free_tvs
+             free_tvs = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet ev_vars
+             extra    = pprEvVars (map (tidyEvVar env1) ev_vars)
+       ; failWithTcM (env1, hang msg 2 extra) }
+  where
+    top_item = head stack
+    msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
+               , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
+
+flattenForAllErrorTcS :: CtFlavor -> TcType -> Bag CanonicalCt -> TcS a
+flattenForAllErrorTcS fl ty _bad_eqs
+  = wrapErrTcS           $ 
+    setCtFlavorLoc fl $ 
+    do { env0 <- tcInitTidyEnv
+       ; let (env1, ty') = tidyOpenType env0 ty 
+             msg = sep [ ptext (sLit "Cannot deal with a type function under a forall type:")
+                       , ppr ty' ]
+       ; failWithTcM (env1, msg) }
+\end{code}
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index d7118e1..03e0687 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -5,7 +5,6 @@
 \section[TcExpr]{Typecheck an expression}
 
 \begin{code}
-{-# OPTIONS -w #-}
 -- The above warning supression flag is a temporary kludge.
 -- While working on this module you are encouraged to remove it and fix
 -- any warnings in the module. See
@@ -13,7 +12,8 @@
 -- for details
 
 module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC, 
-                tcInferRho, tcInferRhoNC, tcSyntaxOp, 
+                tcInferRho, tcInferRhoNC, 
+                tcSyntaxOp, tcCheckId,
                 addExprErrCtxt ) where
 
 #include "HsVersions.h"
@@ -37,30 +37,25 @@ import TcHsType
 import TcPat
 import TcMType
 import TcType
-import TcIface	( checkWiredInTyCon )
 import Id
 import DataCon
 import Name
 import TyCon
 import Type
-import TypeRep
 import Coercion
 import Var
 import VarSet
 import TysWiredIn
+import TysPrim( intPrimTy )
+import PrimOp( tagToEnumKey )
 import PrelNames
-import PrimOp
 import DynFlags
-import StaticFlags
-import HscTypes
 import SrcLoc
 import Util
 import ListSetOps
 import Maybes
 import Outputable
 import FastString
-
-import Data.List( partition )
 import Control.Monad
 \end{code}
 
@@ -72,47 +67,30 @@ import Control.Monad
 
 \begin{code}
 tcPolyExpr, tcPolyExprNC
-	 :: LHsExpr Name		-- Expession to type check
-       	 -> BoxySigmaType		-- Expected type (could be a polytpye)
+	 :: LHsExpr Name	-- Expression to type check
+       	 -> TcSigmaType		-- Expected type (could be a polytpye)
        	 -> TcM (LHsExpr TcId)	-- Generalised expr with expected type
 
--- tcPolyExpr is a convenient place (frequent but not too frequent) place
--- to add context information.
+-- tcPolyExpr is a convenient place (frequent but not too frequent)
+-- place to add context information.
 -- The NC version does not do so, usually because the caller wants
 -- to do so himself.
 
 tcPolyExpr expr res_ty 	
   = addExprErrCtxt expr $
-    (do {traceTc (text "tcPolyExpr") ; tcPolyExprNC expr res_ty })
-
-tcPolyExprNC expr res_ty 
-  | isSigmaTy res_ty
-  = do	{ traceTc (text "tcPolyExprNC" <+> ppr res_ty)
-	; (gen_fn, expr') <- tcGen res_ty emptyVarSet Nothing $ \ _ res_ty ->
-			     tcPolyExprNC expr res_ty
-		-- Note the recursive call to tcPolyExpr, because the
-		-- type may have multiple layers of for-alls
-		-- E.g. forall a. Eq a => forall b. Ord b => ....
-	; return (mkLHsWrap gen_fn expr') }
-
-  | otherwise
-  = tcMonoExprNC expr res_ty
+    do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty }
 
----------------
-tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
-tcPolyExprs [] [] = return []
-tcPolyExprs (expr:exprs) (ty:tys)
- = do 	{ expr'  <- tcPolyExpr  expr  ty
-	; exprs' <- tcPolyExprs exprs tys
-	; return (expr':exprs') }
-tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
+tcPolyExprNC expr res_ty
+  = do { traceTc "tcPolyExprNC" (ppr res_ty)
+       ; (gen_fn, expr') <- tcGen (GenSkol res_ty) emptyVarSet res_ty $ \ _ rho ->
+			    tcMonoExprNC expr rho
+       ; return (mkLHsWrap gen_fn expr') }
 
 ---------------
 tcMonoExpr, tcMonoExprNC 
-    :: LHsExpr Name	-- Expression to type check
-    -> BoxyRhoType 	-- Expected type (could be a type variable)
-			-- Definitely no foralls at the top
-			-- Can contain boxes, which will be filled in
+    :: LHsExpr Name      -- Expression to type check
+    -> TcRhoType         -- Expected type (could be a type variable)
+			 -- Definitely no foralls at the top
     -> TcM (LHsExpr TcId)
 
 tcMonoExpr expr res_ty
@@ -127,8 +105,27 @@ tcMonoExprNC (L loc expr) res_ty
 
 ---------------
 tcInferRho, tcInferRhoNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
-tcInferRho   expr = tcInfer (tcMonoExpr expr)
-tcInferRhoNC expr = tcInfer (tcMonoExprNC expr)
+-- Infer a *rho*-type.  This is, in effect, a special case
+-- for ids and partial applications, so that if
+--     f :: Int -> (forall a. a -> a) -> Int
+-- then we can infer
+--     f 3 :: (forall a. a -> a) -> Int
+-- And that in turn is useful 
+--  (a) for the function part of any application (see tcApp)
+--  (b) for the special rule for '$'
+tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)
+
+tcInferRhoNC (L loc expr)
+  = setSrcSpan loc $
+    do { (expr', rho) <- tcInfExpr expr
+       ; return (L loc expr', rho) }
+
+tcInfExpr :: HsExpr Name -> TcM (HsExpr TcId, TcRhoType)
+tcInfExpr (HsVar f) 	= tcInferId f
+tcInfExpr (HsPar e) 	= do { (e', ty) <- tcInferRhoNC e
+                             ; return (HsPar e', ty) }
+tcInfExpr (HsApp e1 e2) = tcInferApp e1 [e2]                                  
+tcInfExpr e             = tcInfer (tcExpr e)
 \end{code}
 
 
@@ -139,32 +136,34 @@ tcInferRhoNC expr = tcInfer (tcMonoExprNC expr)
 %************************************************************************
 
 \begin{code}
-tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
+tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
 tcExpr e res_ty | debugIsOn && isSigmaTy res_ty     -- Sanity check
        	        = pprPanic "tcExpr: sigma" (ppr res_ty $$ ppr e)
 
-tcExpr (HsVar name)     res_ty = tcId (OccurrenceOf name) name res_ty
+tcExpr (HsVar name)  res_ty = tcCheckId name res_ty
 
-tcExpr (HsLit lit)	res_ty = do { let lit_ty = hsLitType lit
-				    ; coi <- boxyUnify lit_ty res_ty
-				    ; return $ mkHsWrapCoI coi (HsLit lit)
-				    }
+tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty
 
-tcExpr (HsPar expr)     res_ty = do { expr' <- tcMonoExprNC expr res_ty
-				    ; return (HsPar expr') }
+tcExpr (HsLit lit)   res_ty = do { let lit_ty = hsLitType lit
+		     	         ; tcWrapResult (HsLit lit) lit_ty res_ty }
+
+tcExpr (HsPar expr)  res_ty = do { expr' <- tcMonoExprNC expr res_ty
+				 ; return (HsPar expr') }
+
+tcExpr (HsSCC lbl expr) res_ty 
+  = do { expr' <- tcMonoExpr expr res_ty
+       ; return (HsSCC lbl expr') }
 
-tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
-				    ; return (HsSCC lbl expr') }
 tcExpr (HsTickPragma info expr) res_ty 
-       		     	       = do { expr' <- tcMonoExpr expr res_ty
-				    ; return (HsTickPragma info expr') }
+  = do { expr' <- tcMonoExpr expr res_ty
+       ; return (HsTickPragma info expr') }
 
-tcExpr (HsCoreAnn lbl expr) res_ty 	 -- hdaume: core annotation
+tcExpr (HsCoreAnn lbl expr) res_ty
   = do	{ expr' <- tcMonoExpr expr res_ty
 	; return (HsCoreAnn lbl expr') }
 
 tcExpr (HsOverLit lit) res_ty  
-  = do 	{ lit' <- tcOverloadedLit (LiteralOrigin lit) lit res_ty
+  = do 	{ lit' <- newOverloadedLit (LiteralOrigin lit) lit res_ty
 	; return (HsOverLit lit') }
 
 tcExpr (NegApp expr neg_expr) res_ty
@@ -180,39 +179,29 @@ tcExpr (HsIPVar ip) res_ty
 		-- type variable as its type.  (Because res_ty may not
 		-- be a tau-type.)
 	; ip_ty <- newFlexiTyVarTy argTypeKind	-- argTypeKind: it can't be an unboxed tuple
-	; co_fn <- tcSubExp origin ip_ty res_ty
-	; (ip', inst) <- newIPDict origin ip ip_ty
-	; extendLIE inst
-	; return (mkHsWrap co_fn (HsIPVar ip')) }
-
-tcExpr (HsApp e1 e2) res_ty 
-  = go e1 [e2]
-  where
-    go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId)
-    go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
-    go lfun@(L loc fun) args
-	= do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $
-				tcApp fun (length args) (tcArgs lfun args) res_ty
-	     ; traceTc (text "tcExpr args': " <+> ppr args')
-	     ; return (unLoc (foldl mkHsApp (L loc fun') args')) }
+	; ip_var <- emitWanted origin (mkIPPred ip ip_ty)
+	; tcWrapResult (HsIPVar (IPName ip_var)) ip_ty res_ty }
 
 tcExpr (HsLam match) res_ty
   = do	{ (co_fn, match') <- tcMatchLambda match res_ty
 	; return (mkHsWrap co_fn (HsLam match')) }
 
-tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
- = do	{ sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
+tcExpr (ExprWithTySig expr sig_ty) res_ty
+ = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
+
+      -- Remember to extend the lexical type-variable environment
+      ; (gen_fn, expr') 
+            <- tcGen (SigSkol ExprSigCtxt) emptyVarSet sig_tc_ty $ \ skol_tvs res_ty ->
+      	       tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
+	             	       	-- See Note [More instantiated than scoped] in TcBinds
+      	       tcMonoExprNC expr res_ty
 
-	-- Remember to extend the lexical type-variable environment
-	; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (Just ExprSigCtxt) $ \ skol_tvs res_ty ->
-		             tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
-				-- See Note [More instantiated than scoped] in TcBinds
-			     tcMonoExprNC expr res_ty
+      ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty
 
-	; co_fn <- tcSubExp ExprSigOrigin sig_tc_ty res_ty
-	; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
+      ; (inst_wrap, rho) <- deeplyInstantiate ExprSigOrigin sig_tc_ty
+      ; tcWrapResult (mkHsWrap inst_wrap inner_expr) rho res_ty }
 
-tcExpr (HsType ty) res_ty
+tcExpr (HsType ty) _
   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
 	-- This is the syntax for type applications that I was planning
 	-- but there are difficulties (e.g. what order for type args)
@@ -228,94 +217,156 @@ tcExpr (HsType ty) res_ty
 %*									*
 %************************************************************************
 
+Note [Left sections]
+~~~~~~~~~~~~~~~~~~~~
+Left sections, like (4 *), are equivalent to
+	\ x -> (*) 4 x,
+or, if PostfixOperators is enabled, just
+	(*) 4
+With PostfixOperators we don't actually require the function to take
+two arguments at all.  For example, (x `not`) means (not x); you get
+postfix operators!  Not Haskell 98, but it's less work and kind of
+useful.
+
+Note [Typing rule for ($)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+People write 
+   runST $ blah
+so much, where 
+   runST :: (forall s. ST s a) -> a
+that I have finally given in and written a special type-checking
+rule just for saturated appliations of ($).  
+  * Infer the type of the first argument
+  * Decompose it; should be of form (arg2_ty -> res_ty), 
+       where arg2_ty might be a polytype
+  * Use arg2_ty to typecheck arg2
+
+Note [Typing rule for seq]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to allow
+       x `seq` (# p,q #)
+which suggests this type for seq:
+   seq :: forall (a:*) (b:??). a -> b -> b, 
+with (b:??) meaning that be can be instantiated with an unboxed tuple.
+But that's ill-kinded!  Function arguments can't be unboxed tuples.
+And indeed, you could not expect to do this with a partially-applied
+'seq'; it's only going to work when it's fully applied.  so it turns
+into 
+    case x of _ -> (# p,q #)
+
+For a while I slid by by giving 'seq' an ill-kinded type, but then
+the simplifier eta-reduced an application of seq and Lint blew up 
+with a kind error.  It seems more uniform to treat 'seq' as it it
+was a language construct.  
+
+See Note [seqId magic] in MkId, and 
+
+
 \begin{code}
-tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty
-  = do	{ (op', [arg1', arg2']) <- tcApp op 2 (tcArgs lop [arg1,arg2]) res_ty
-	; return (OpApp arg1' (L loc op') fix arg2') }
-
--- Left sections, equivalent to
---	\ x -> e op x,
--- or
---	\ x -> op e x,
--- or, if PostfixOperators is enabled, just
--- 	op e
---
--- With PostfixOperators we don't
--- actually require the function to take two arguments
--- at all.  For example, (x `not`) means (not x);
--- you get postfix operators!  Not Haskell 98,
--- but it's less work and kind of useful.
-
-tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
-  = do { dflags <- getDOpts
-       ; if dopt Opt_PostfixOperators dflags
-         then do { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
-                 ; return (SectionL arg1' (L loc op')) }
-         else do 
-       { (co_fn, expr')
-             <- subFunTys doc 1 res_ty Nothing $ \ [arg2_ty'] res_ty' ->
-                do { (op', (arg1', co_arg2)) <- tcApp op 2 (tc_args arg2_ty') res_ty'
-		   ; let coi = mkFunTyCoI arg2_ty' co_arg2 res_ty' IdCo
-                   ; return (mkHsWrapCoI coi (SectionL arg1' (L loc op'))) }
-       ; return (mkHsWrap co_fn expr') } }
-  where
-    doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
-		<+> ptext (sLit "takes one argument")
-    tc_args arg2_ty' qtvs qtys [arg1_ty, arg2_ty] 
-	= do { co_arg2 <- boxyUnify (substTyWith qtvs qtys arg2_ty) arg2_ty' 
-	     ; arg1'   <- tcArg lop 1 arg1 qtvs qtys arg1_ty
-	     ; qtys'   <- mapM refineBox qtys	-- c.f. tcArgs 
-	     ; return (qtys', (arg1', co_arg2)) }
-    tc_args _ _ _ _ = panic "tcExpr SectionL"
+tcExpr (OpApp arg1 op fix arg2) res_ty
+  | (L loc (HsVar op_name)) <- op
+  , op_name `hasKey` seqIdKey		-- Note [Typing rule for seq]
+  = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
+       ; let arg2_ty = res_ty
+       ; arg1' <- tcArg op (arg1, arg1_ty, 1)
+       ; arg2' <- tcArg op (arg2, arg2_ty, 2)
+       ; op_id <- tcLookupId op_name
+       ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id))
+       ; return $ OpApp arg1' op' fix arg2' }
+
+  | (L loc (HsVar op_name)) <- op
+  , op_name `hasKey` dollarIdKey	-- Note [Typing rule for ($)]
+  = do { traceTc "Application rule" (ppr op)
+       ; (arg1', arg1_ty) <- tcInferRho arg1
+       ; let doc = ptext (sLit "The first argument of ($) takes")
+       ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty
+       	 -- arg2_ty maybe polymorphic; that's the point
+       ; arg2' <- tcArg op (arg2, arg2_ty, 2)
+       ; co_res <- unifyType op_res_ty res_ty
+       ; op_id <- tcLookupId op_name
+       ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id))
+       ; return $ mkHsWrapCoI co_res $
+         OpApp (mkLHsWrapCoI co_arg1 arg1') op' fix arg2' }
+
+  | otherwise
+  = do { traceTc "Non Application rule" (ppr op)
+       ; (op', op_ty) <- tcInferFun op
+       ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty
+       ; co_res <- unifyType op_res_ty res_ty
+       ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys
+       ; return $ mkHsWrapCoI co_res $
+         OpApp arg1' (mkLHsWrapCoI co_fn op') fix arg2' }
 
 -- Right sections, equivalent to \ x -> x `op` expr, or
 --	\ x -> op x expr
  
-tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
-  = do	{ (co_fn, expr') 
-              <- subFunTys doc 1 res_ty Nothing $ \ [arg1_ty'] res_ty' ->
-		 do { (op', (co_arg1, arg2')) <- tcApp op 2 (tc_args arg1_ty') res_ty'
-		    ; let coi = mkFunTyCoI arg1_ty' co_arg1 res_ty' IdCo
-                    ; return (mkHsWrapCoI coi $ SectionR (L loc op') arg2') }
-	; return (mkHsWrap co_fn expr') }
-  where
-    doc = ptext (sLit "The section") <+> quotes (ppr in_expr)
-		<+> ptext (sLit "takes one argument")
-    tc_args arg1_ty' qtvs qtys [arg1_ty, arg2_ty] 
-	= do { co_arg1 <- boxyUnify (substTyWith qtvs qtys arg1_ty) arg1_ty'
-	     ; arg2'   <- tcArg lop 2 arg2 qtvs qtys arg2_ty 
-	     ; qtys'   <- mapM refineBox qtys	-- c.f. tcArgs 
-	     ; return (qtys', (co_arg1, arg2')) }
-    tc_args arg1_ty' _ _ _ = panic "tcExpr SectionR"
-
--- For tuples, take care to preserve rigidity
--- E.g. 	case (x,y) of ....
--- 	   The scrutinee should have a rigid type if x,y do
--- The general scheme is the same as in tcIdApp
-tcExpr in_expr@(ExplicitTuple tup_args boxity) res_ty
-  = do { let kind = case boxity of { Boxed   -> liftedTypeKind
+tcExpr (SectionR op arg2) res_ty
+  = do { (op', op_ty) <- tcInferFun op
+       ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty
+       ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty
+       ; arg2' <- tcArg op (arg2, arg2_ty, 2)
+       ; return $ mkHsWrapCoI co_res $
+         SectionR (mkLHsWrapCoI co_fn op') arg2' } 
+
+tcExpr (SectionL arg1 op) res_ty
+  = do { (op', op_ty) <- tcInferFun op
+       ; dflags <- getDOpts	    -- Note [Left sections]
+       ; let n_reqd_args | dopt Opt_PostfixOperators dflags = 1
+                         | otherwise                        = 2
+
+       ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty
+       ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty
+       ; arg1' <- tcArg op (arg1, arg1_ty, 1)
+       ; return $ mkHsWrapCoI co_res $
+         SectionL arg1' (mkLHsWrapCoI co_fn op') }
+
+tcExpr (ExplicitTuple tup_args boxity) res_ty
+  | all tupArgPresent tup_args
+  = do { let tup_tc = tupleTyCon boxity (length tup_args)
+       ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
+       ; tup_args1 <- tcTupArgs tup_args arg_tys
+       ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
+    
+  | otherwise
+  = -- The tup_args are a mixture of Present and Missing (for tuple sections)
+    do { let kind = case boxity of { Boxed   -> liftedTypeKind
                                    ; Unboxed -> argTypeKind }
-             arity = length tup_args
+             arity = length tup_args 
              tup_tc = tupleTyCon boxity arity
-             mk_tup_res_ty arg_tys 
+
+       ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind
+       ; let actual_res_ty
                  = mkFunTys [ty | (ty, Missing _) <- arg_tys `zip` tup_args]
                             (mkTyConApp tup_tc arg_tys)
 
-       ; checkWiredInTyCon tup_tc       -- Ensure instances are available
-       ; tvs <- newBoxyTyVars (replicate arity kind)
-       ; let arg_tys1 = map mkTyVarTy tvs
-       ; arg_tys2 <- preSubType tvs (mkVarSet tvs) (mk_tup_res_ty arg_tys1) res_ty
-       
-       ; let go (Missing _,    arg_ty) = return (Missing arg_ty)
-             go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
-			                    ; return (Present expr') }
-       ; tup_args' <- mapM go (tup_args `zip` arg_tys2)
+       ; coi <- unifyType actual_res_ty res_ty
+
+       -- Handle tuple sections where
+       ; tup_args1 <- tcTupArgs tup_args arg_tys
        
-       ; arg_tys3 <- mapM refineBox arg_tys2
-       ; co_fn <- tcSubExp TupleOrigin (mk_tup_res_ty arg_tys3) res_ty
-       ; return (mkHsWrap co_fn (ExplicitTuple tup_args' boxity)) }
+       ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) }
+
+tcExpr (ExplicitList _ exprs) res_ty
+  = do 	{ (coi, elt_ty) <- matchExpectedListTy res_ty
+	; exprs' <- mapM (tc_elt elt_ty) exprs
+	; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
+  where
+    tc_elt elt_ty expr = tcPolyExpr expr elt_ty
+
+tcExpr (ExplicitPArr _ exprs) res_ty	-- maybe empty
+  = do	{ (coi, elt_ty) <- matchExpectedPArrTy res_ty
+    	; exprs' <- mapM (tc_elt elt_ty) exprs	
+	; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
+  where
+    tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 \end{code}
 
+%************************************************************************
+%*									*
+		Let, case, if, do
+%*									*
+%************************************************************************
+
 \begin{code}
 tcExpr (HsLet binds expr) res_ty
   = do	{ (binds', expr') <- tcLocalBinds binds $
@@ -334,7 +385,7 @@ tcExpr (HsCase scrut matches) exp_ty
 	   -- first, to get type info that may be refined in the case alternatives
 	  (scrut', scrut_ty) <- tcInferRho scrut
 
-	; traceTc (text "HsCase" <+> ppr scrut_ty)
+	; traceTc "HsCase" (ppr scrut_ty)
 	; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
 	; return (HsCase scrut' matches') }
  where
@@ -350,34 +401,6 @@ tcExpr (HsIf pred b1 b2) res_ty
 tcExpr (HsDo do_or_lc stmts body _) res_ty
   = tcDoStmts do_or_lc stmts body res_ty
 
-tcExpr in_expr@(ExplicitList _ exprs) res_ty
-  = do 	{ (elt_ty, coi) <- boxySplitListTy res_ty
-	; exprs' <- mapM (tc_elt elt_ty) exprs
-	; when (null exprs) (zapToMonotype elt_ty >> return ())
-		-- If there are no expressions in the comprehension
-		-- we must still fill in the box
-		--
-		-- The GHC front end never generates an empty ExplicitList
-		-- (instead it generates the [] data constructor) but
-		-- Template Haskell might.  We could fix the bit of 
-		-- TH that generates ExplicitList, but it seems less
-		-- fragile to just handle the case here.
-	; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') }
-  where
-    tc_elt elt_ty expr = tcPolyExpr expr elt_ty
-
-tcExpr in_expr@(ExplicitPArr _ exprs) res_ty	-- maybe empty
-  = do	{ (elt_ty, coi) <- boxySplitPArrTy res_ty
-    	; exprs' <- mapM (tc_elt elt_ty) exprs	
-	; when (null exprs) (zapToMonotype elt_ty >> return ())
-		-- If there are no expressions in the comprehension
-		-- we must still fill in the box
-		-- (Not needed for [] and () becuase they happen
-		--  to parse as data constructors.)
-	; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') }
-  where
-    tc_elt elt_ty expr = tcPolyExpr expr elt_ty
-
 tcExpr (HsProc pat cmd) res_ty
   = do	{ (pat', cmd', coi) <- tcProc pat cmd res_ty
 	; return $ mkHsWrapCoI coi (HsProc pat' cmd') }
@@ -398,26 +421,21 @@ tcExpr e@(HsArrForm _ _ _) _
 %************************************************************************
 
 \begin{code}
-tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
+tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
   = do	{ data_con <- tcLookupDataCon con_name
 
  	-- Check for missing fields
 	; checkMissingFields data_con rbinds
 
+	; (con_expr, con_tau) <- tcInferId con_name
 	; let arity = dataConSourceArity data_con
-	      check_fields qtvs qtys arg_tys 
-		  = do	{ let arg_tys' = substTys (zipOpenTvSubst qtvs qtys) arg_tys
-			; rbinds' <- tcRecordBinds data_con arg_tys' rbinds
-		 	; qtys' <- mapM refineBoxToTau qtys
-			; return (qtys', rbinds') }
-		-- The refineBoxToTau ensures that all the boxes in arg_tys are indeed
-		-- filled, which is the invariant expected by tcIdApp
-		-- How could this not be the case?  Consider a record construction
-		-- that does not mention all the fields.
-
-	; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
-
-	; return (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
+	      (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
+	      con_id = dataConWrapId data_con
+
+        ; co_res <- unifyType actual_res_ty res_ty
+        ; rbinds' <- tcRecordBinds data_con arg_tys rbinds
+	; return $ mkHsWrapCoI co_res $ 
+          RecordCon (L loc con_id) con_expr rbinds' } 
 \end{code}
 
 Note [Type of a record update]
@@ -522,7 +540,7 @@ In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
 	family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
 	
 \begin{code}
-tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
+tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
   = ASSERT( notNull upd_fld_names )
     do	{
 	-- STEP 0
@@ -565,8 +583,8 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
 	-- Check that each updated field is polymorphic; that is, its type
 	-- mentions only the universally-quantified variables of the data con
 	; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
-	      (upd_flds1_w_tys, fixed_flds1_w_tys) = partition is_updated flds1_w_tys
-	      is_updated (fld,ty) = fld `elem` upd_fld_names
+	      upd_flds1_w_tys = filter is_updated flds1_w_tys
+	      is_updated (fld,_) = fld `elem` upd_fld_names
 
 	      bad_upd_flds = filter bad_fld upd_flds1_w_tys
 	      con1_tv_set = mkVarSet con1_tvs
@@ -590,32 +608,31 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
 	; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs
 	; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys
 
-	; let result_ty     = substTy result_inst_env con1_res_ty
+	; let rec_res_ty    = substTy result_inst_env con1_res_ty
 	      con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys
 	      scrut_subst   = zipTopTvSubst con1_tvs scrut_inst_tys
 	      scrut_ty      = substTy scrut_subst con1_res_ty
 
+        ; co_res <- unifyType rec_res_ty res_ty
+
 	-- STEP 5
 	-- Typecheck the thing to be updated, and the bindings
 	; record_expr' <- tcMonoExpr record_expr scrut_ty
 	; rbinds'      <- tcRecordBinds con1 con1_arg_tys' rbinds
 	
-	; let origin = RecordUpdOrigin
-	; co_fn <- tcSubExp origin result_ty res_ty
-
 	-- STEP 6: Deal with the stupid theta
 	; let theta' = substTheta scrut_subst (dataConStupidTheta con1)
-	; instStupidTheta origin theta'
+	; instStupidTheta RecordUpdOrigin theta'
 
 	-- Step 7: make a cast for the scrutinee, in the case that it's from a type family
 	; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon 
 		       = WpCast $ mkTyConApp co_con scrut_inst_tys
 		       | otherwise
 		       = idHsWrapper
-
 	-- Phew!
-	; return (mkHsWrap co_fn (RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
-				        relevant_cons scrut_inst_tys result_inst_tys)) }
+        ; return $ mkHsWrapCoI co_res $
+          RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
+			           relevant_cons scrut_inst_tys result_inst_tys  }
   where
     upd_fld_names = hsRecFields rbinds
 
@@ -649,58 +666,58 @@ tcExpr expr@(RecordUpd record_expr rbinds _ _ _) res_ty
 
 \begin{code}
 tcExpr (ArithSeq _ seq@(From expr)) res_ty
-  = do	{ (elt_ty, coi) <- boxySplitListTy res_ty
+  = do	{ (coi, elt_ty) <- matchExpectedListTy res_ty
 	; expr' <- tcPolyExpr expr elt_ty
 	; enum_from <- newMethodFromName (ArithSeqOrigin seq) 
-			      elt_ty enumFromName
-	; return $ mkHsWrapCoI coi (ArithSeq (HsVar enum_from) (From expr')) }
+			      enumFromName elt_ty 
+	; return $ mkHsWrapCoI coi (ArithSeq enum_from (From expr')) }
 
-tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
-  = do	{ (elt_ty, coi) <- boxySplitListTy res_ty
+tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
+  = do	{ (coi, elt_ty) <- matchExpectedListTy res_ty
 	; expr1' <- tcPolyExpr expr1 elt_ty
 	; expr2' <- tcPolyExpr expr2 elt_ty
 	; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) 
-			      elt_ty enumFromThenName
+			      enumFromThenName elt_ty 
 	; return $ mkHsWrapCoI coi 
-                    (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
+                    (ArithSeq enum_from_then (FromThen expr1' expr2')) }
 
-tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
-  = do	{ (elt_ty, coi) <- boxySplitListTy res_ty
+tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
+  = do	{ (coi, elt_ty) <- matchExpectedListTy res_ty
 	; expr1' <- tcPolyExpr expr1 elt_ty
 	; expr2' <- tcPolyExpr expr2 elt_ty
 	; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) 
-		  	      elt_ty enumFromToName
+		  	      enumFromToName elt_ty 
 	; return $ mkHsWrapCoI coi 
-                     (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
+                     (ArithSeq enum_from_to (FromTo expr1' expr2')) }
 
-tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
-  = do	{ (elt_ty, coi) <- boxySplitListTy res_ty
+tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
+  = do	{ (coi, elt_ty) <- matchExpectedListTy res_ty
 	; expr1' <- tcPolyExpr expr1 elt_ty
 	; expr2' <- tcPolyExpr expr2 elt_ty
 	; expr3' <- tcPolyExpr expr3 elt_ty
 	; eft <- newMethodFromName (ArithSeqOrigin seq) 
-		      elt_ty enumFromThenToName
+		      enumFromThenToName elt_ty 
 	; return $ mkHsWrapCoI coi 
-                     (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
+                     (ArithSeq eft (FromThenTo expr1' expr2' expr3')) }
 
-tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
-  = do	{ (elt_ty, coi) <- boxySplitPArrTy res_ty
+tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
+  = do	{ (coi, elt_ty) <- matchExpectedPArrTy res_ty
 	; expr1' <- tcPolyExpr expr1 elt_ty
 	; expr2' <- tcPolyExpr expr2 elt_ty
 	; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) 
-				      elt_ty enumFromToPName
+				 enumFromToPName elt_ty 
 	; return $ mkHsWrapCoI coi 
-                     (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
+                     (PArrSeq enum_from_to (FromTo expr1' expr2')) }
 
-tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
-  = do	{ (elt_ty, coi) <- boxySplitPArrTy res_ty
+tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
+  = do	{ (coi, elt_ty) <- matchExpectedPArrTy res_ty
 	; expr1' <- tcPolyExpr expr1 elt_ty
 	; expr2' <- tcPolyExpr expr2 elt_ty
 	; expr3' <- tcPolyExpr expr3 elt_ty
 	; eft <- newMethodFromName (PArrSeqOrigin seq)
-		      elt_ty enumFromThenToPName
+		      enumFromThenToPName elt_ty
 	; return $ mkHsWrapCoI coi 
-                     (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
+                     (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
 
 tcExpr (PArrSeq _ _) _ 
   = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
@@ -721,7 +738,7 @@ tcExpr (PArrSeq _ _) _
 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
 tcExpr (HsBracket brack)  res_ty = do	{ e <- tcBracket brack res_ty
 					; return (unLoc e) }
-tcExpr e@(HsQuasiQuoteE _) res_ty =
+tcExpr e@(HsQuasiQuoteE _) _ =
     pprPanic "Should never see HsQuasiQuoteE in type checker" (ppr e)
 #endif /* GHCI */
 \end{code}
@@ -745,208 +762,223 @@ tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
 %************************************************************************
 
 \begin{code}
+tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
+      -> TcRhoType -> TcM (HsExpr TcId) -- Translated fun and args
+
+tcApp (L _ (HsPar e)) args res_ty
+  = tcApp e args res_ty
+
+tcApp (L _ (HsApp e1 e2)) args res_ty
+  = tcApp e1 (e2:args) res_ty	-- Accumulate the arguments
+
+tcApp (L loc (HsVar fun)) args res_ty
+  | fun `hasKey` tagToEnumKey
+  , [arg] <- args
+  = tcTagToEnum loc fun arg res_ty
+
+tcApp fun args res_ty
+  = do	{   -- Type-check the function
+	; (fun1, fun_tau) <- tcInferFun fun
+
+	    -- Extract its argument types
+	; (co_fun, expected_arg_tys, actual_res_ty)
+	      <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
+
+	-- Typecheck the result, thereby propagating 
+        -- info (if any) from result into the argument types
+        -- Both actual_res_ty and res_ty are deeply skolemised
+        ; co_res <- unifyType actual_res_ty res_ty
+
+	-- Typecheck the arguments
+	; args1 <- tcArgs fun args expected_arg_tys
+
+        -- Assemble the result
+	; let fun2 = mkLHsWrapCoI co_fun fun1
+              app  = mkLHsWrapCoI co_res (foldl mkHsApp fun2 args1)
+
+        ; return (unLoc app) }
+
+
+mk_app_msg :: LHsExpr Name -> SDoc
+mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
+                     , ptext (sLit "is applied to")]
+
+----------------
+tcInferApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args
+           -> TcM (HsExpr TcId, TcRhoType) -- Translated fun and args
+
+tcInferApp (L _ (HsPar e))     args = tcInferApp e args
+tcInferApp (L _ (HsApp e1 e2)) args = tcInferApp e1 (e2:args)
+tcInferApp fun args
+  = -- Very like the tcApp version, except that there is
+    -- no expected result type passed in
+    do	{ (fun1, fun_tau) <- tcInferFun fun
+	; (co_fun, expected_arg_tys, actual_res_ty)
+	      <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau
+	; args1 <- tcArgs fun args expected_arg_tys
+	; let fun2 = mkLHsWrapCoI co_fun fun1
+              app  = foldl mkHsApp fun2 args1
+        ; return (unLoc app, actual_res_ty) }
+
+----------------
+tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
+-- Infer and instantiate the type of a function
+tcInferFun (L loc (HsVar name)) 
+  = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
+       	       -- Don't wrap a context around a plain Id
+       ; return (L loc fun, ty) }
+
+tcInferFun fun
+  = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun)
+
+         -- Zonk the function type carefully, to expose any polymorphism
+	 -- E.g. (( \(x::forall a. a->a). blah ) e)
+	 -- We can see the rank-2 type of the lambda in time to genrealise e
+       ; fun_ty' <- zonkTcTypeCarefully fun_ty
+
+       ; (wrap, rho) <- deeplyInstantiate AppOrigin fun_ty'
+       ; return (mkLHsWrap wrap fun, rho) }
+
+----------------
+tcArgs :: LHsExpr Name				-- The function (for error messages)
+       -> [LHsExpr Name] -> [TcSigmaType]	-- Actual arguments and expected arg types
+       -> TcM [LHsExpr TcId]			-- Resulting args
+
+tcArgs fun args expected_arg_tys
+  = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
+
+----------------
+tcArg :: LHsExpr Name				-- The function (for error messages)
+       -> (LHsExpr Name, TcSigmaType, Int)	-- Actual argument and expected arg type
+       -> TcM (LHsExpr TcId)			-- Resulting argument
+tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
+				 	 (tcPolyExprNC arg ty)
+
+----------------
+tcTupArgs :: [HsTupArg Name] -> [TcSigmaType] -> TcM [HsTupArg TcId]
+tcTupArgs args tys 
+  = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
+  where
+    go (Missing {},   arg_ty) = return (Missing arg_ty)
+    go (Present expr, arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
+			           ; return (Present expr') }
+
+----------------
+unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType
+              -> TcM (CoercionI, [TcSigmaType], TcRhoType)	 		
+-- A wrapper for matchExpectedFunTys
+unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty
+  where
+    herald = ptext (sLit "The operator") <+> quotes (ppr op) <+> ptext (sLit "takes")
+
 ---------------------------
-tcApp :: HsExpr Name				-- Function
-      -> Arity					-- Number of args reqd
-      -> ArgChecker results
-      -> BoxyRhoType				-- Result type
-      -> TcM (HsExpr TcId, results)		
+tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
+-- Typecheck a syntax operator, checking that it has the specified type
+-- The operator is always a variable at this stage (i.e. renamer output)
+-- This version assumes res_ty is a monotype
+tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op
+                                       ; tcWrapResult expr rho res_ty }
+tcSyntaxOp _ other 	   _      = pprPanic "tcSyntaxOp" (ppr other) 
+\end{code}
+
 
--- (tcFun fun n_args arg_checker res_ty)
--- The argument type checker, arg_checker, will be passed exactly n_args types
+Note [Push result type in]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+Unify with expected result before type-checking the args so that the
+info from res_ty percolates to args.  This is when we might detect a
+too-few args situation.  (One can think of cases when the opposite
+order would give a better error message.) 
+experimenting with putting this first.  
 
-tcApp (HsVar fun_name) n_args arg_checker res_ty
-  = tcIdApp fun_name n_args arg_checker res_ty
+Here's an example where it actually makes a real difference
 
-tcApp fun n_args arg_checker res_ty	-- The vanilla case (rula APP)
-  = do	{ arg_boxes  <- newBoxyTyVars (replicate n_args argTypeKind)
-	; fun'       <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
-	; arg_tys'   <- mapM readFilledBox arg_boxes
-	; (_, args') <- arg_checker [] [] arg_tys'	-- Yuk
-	; return (fun', args') }
+   class C t a b | t a -> b
+   instance C Char a Bool
 
----------------------------
-tcIdApp :: Name					-- Function
-        -> Arity				-- Number of args reqd
-        -> ArgChecker results	-- The arg-checker guarantees to fill all boxes in the arg types
-        -> BoxyRhoType				-- Result type
-        -> TcM (HsExpr TcId, results)		
-
--- Call 	(f e1 ... en) :: res_ty
--- Type		f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
--- 			(where k <= n; fres has the rest)
--- NB:	if k < n then the function doesn't have enough args, and
---	presumably fres is a type variable that we are going to 
---	instantiate with a function type
---
--- Then		fres <= bx_(k+1) -> ... -> bx_n -> res_ty
-
-tcIdApp fun_name n_args arg_checker res_ty
-  = do	{ let orig = OccurrenceOf fun_name
-	; (fun, fun_ty) <- lookupFun orig fun_name
-
-	-- Split up the function type
-	; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy fun_ty
-	      (fun_arg_tys, fun_res_ty) = tcSplitFunTysN rho n_args
-
-	      qtvs = concatMap fst tv_theta_prs		-- Quantified tyvars
-	      arg_qtvs = exactTyVarsOfTypes fun_arg_tys
-	      res_qtvs = exactTyVarsOfType fun_res_ty
-		-- NB: exactTyVarsOfType.  See Note [Silly type synonyms in smart-app]
-	      tau_qtvs = arg_qtvs `unionVarSet` res_qtvs
-	      k  	     = length fun_arg_tys	-- k <= n_args
-	      n_missing_args = n_args - k		-- Always >= 0
-
-	-- Match the result type of the function with the
-	-- result type of the context, to get an inital substitution
-	; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
-	; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
-	      res_ty' 	     = mkFunTys extra_arg_tys' res_ty
-	; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
-
-	-- Typecheck the arguments!
-	-- Doing so will fill arg_qtvs and extra_arg_tys'
-	; (qtys'', args') <- arg_checker qtvs qtys' (fun_arg_tys ++ extra_arg_tys')
-
-	-- Strip boxes from the qtvs that have been filled in by the arg checking
-	; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
-
-	-- Result subsumption
-	-- This fills in res_qtvs
-	; let res_subst = zipOpenTvSubst qtvs qtys''
-	      fun_res_ty'' = substTy res_subst fun_res_ty
-	      res_ty'' = mkFunTys extra_arg_tys'' res_ty
-	; co_fn <- tcSubExp orig fun_res_ty'' res_ty''
-			    
-	-- And pack up the results
-	-- By applying the coercion just to the *function* we can make
-	-- tcFun work nicely for OpApp and Sections too
-	; fun' <- instFun orig fun res_subst tv_theta_prs
-	; co_fn' <- wrapFunResCoercion (substTys res_subst fun_arg_tys) co_fn
-	; traceTc (text "tcIdApp: " <+> ppr (mkHsWrap co_fn' fun') <+> ppr tv_theta_prs <+> ppr co_fn' <+> ppr fun')
-	; return (mkHsWrap co_fn' fun', args') }
-\end{code}
+   data P t a = forall b. (C t a b) => MkP b
+   data Q t   = MkQ (forall a. P t a)
+
+   f1, f2 :: Q Char;
+   f1 = MkQ (MkP True)
+   f2 = MkQ (MkP True :: forall a. P Char a)
 
-Note [Silly type synonyms in smart-app]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we call sripBoxyType, all of the boxes should be filled
-in.  But we need to be careful about type synonyms:
-	type T a = Int
-	f :: T a -> Int
-	...(f x)...
-In the call (f x) we'll typecheck x, expecting it to have type
-(T box).  Usually that would fill in the box, but in this case not;
-because 'a' is discarded by the silly type synonym T.  So we must
-use exactTyVarsOfType to figure out which type variables are free 
-in the argument type.
+With the change, f1 will type-check, because the 'Char' info from
+the signature is propagated into MkQ's argument. With the check
+in the other order, the extra signature in f2 is reqd.
+
+
+%************************************************************************
+%*									*
+                 tcInferId
+%*									*
+%************************************************************************
 
 \begin{code}
--- tcId is a specialisation of tcIdApp when there are no arguments
--- tcId f ty = do { (res, _) <- tcIdApp f [] (\[] -> return ()) ty
---		  ; return res }
-
-tcId :: InstOrigin
-     -> Name					-- Function
-     -> BoxyRhoType				-- Result type
-     -> TcM (HsExpr TcId)
-tcId orig fun_name res_ty
-  = do	{ (fun, fun_ty) <- lookupFun orig fun_name
-        ; traceTc (text "tcId" <+> ppr fun_name <+> (ppr fun_ty $$ ppr res_ty))
-	
-	-- Split up the function type
-	; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty
-	      qtvs = concatMap fst tv_theta_prs  	-- Quantified tyvars
-	      tau_qtvs = exactTyVarsOfType fun_tau	-- Mentioned in the tau part
-	; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
-
-	-- Do the subsumption check wrt the result type
-	; let res_subst = zipTopTvSubst qtvs qtv_tys
-	      fun_tau'  = substTy res_subst fun_tau
-
-        ; traceTc (text "tcId2" <+> ppr fun_name <+> (ppr qtvs $$ ppr qtv_tys))
-
-	; co_fn <- tcSubExp orig fun_tau' res_ty
-
-	-- And pack up the results
-	; fun' <- instFun orig fun res_subst tv_theta_prs 
-	; traceTc (text "tcId yields" <+> ppr (mkHsWrap co_fn fun'))
-	; return (mkHsWrap co_fn fun') }
-
--- 	Note [Push result type in]
---
--- Unify with expected result before (was: after) type-checking the args
--- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
--- This is when we might detect a too-few args situation.
--- (One can think of cases when the opposite order would give
--- a better error message.)
--- [March 2003: I'm experimenting with putting this first.  Here's an 
---		example where it actually makes a real difference
---    class C t a b | t a -> b
---    instance C Char a Bool
---
---    data P t a = forall b. (C t a b) => MkP b
---    data Q t   = MkQ (forall a. P t a)
-
---    f1, f2 :: Q Char;
---    f1 = MkQ (MkP True)
---    f2 = MkQ (MkP True :: forall a. P Char a)
---
--- With the change, f1 will type-check, because the 'Char' info from
--- the signature is propagated into MkQ's argument. With the check
--- in the other order, the extra signature in f2 is reqd.]
+tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
+tcCheckId name res_ty = do { (expr, rho) <- tcInferId name
+                           ; tcWrapResult expr rho res_ty }
+
+------------------------
+tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
+-- Infer type, and deeply instantiate
+tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n
+
+------------------------
+tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
+-- Look up an occurrence of an Id, and instantiate it (deeply)
+
+tcInferIdWithOrig orig id_name
+  = do { id <- lookup_id
+       ; (id_expr, id_rho) <- instantiateOuter orig id
+       ; (wrap, rho) <- deeplyInstantiate orig id_rho
+       ; return (mkHsWrap wrap id_expr, rho) }
+  where
+    lookup_id :: TcM TcId
+    lookup_id 
+       = do { thing <- tcLookup id_name
+	    ; case thing of
+    	    	 ATcId { tct_id = id, tct_level = lvl }
+	           -> do { check_naughty id        -- Note [Local record selectors]
+                         ; checkThLocalId id lvl
+                         ; return id }
+
+    	    	 AGlobal (AnId id) 
+                   -> do { check_naughty id; return id }
+	    	 	-- A global cannot possibly be ill-staged
+	    	 	-- nor does it need the 'lifting' treatment
+                        -- hence no checkTh stuff here
+
+    	    	 AGlobal (ADataCon con) -> return (dataConWrapId con)
+
+    	    	 other -> failWithTc (bad_lookup other) }
+
+    bad_lookup thing = ppr thing <+> ptext (sLit "used where a value identifer was expected")
+
+    check_naughty id 
+      | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
+      | otherwise		   = return ()
+
+------------------------
+instantiateOuter :: CtOrigin -> TcId -> TcM (HsExpr TcId, TcSigmaType)
+-- Do just the first level of instantiation of an Id
+--   a) Deal with method sharing
+--   b) Deal with stupid checks
+-- Only look at the *outer level* of quantification
+-- See Note [Multiple instantiation]
+
+instantiateOuter orig id
+  | null tvs && null theta
+  = return (HsVar id, tau)
 
----------------------------
-tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
--- Typecheck a syntax operator, checking that it has the specified type
--- The operator is always a variable at this stage (i.e. renamer output)
--- This version assumes ty is a monotype
-tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
-tcSyntaxOp orig other 	   ty = pprPanic "tcSyntaxOp" (ppr other) 
-                        
----------------------------
-instFun :: InstOrigin
-	-> HsExpr TcId
-	-> TvSubst		  -- The instantiating substitution
-	-> [([TyVar], ThetaType)] -- Stuff to instantiate
-	-> TcM (HsExpr TcId)	
-
-instFun orig fun subst []
-  = return fun		-- Common short cut
-
-instFun orig fun subst tv_theta_prs
-  = do 	{ let ty_theta_prs' = map subst_pr tv_theta_prs
-	; traceTc (text "instFun" <+> ppr ty_theta_prs')
-                -- Make two ad-hoc checks 
-	; doStupidChecks fun ty_theta_prs'
-
-		-- Now do normal instantiation
-        ; method_sharing <- doptM Opt_MethodSharing
-	; result <- go method_sharing True fun ty_theta_prs' 
-	; traceTc (text "instFun result" <+> ppr result)
-	; return result
-	}
+  | otherwise
+  = do { (_, tys, subst) <- tcInstTyVars tvs
+       ; doStupidChecks id tys
+       ; let theta' = substTheta subst theta
+       ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta'))
+       ; wrap <- instCall orig tys theta'
+       ; return (mkHsWrap wrap (HsVar id), substTy subst tau) }
   where
-    subst_pr (tvs, theta) 
-	= (substTyVars subst tvs, substTheta subst theta)
-
-    go _ _ fun [] = do {traceTc (text "go _ _ fun [] returns" <+> ppr fun) ; return fun }
-
-    go method_sharing True (HsVar fun_id) ((tys,theta) : prs)
-	| want_method_inst method_sharing theta
-	= do { traceTc (text "go (HsVar fun_id) ((tys,theta) : prs) | want_method_inst theta")
-	     ; meth_id <- newMethodWithGivenTy orig fun_id tys
-	     ; go method_sharing False (HsVar meth_id) prs }
-		-- Go round with 'False' to prevent further use
-		-- of newMethod: see Note [Multiple instantiation]
-
-    go method_sharing _ fun ((tys, theta) : prs)
-	= do { co_fn <- instCall orig tys theta
-	     ; traceTc (text "go yields co_fn" <+> ppr co_fn)
-	     ; go method_sharing False (HsWrap co_fn fun) prs }
-
-	-- See Note [No method sharing]
-    want_method_inst method_sharing theta =  not (null theta)	-- Overloaded
-		   	                  && method_sharing
+    (tvs, theta, tau) = tcSplitSigmaTy (idType id)
 \end{code}
 
 Note [Multiple instantiation]
@@ -998,54 +1030,34 @@ This gets a bit less sharing, but
 	a) it's better for RULEs involving overloaded functions
 	b) perhaps fewer separated lambdas
 
-Note [Left to right]
-~~~~~~~~~~~~~~~~~~~~
-tcArgs implements a left-to-right order, which goes beyond what is described in the
-impredicative type inference paper.  In particular, it allows
-	runST $ foo
-where runST :: (forall s. ST s a) -> a
-When typechecking the application of ($)::(a->b) -> a -> b, we first check that
-runST has type (a->b), thereby filling in a=forall s. ST s a.  Then we un-box this type
-before checking foo.  The left-to-right order really helps here.
-
 \begin{code}
-tcArgs :: LHsExpr Name				-- The function (for error messages)
-       -> [LHsExpr Name] 			-- Actual args
-       -> ArgChecker [LHsExpr TcId]
+doStupidChecks :: TcId
+	       -> [TcType]
+	       -> TcM ()
+-- Check two tiresome and ad-hoc cases
+-- (a) the "stupid theta" for a data con; add the constraints
+--     from the "stupid theta" of a data constructor (sigh)
 
-type ArgChecker results
-   = [TyVar] -> [TcSigmaType] 		-- Current instantiation
-   -> [TcSigmaType]			-- Expected arg types (**before** applying the instantiation)
-   -> TcM ([TcSigmaType], results)	-- Resulting instantiation and args
+doStupidChecks fun_id tys
+  | Just con <- isDataConId_maybe fun_id   -- (a)
+  = addDataConStupidTheta con tys
 
-tcArgs fun args qtvs qtys arg_tys
-  = go 1 qtys args arg_tys
-  where
-    go n qtys [] [] = return (qtys, [])
-    go n qtys (arg:args) (arg_ty:arg_tys)
-	= do { arg' <- tcArg fun n arg qtvs qtys arg_ty
-	     ; qtys' <- mapM refineBox qtys	-- Exploit new info
-	     ; (qtys'', args') <- go (n+1) qtys' args arg_tys
-	     ; return (qtys'', arg':args') }
-    go n qtys args arg_tys = panic "tcArgs"
-
-tcArg :: LHsExpr Name				-- The function
-      -> Int					--   and arg number (for error messages)
-      -> LHsExpr Name
-      -> [TyVar] -> [TcSigmaType] 		-- Instantiate the arg type like this
-      -> BoxySigmaType
-      -> TcM (LHsExpr TcId)			-- Resulting argument
-tcArg fun arg_no arg qtvs qtys ty
-  = addErrCtxt (funAppCtxt fun arg arg_no) $
-    tcPolyExprNC arg (substTyWith qtvs qtys ty)
+  | fun_id `hasKey` tagToEnumKey           -- (b)
+  = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
+  
+  | otherwise
+  = return () -- The common case
 \end{code}
 
-
 Note [tagToEnum#]
 ~~~~~~~~~~~~~~~~~
 Nasty check to ensure that tagToEnum# is applied to a type that is an
 enumeration TyCon.  Unification may refine the type later, but this
-check won't see that, alas.  It's crude but it works.
+check won't see that, alas.  It's crude, because it relies on our
+knowing *now* that the type is ok, which in turn relies on the
+eager-unification part of the type checker pushing enough information
+here.  In theory the Right Thing to do is to have a new form of 
+constraint but I definitely cannot face that!  And it works ok as-is.
 
 Here's are two cases that should fail
  	f :: forall a. a
@@ -1054,106 +1066,107 @@ Here's are two cases that should fail
 	g :: Int
 	g = tagToEnum# 0	-- Int is not an enumeration
 
+When data type families are involved it's a bit more complicated.
+     data family F a
+     data instance F [Int] = A | B | C
+Then we want to generate something like
+     tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
+Usually that coercion is hidden inside the wrappers for 
+constructors of F [Int] but here we have to do it explicitly.
 
-\begin{code}
-doStupidChecks :: HsExpr TcId
-	       -> [([TcType], ThetaType)]
-	       -> TcM ()
--- Check two tiresome and ad-hoc cases
--- (a) the "stupid theta" for a data con; add the constraints
---     from the "stupid theta" of a data constructor (sigh)
--- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
+It's all grotesquely complicated.
 
-doStupidChecks (HsVar fun_id) ((tys,_):_)
-  | Just con <- isDataConId_maybe fun_id   -- (a)
-  = addDataConStupidTheta con tys
-
-  | fun_id `hasKey` tagToEnumKey           -- (b)
-  = do	{ tys' <- zonkTcTypes tys
-	; checkTc (ok tys') (tagToEnumError tys')
-	}
-  where
-    ok [] 	= False
-    ok (ty:tys) = case tcSplitTyConApp_maybe ty of
-			Just (tc,_) -> isEnumerationTyCon tc
-			Nothing     -> False
-
-doStupidChecks fun tv_theta_prs
-  = return () -- The common case
-				      
-
-tagToEnumError tys
-  = hang (ptext (sLit "Bad call to tagToEnum#") <+> at_type)
-	 2 (vcat [ptext (sLit "Specify the type by giving a type signature"),
-		  ptext (sLit "e.g. (tagToEnum# x) :: Bool")])
+\begin{code}
+tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
+-- tagToEnum# :: forall a. Int# -> a
+-- See Note [tagToEnum#]   Urgh!
+tcTagToEnum loc fun_name arg res_ty
+  = do	{ fun <- tcLookupId fun_name
+        ; ty' <- zonkTcType res_ty
+
+	-- Check that the type is algebraic
+        ; let mb_tc_app = tcSplitTyConApp_maybe ty'
+              Just (tc, tc_args) = mb_tc_app
+	; checkTc (isJust mb_tc_app)
+                  (tagToEnumError ty' doc1)
+
+	-- Look through any type family
+        ; (coi, rep_tc, rep_args) <- get_rep_ty ty' tc tc_args
+
+	; checkTc (isEnumerationTyCon rep_tc) 
+                  (tagToEnumError ty' doc2)
+
+        ; arg' <- tcMonoExpr arg intPrimTy
+        ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
+              rep_ty = mkTyConApp rep_tc rep_args
+
+	; return (mkHsWrapCoI coi $ HsApp fun' arg') }
   where
-    at_type | null tys = empty	-- Probably never happens
-	    | otherwise = ptext (sLit "at type") <+> ppr (head tys)
+    doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
+		, ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
+    doc2 = ptext (sLit "Result type must be an enumeration type")
+    doc3 = ptext (sLit "No family instance for this type")
+
+    get_rep_ty :: TcType -> TyCon -> [TcType]
+               -> TcM (CoercionI, TyCon, [TcType])
+    	-- Converts a family type (eg F [a]) to its rep type (eg FList a)
+	-- and returns a coercion between the two
+    get_rep_ty ty tc tc_args
+      | not (isFamilyTyCon tc) 
+      = return (IdCo ty, tc, tc_args)
+      | otherwise 
+      = do { mb_fam <- tcLookupFamInst tc tc_args
+           ; case mb_fam of 
+	       Nothing -> failWithTc (tagToEnumError ty doc3)
+               Just (rep_tc, rep_args) 
+                   -> return ( ACo (mkSymCoercion (mkTyConApp co_tc rep_args))
+                             , rep_tc, rep_args )
+                 where
+                   co_tc = expectJust "tcTagToEnum" $
+                           tyConFamilyCoercion_maybe rep_tc }
+
+tagToEnumError :: TcType -> SDoc -> SDoc
+tagToEnumError ty what
+  = hang (ptext (sLit "Bad call to tagToEnum#") 
+           <+> ptext (sLit "at type") <+> ppr ty) 
+	 2 what
 \end{code}
 
+
 %************************************************************************
 %*									*
-\subsection{@tcId@ typechecks an identifier occurrence}
+                 Template Haskell checks
 %*									*
 %************************************************************************
 
 \begin{code}
-lookupFun :: InstOrigin -> Name -> TcM (HsExpr TcId, TcType)
-lookupFun orig id_name
-  = do 	{ thing <- tcLookup id_name
-	; case thing of
-    	    AGlobal (ADataCon con) -> return (HsVar wrap_id, idType wrap_id)
-				   where
-				      wrap_id = dataConWrapId con
-
-    	    AGlobal (AnId id) 
-	    	| isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
-	    	| otherwise		     -> return (HsVar id, idType id)
-	    	-- A global cannot possibly be ill-staged
-	    	-- nor does it need the 'lifting' treatment
-
-    	    ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }
-	    	| isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
-		  			  -- Note [Local record selectors]
-		| otherwise
-		-> do { thLocalId orig id ty lvl
-		      ; case mb_co of
-			  Unrefineable    -> return (HsVar id, ty)
-			  Rigid co        -> return (mkHsWrap co (HsVar id), ty) 	
-			  Wobbly 	  -> traceTc (text "lookupFun" <+> ppr id) >> return (HsVar id, ty)	-- Wobbly, or no free vars
-			  WobblyInvisible -> failWithTc (ppr id_name <+> ptext (sLit " not in scope because it has a wobbly type (solution: add a type annotation)"))
-		      }
-
-    	    other -> failWithTc (ppr other <+> ptext (sLit "used where a value identifer was expected"))
-    }
-
+checkThLocalId :: Id -> ThLevel -> TcM ()
 #ifndef GHCI  /* GHCI and TH is off */
 --------------------------------------
-thLocalId :: InstOrigin -> Id -> TcType -> ThLevel -> TcM ()
 -- Check for cross-stage lifting
-thLocalId orig id id_ty bind_lvl
+checkThLocalId _id _bind_lvl
   = return ()
 
 #else	      /* GHCI and TH is on */
-thLocalId orig id id_ty bind_lvl 
+checkThLocalId id bind_lvl 
   = do	{ use_stage <- getStage	-- TH case
 	; let use_lvl = thLevel use_stage
 	; checkWellStaged (quotes (ppr id)) bind_lvl use_lvl
-	; traceTc (text "thLocalId" <+> ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
+	; traceTc "thLocalId" (ppr id <+> ppr bind_lvl <+> ppr use_stage <+> ppr use_lvl)
 	; when (use_lvl > bind_lvl) $
-          checkCrossStageLifting orig id id_ty bind_lvl use_stage }
+          checkCrossStageLifting id bind_lvl use_stage }
 
 --------------------------------------
-checkCrossStageLifting :: InstOrigin -> Id -> TcType -> ThLevel -> ThStage -> TcM ()
+checkCrossStageLifting :: Id -> ThLevel -> ThStage -> TcM ()
 -- We are inside brackets, and (use_lvl > bind_lvl)
 -- Now we must check whether there's a cross-stage lift to do
 -- Examples   \x -> [| x |]  
 --            [| map |]
 
-checkCrossStageLifting _ _ _ _ Comp   = return ()
-checkCrossStageLifting _ _ _ _ Splice = return ()
+checkCrossStageLifting _ _ Comp   = return ()
+checkCrossStageLifting _ _ Splice = return ()
 
-checkCrossStageLifting orig id id_ty bind_lvl (Brack _ ps_var lie_var) 
+checkCrossStageLifting id _ (Brack _ ps_var lie_var) 
   | thTopLevelId id
   =	-- Top-level identifiers in this module,
 	-- (which have External Names)
@@ -1178,29 +1191,27 @@ checkCrossStageLifting orig id id_ty bind_lvl (Brack _ ps_var lie_var)
 	-- If 'x' occurs many times we may get many identical
 	-- bindings of the same splice proxy, but that doesn't
 	-- matter, although it's a mite untidy.
-    do 	{ checkTc (isTauTy id_ty) (polySpliceErr id)
+    do 	{ let id_ty = idType id
+        ; checkTc (isTauTy id_ty) (polySpliceErr id)
 	       -- If x is polymorphic, its occurrence sites might
 	       -- have different instantiations, so we can't use plain
 	       -- 'x' as the splice proxy name.  I don't know how to 
 	       -- solve this, and it's probably unimportant, so I'm
 	       -- just going to flag an error for now
    
-	; id_ty' <- zapToMonotype id_ty
-		-- The id_ty might have an OpenTypeKind, but we
-		-- can't instantiate the Lift class at that kind,
-		-- so we zap it to a LiftedTypeKind monotype
-		-- C.f. the call in TcPat.newLitInst
-
-	; lift <- if isStringTy id_ty' then
-	       	     tcLookupId DsMeta.liftStringName
-		     -- See Note [Lifting strings]
+	; lift <- if isStringTy id_ty then
+	       	     do { sid <- tcLookupId DsMeta.liftStringName
+		     		     -- See Note [Lifting strings]
+                        ; return (HsVar sid) }
 	          else
-                     setLIEVar lie_var	$ do  -- Put the 'lift' constraint into the right LIE
-                     newMethodFromName orig id_ty' DsMeta.liftName
+                     setConstraintVar lie_var	$ do  
+		          -- Put the 'lift' constraint into the right LIE
+                     newMethodFromName (OccurrenceOf (idName id)) 
+                                       DsMeta.liftName id_ty
 	   
 		   -- Update the pending splices
 	; ps <- readMutVar ps_var
-	; writeMutVar ps_var ((idName id, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
+	; writeMutVar ps_var ((idName id, nlHsApp (noLoc lift) (nlHsVar id)) : ps)
 
 	; return () }
 #endif /* GHCI */
@@ -1324,34 +1335,41 @@ checkMissingFields data_con rbinds
 
 Boring and alphabetical:
 \begin{code}
-addExprErrCtxt :: OutputableBndr id => LHsExpr id -> TcM a -> TcM a
-addExprErrCtxt expr = addErrCtxt (exprCtxt (unLoc expr))
+addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
+addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
 
+exprCtxt :: LHsExpr Name -> SDoc
 exprCtxt expr
-  = hang (ptext (sLit "In the expression:")) 4 (ppr expr)
+  = hang (ptext (sLit "In the expression:")) 2 (ppr expr)
 
+fieldCtxt :: Name -> SDoc
 fieldCtxt field_name
   = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
 
+funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc
 funAppCtxt fun arg arg_no
   = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"), 
 		    quotes (ppr fun) <> text ", namely"])
-	 4 (quotes (ppr arg))
+       2 (quotes (ppr arg))
 
+badFieldTypes :: [(Name,TcType)] -> SDoc
 badFieldTypes prs
   = hang (ptext (sLit "Record update for insufficiently polymorphic field")
 			 <> plural prs <> colon)
        2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
 
+badFieldsUpd :: HsRecFields Name a -> SDoc
 badFieldsUpd rbinds
   = hang (ptext (sLit "No constructor has all these fields:"))
-	 4 (pprQuotedList (hsRecFields rbinds))
+       2 (pprQuotedList (hsRecFields rbinds))
 
+naughtyRecordSel :: TcId -> SDoc
 naughtyRecordSel sel_id
   = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+> 
     ptext (sLit "as a function due to escaped type variables") $$ 
     ptext (sLit "Probable fix: use pattern-matching syntax instead")
 
+notSelector :: Name -> SDoc
 notSelector field
   = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
 
diff --git a/compiler/typecheck/TcExpr.lhs-boot b/compiler/typecheck/TcExpr.lhs-boot
index 6a75a10..5a4f005 100644
--- a/compiler/typecheck/TcExpr.lhs-boot
+++ b/compiler/typecheck/TcExpr.lhs-boot
@@ -2,27 +2,27 @@
 module TcExpr where
 import HsSyn	( HsExpr, LHsExpr )
 import Name	( Name )
-import TcType	( TcType, TcRhoType, BoxySigmaType, BoxyRhoType )
-import TcRnTypes( TcM, TcId, InstOrigin )
+import TcType	( TcType, TcRhoType, TcSigmaType )
+import TcRnTypes( TcM, TcId, CtOrigin )
 
 tcPolyExpr :: 
 	  LHsExpr Name
-       -> BoxySigmaType
+       -> TcSigmaType
        -> TcM (LHsExpr TcId)
 
 tcMonoExpr, tcMonoExprNC :: 
   	  LHsExpr Name
-       -> BoxyRhoType
+       -> TcRhoType
        -> TcM (LHsExpr TcId)
 
 tcInferRho, tcInferRhoNC :: 
   	  LHsExpr Name
        -> TcM (LHsExpr TcId, TcRhoType)
 
-tcSyntaxOp :: 
-	  InstOrigin
-       -> HsExpr Name
-       -> TcType
-       -> TcM (HsExpr TcId)
+tcSyntaxOp :: CtOrigin
+       	   -> HsExpr Name
+       	   -> TcType
+       	   -> TcM (HsExpr TcId)
 
+tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
 \end{code}
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 330ce57..782ce3f 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -335,7 +335,7 @@ illegalForeignTyErr :: SDoc -> Type -> SDoc
 illegalForeignTyErr arg_or_res ty
   = hang (hsep [ptext (sLit "Unacceptable"), arg_or_res, 
                 ptext (sLit "type in foreign declaration:")])
-	 4 (hsep [ppr ty])
+       2 (hsep [ppr ty])
 
 -- Used for 'arg_or_res' argument to illegalForeignTyErr
 argument, result :: SDoc
@@ -349,6 +349,6 @@ badCName target
 foreignDeclCtxt :: ForeignDecl Name -> SDoc
 foreignDeclCtxt fo
   = hang (ptext (sLit "When checking declaration:"))
-         4 (ppr fo)
+       2 (ppr fo)
 \end{code}
 
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 1708349..074ab39 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -1,4 +1,4 @@
-%
+1%
 % (c) The University of Glasgow 2006
 % (c) The AQUA Project, Glasgow University, 1996-1998
 %
@@ -17,7 +17,7 @@ module TcHsSyn (
 	shortCutLit, hsOverLitName,
 	
 	-- re-exported from TcMonad
-	TcId, TcIdSet, TcDictBinds,
+	TcId, TcIdSet, 
 
 	zonkTopDecls, zonkTopExpr, zonkTopLExpr,
 	zonkId, zonkTopBndrs
@@ -46,7 +46,6 @@ import Literal
 import BasicTypes
 import Maybes
 import SrcLoc
-import Util
 import Bag
 import Outputable
 \end{code}
@@ -56,9 +55,6 @@ import Outputable
 thenM :: Monad a => a b -> (b -> a c) -> a c
 thenM = (>>=)
 
-thenM_ :: Monad a => a b -> a c -> a c
-thenM_ = (>>)
-
 returnM :: Monad m => a -> m a
 returnM = return
 
@@ -181,18 +177,21 @@ the environment manipulation is tiresome.
 
 \begin{code}
 data ZonkEnv = ZonkEnv	(TcType -> TcM Type) 	-- How to zonk a type
-			(IdEnv Id)		-- What variables are in scope
-	-- Maps an Id to its zonked version; both have the same Name
+			(VarEnv Var)		-- What variables are in scope
+	-- Maps an Id or EvVar to its zonked version; both have the same Name
+	-- Note that all evidence (coercion variables as well as dictionaries)
+	-- 	are kept in the ZonkEnv
+	-- Only *type* abstraction is done by side effect
 	-- Is only consulted lazily; hence knot-tying
 
 emptyZonkEnv :: ZonkEnv
 emptyZonkEnv = ZonkEnv zonkTypeZapping emptyVarEnv
 
-extendZonkEnv :: ZonkEnv -> [Id] -> ZonkEnv
+extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv
 extendZonkEnv (ZonkEnv zonk_ty env) ids 
   = ZonkEnv zonk_ty (extendVarEnvList env [(id,id) | id <- ids])
 
-extendZonkEnv1 :: ZonkEnv -> Id -> ZonkEnv
+extendZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv
 extendZonkEnv1 (ZonkEnv zonk_ty env) id 
   = ZonkEnv zonk_ty (extendVarEnv env id id)
 
@@ -235,27 +234,27 @@ zonkIdBndr env id
 zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]
 zonkIdBndrs env ids = mappM (zonkIdBndr env) ids
 
-zonkDictBndrs :: ZonkEnv -> [Var] -> TcM [Var]
--- "Dictionary" binders can be coercion variables or dictionary variables
-zonkDictBndrs env ids = mappM (zonkDictBndr env) ids
-
-zonkDictBndr :: ZonkEnv -> Var -> TcM Var
-zonkDictBndr env var | isTyVar var = zonkTyVarBndr env var
-		     | otherwise   = zonkIdBndr env var
-
 zonkTopBndrs :: [TcId] -> TcM [Id]
 zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids
 
--- Zonk the kind of a non-TC tyvar in case it is a coercion variable (their
--- kind contains types).
---
-zonkTyVarBndr :: ZonkEnv -> TyVar -> TcM TyVar
-zonkTyVarBndr env tv
-  | isCoVar tv
-  = do { kind <- zonkTcTypeToType env (tyVarKind tv)
-       ; return $ setTyVarKind tv kind
-       }
-  | otherwise = return tv
+zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])
+zonkEvBndrsX = mapAccumLM zonkEvBndrX 
+
+zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)
+-- Works for dictionaries and coercions
+zonkEvBndrX env var
+  = do { var' <- zonkEvBndr env var
+       ; return (extendZonkEnv1 env var', var') }
+
+zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar
+-- Works for dictionaries and coercions
+-- Does not extend the ZonkEnv
+zonkEvBndr env var 
+  = do { ty' <- zonkTcTypeToType env (varType var)
+       ; return (setVarType var ty') }
+
+zonkEvVarOcc :: ZonkEnv -> EvVar -> EvVar
+zonkEvVarOcc env v = zonkIdOcc env v
 \end{code}
 
 
@@ -266,17 +265,20 @@ zonkTopExpr e = zonkExpr emptyZonkEnv e
 zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id)
 zonkTopLExpr e = zonkLExpr emptyZonkEnv e
 
-zonkTopDecls :: LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
+zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> [LRuleDecl TcId] -> [LForeignDecl TcId]
 	     -> TcM ([Id], 
+	             Bag EvBind,
 		     Bag (LHsBind  Id),
 		     [LForeignDecl Id],
 		     [LRuleDecl    Id])
-zonkTopDecls binds rules fords
-  = do	{ (env, binds') <- zonkRecMonoBinds emptyZonkEnv binds
+zonkTopDecls ev_binds binds rules fords
+  = do	{ (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds
+
+        ; (env2, binds') <- zonkRecMonoBinds env1 binds
 			-- Top level is implicitly recursive
-	; rules' <- zonkRules env rules
-	; fords' <- zonkForeignExports env fords
-	; return (zonkEnvIds env, binds', fords', rules') }
+	; rules' <- zonkRules env2 rules
+	; fords' <- zonkForeignExports env2 fords
+	; return (zonkEnvIds env2, ev_binds', binds', fords', rules') }
 
 ---------------------------------------------
 zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id)
@@ -292,7 +294,7 @@ zonkLocalBinds env (HsIPBinds (IPBinds binds dict_binds))
     let
 	env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds]
     in
-    zonkRecMonoBinds env1 dict_binds 	`thenM` \ (env2, new_dict_binds) -> 
+    zonkTcEvBinds env1 dict_binds 	`thenM` \ (env2, new_dict_binds) -> 
     returnM (env2, HsIPBinds (IPBinds new_binds new_dict_binds))
   where
     zonk_ip_bind (IPBind n e)
@@ -338,37 +340,38 @@ zonk_bind env (VarBind { var_id = var, var_rhs = expr, var_inline = inl })
     zonkLExpr env expr			`thenM` \ new_expr ->
     returnM (VarBind { var_id = new_var, var_rhs = new_expr, var_inline = inl })
 
-zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms, fun_co_fn = co_fn })
+zonk_bind env bind@(FunBind { fun_id = var, fun_matches = ms
+                            , fun_co_fn = co_fn })
   = wrapLocM (zonkIdBndr env) var	`thenM` \ new_var ->
     zonkCoFn env co_fn			`thenM` \ (env1, new_co_fn) ->
     zonkMatchGroup env1 ms		`thenM` \ new_ms ->
-    returnM (bind { fun_id = new_var, fun_matches = new_ms, fun_co_fn = new_co_fn })
+    returnM (bind { fun_id = new_var, fun_matches = new_ms
+                  , fun_co_fn = new_co_fn })
 
-zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_dicts = dicts, 
+zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs, abs_ev_binds = ev_binds,
 			  abs_exports = exports, abs_binds = val_binds })
   = ASSERT( all isImmutableTyVar tyvars )
-    zonkDictBndrs env dicts			`thenM` \ new_dicts ->
-    fixM (\ ~(new_val_binds, _) ->
-	let
-	  env1 = extendZonkEnv env new_dicts
-	  env2 = extendZonkEnv env1 (collectHsBindsBinders new_val_binds)
-	in
-	zonkMonoBinds env2 val_binds 		`thenM` \ new_val_binds ->
-        mappM (zonkExport env2) exports		`thenM` \ new_exports ->
-	returnM (new_val_binds, new_exports)
-    )						`thenM` \ (new_val_bind, new_exports) ->
-    returnM (AbsBinds { abs_tvs = tyvars, abs_dicts = new_dicts, 
-			abs_exports = new_exports, abs_binds = new_val_bind })
+    do { (env1, new_evs) <- zonkEvBndrsX env evs
+       ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds
+       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->
+    	 do { let env3 = extendZonkEnv env2 (collectHsBindsBinders new_val_binds)
+    	    ; new_val_binds <- zonkMonoBinds env3 val_binds
+    	    ; new_exports   <- mapM (zonkExport env3) exports
+    	    ; return (new_val_binds, new_exports) } 
+       ; return (AbsBinds { abs_tvs = tyvars, abs_ev_vars = new_evs, abs_ev_binds = new_ev_binds
+			  , abs_exports = new_exports, abs_binds = new_val_bind }) }
   where
     zonkExport env (tyvars, global, local, prags)
 	-- The tyvars are already zonked
 	= zonkIdBndr env global			`thenM` \ new_global ->
-	  zonk_prags prags			`thenM` \ new_prags -> 
+	  zonkSpecPrags env prags		`thenM` \ new_prags -> 
 	  returnM (tyvars, new_global, zonkIdOcc env local, new_prags)
 
-    zonk_prags IsDefaultMethod = return IsDefaultMethod
-    zonk_prags (SpecPrags ps)  = do { ps' <- mapM zonk_prag ps; return (SpecPrags ps') }
-
+zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags
+zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod
+zonkSpecPrags env (SpecPrags ps)  = do { ps' <- mapM zonk_prag ps
+                                       ; return (SpecPrags ps') }
+  where
     zonk_prag (L loc (SpecPrag co_fn inl))
 	= do { (_, co_fn') <- zonkCoFn env co_fn
 	     ; return (L loc (SpecPrag co_fn' inl)) }
@@ -510,8 +513,8 @@ zonkExpr env (HsDo do_or_lc stmts body ty)
   = zonkStmts env stmts 	`thenM` \ (new_env, new_stmts) ->
     zonkLExpr new_env body	`thenM` \ new_body ->
     zonkTcTypeToType env ty	`thenM` \ new_ty   ->
-    returnM (HsDo (zonkDo env do_or_lc) 
-		  new_stmts new_body new_ty)
+    zonkDo env do_or_lc	 	`thenM` \ new_do_or_lc ->
+    returnM (HsDo new_do_or_lc new_stmts new_body new_ty)
 
 zonkExpr env (ExplicitList ty exprs)
   = zonkTcTypeToType env ty	`thenM` \ new_ty ->
@@ -607,31 +610,23 @@ zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1
 				    ; return (env2, WpCompose c1' c2') }
 zonkCoFn env (WpCast co)    = do { co' <- zonkTcTypeToType env co
 				 ; return (env, WpCast co') }
-zonkCoFn env (WpLam id)     = do { id' <- zonkDictBndr env id
-				 ; let env1 = extendZonkEnv1 env id'
-				 ; return (env1, WpLam id') }
+zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev
+				 ; return (env', WpEvLam ev') }
+zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg 
+                                 ; return (env, WpEvApp arg') }
 zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )
-                              do { tv' <- zonkTyVarBndr env tv
-			         ; return (env, WpTyLam tv') }
-zonkCoFn env (WpApp v)
-	| isTcTyVar v  	    = do { co <- zonkTcTyVar v
-				 ; return (env, WpTyApp co) }
-		-- Yuk!  A mutable coercion variable is a TcTyVar 
-		--	 not a CoVar, so don't use isCoVar!
-		-- Yuk!  A WpApp can't hold the zonked type,
-		--	 so we switch to WpTyApp
-	| otherwise	    = return (env, WpApp (zonkIdOcc env v))
+                              return (env, WpTyLam tv) 
 zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToType env ty
 				 ; return (env, WpTyApp ty') }
-zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkRecMonoBinds env bs
+zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs
 				 ; return (env1, WpLet bs') }
 
-
 -------------------------------------------------------------------------
-zonkDo :: ZonkEnv -> HsStmtContext Name -> HsStmtContext Name
+zonkDo :: ZonkEnv -> HsStmtContext Name -> TcM (HsStmtContext Name)
 -- Only used for 'do', so the only Ids are in a MDoExpr table
-zonkDo env (MDoExpr tbl) = MDoExpr (mapSnd (zonkIdOcc env) tbl)
-zonkDo _   do_or_lc      = do_or_lc
+zonkDo env (MDoExpr tbl) = do { tbl' <- mapSndM (zonkExpr env) tbl
+                              ; return (MDoExpr tbl') }
+zonkDo _   do_or_lc      = return do_or_lc
 
 -------------------------------------------------------------------------
 zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id)
@@ -697,7 +692,7 @@ zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_id
 	-- has the polymorphic bindings in the envt
        ; new_rets <- mapM (zonkExpr env2) rets
        ; let env3 = extendZonkEnv env new_lvs	-- Only the lvs are needed
-       ; (env4, new_binds) <- zonkRecMonoBinds env3 binds
+       ; (env4, new_binds) <- zonkTcEvBinds env3 binds
        ; return (env4,
                  RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
                          , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
@@ -791,7 +786,7 @@ zonk_pat env (VarPat v)
 
 zonk_pat env (VarPatOut v binds)
   = do	{ v' <- zonkIdBndr env v
-	; (env', binds') <- zonkRecMonoBinds (extendZonkEnv1 env v') binds
+	; (env', binds') <- zonkTcEvBinds (extendZonkEnv1 env v') binds
   	; returnM (env', VarPatOut v' binds') }
 
 zonk_pat env (LazyPat pat)
@@ -828,14 +823,13 @@ zonk_pat env (TuplePat pats boxed ty)
 	; (env', pats') <- zonkPats env pats
 	; return (env', TuplePat pats' boxed ty') }
 
-zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = dicts, pat_binds = binds, pat_args = args })
+zonk_pat env p@(ConPatOut { pat_ty = ty, pat_dicts = evs, pat_binds = binds, pat_args = args })
   = ASSERT( all isImmutableTyVar (pat_tvs p) ) 
     do	{ new_ty <- zonkTcTypeToType env ty
-	; new_dicts <- zonkDictBndrs env dicts
-	; let env1 = extendZonkEnv env new_dicts
-	; (env2, new_binds) <- zonkRecMonoBinds env1 binds
+	; (env1, new_evs) <- zonkEvBndrsX env evs
+	; (env2, new_binds) <- zonkTcEvBinds env1 binds
 	; (env', new_args) <- zonkConStuff env2 args
-	; returnM (env', p { pat_ty = new_ty, pat_dicts = new_dicts, 
+	; returnM (env', p { pat_ty = new_ty, pat_dicts = new_evs, 
 			     pat_binds = new_binds, pat_args = new_args }) }
 
 zonk_pat env (LitPat lit) = return (env, LitPat lit)
@@ -921,14 +915,10 @@ zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs
 
 zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id)
 zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
-  = mappM zonk_bndr vars		`thenM` \ new_bndrs ->
-    newMutVar emptyVarSet		`thenM` \ unbound_tv_set ->
-    let
-	env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id]
-	-- Type variables don't need an envt
-	-- They are bound through the mutable mechanism
+  = do { (env_rhs, new_bndrs) <- mapAccumLM zonk_bndr env vars
 
-	env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
+       ; unbound_tv_set <- newMutVar emptyVarSet
+       ; let env_lhs = setZonkType env_rhs (zonkTypeCollecting unbound_tv_set)
 	-- We need to gather the type variables mentioned on the LHS so we can 
 	-- quantify over them.  Example:
 	--   data T a = C
@@ -947,28 +937,78 @@ zonkRule env (HsRule name act (vars{-::[RuleBndr TcId]-}) lhs fv_lhs rhs fv_rhs)
 	-- are tiresome, because (a) the data type is big and (b) finding the 
 	-- free type vars of an expression is necessarily monadic operation.
 	--	(consider /\a -> f @ b, where b is side-effected to a)
-    in
-    zonkLExpr env_lhs lhs		`thenM` \ new_lhs ->
-    zonkLExpr env_rhs rhs		`thenM` \ new_rhs ->
 
-    readMutVar unbound_tv_set		`thenM` \ unbound_tvs ->
-    let
-	final_bndrs :: [Located Var]
-	final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs
-    in
-    returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs fv_lhs new_rhs fv_rhs)
-		-- I hate this map RuleBndr stuff
+       ; new_lhs <- zonkLExpr env_lhs lhs
+       ; new_rhs <- zonkLExpr env_rhs rhs
+
+       ; unbound_tvs <- readMutVar unbound_tv_set
+       ; let final_bndrs :: [RuleBndr Var]
+	     final_bndrs = map (RuleBndr . noLoc) (varSetElems unbound_tvs) ++ new_bndrs
+
+       ; return (HsRule name act final_bndrs new_lhs fv_lhs new_rhs fv_rhs) }
   where
-   zonk_bndr (RuleBndr v) 
-	| isId (unLoc v) = wrapLocM (zonkIdBndr env)   v
-	| otherwise      = ASSERT( isImmutableTyVar (unLoc v) )
-			   return v
-   zonk_bndr (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
+   zonk_bndr env (RuleBndr (L loc v)) 
+      = do { (env', v') <- zonk_it env v; return (env', RuleBndr (L loc v')) }
+   zonk_bndr _ (RuleBndrSig {}) = panic "zonk_bndr RuleBndrSig"
+
+   zonk_it env v
+     | isId v     = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') }
+     | isCoVar v  = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') }
+     | otherwise  = ASSERT( isImmutableTyVar v) return (env, v)
 \end{code}
 
 
 %************************************************************************
 %*									*
+              Constraints and evidence
+%*									*
+%************************************************************************
+
+\begin{code}
+zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm
+zonkEvTerm env (EvId v)           = ASSERT2( isId v, ppr v ) 
+                                    return (EvId (zonkIdOcc env v))
+zonkEvTerm env (EvCoercion co)    = do { co' <- zonkTcTypeToType env co
+                                       ; return (EvCoercion co') }
+zonkEvTerm env (EvCast v co)      = ASSERT( isId v) 
+                                    do { co' <- zonkTcTypeToType env co
+                                       ; return (EvCast (zonkIdOcc env v) co') }
+zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n)
+zonkEvTerm env (EvDFunApp df tys tms) 
+  = do { tys' <- zonkTcTypeToTypes env tys
+       ; let tms' = map (zonkEvVarOcc env) tms
+       ; return (EvDFunApp (zonkIdOcc env df) tys' tms') }
+
+zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)
+zonkTcEvBinds env (TcEvBinds var) = do { (env', bs') <- zonkEvBindsVar env var
+				       ; return (env', EvBinds bs') }
+zonkTcEvBinds env (EvBinds bs)    = do { (env', bs') <- zonkEvBinds env bs
+				       ; return (env', EvBinds bs') }
+
+zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)
+zonkEvBindsVar env (EvBindsVar ref _) = do { bs <- readMutVar ref
+                                           ; zonkEvBinds env (evBindMapBinds bs) }
+
+zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)
+zonkEvBinds env binds
+  = fixM (\ ~( _, new_binds) -> do
+	 { let env1 = extendZonkEnv env (collect_ev_bndrs new_binds)
+         ; binds' <- mapBagM (zonkEvBind env1) binds
+         ; return (env1, binds') })
+  where
+    collect_ev_bndrs :: Bag EvBind -> [EvVar]
+    collect_ev_bndrs = foldrBag add [] 
+    add (EvBind var _) vars = var : vars
+
+zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind
+zonkEvBind env (EvBind var term)
+  = do { var' <- zonkEvBndr env var
+       ; term' <- zonkEvTerm env term
+       ; return (EvBind var' term') }
+\end{code}
+
+%************************************************************************
+%*									*
 \subsection[BackSubst-Foreign]{Foreign exports}
 %*									*
 %************************************************************************
@@ -983,19 +1023,19 @@ zonkTcTypeToTypes env tys = mapM (zonkTcTypeToType env) tys
 zonkTypeCollecting :: TcRef TyVarSet -> TcType -> TcM Type
 -- This variant collects unbound type variables in a mutable variable
 zonkTypeCollecting unbound_tv_set
-  = zonkType zonk_unbound_tyvar
+  = zonkType (mkZonkTcTyVar zonk_unbound_tyvar)
   where
     zonk_unbound_tyvar tv 
-	= zonkQuantifiedTyVar tv				`thenM` \ tv' ->
-	  readMutVar unbound_tv_set				`thenM` \ tv_set ->
-	  writeMutVar unbound_tv_set (extendVarSet tv_set tv')	`thenM_`
-	  return (mkTyVarTy tv')
+	= do { tv' <- zonkQuantifiedTyVar tv
+	     ; tv_set <- readMutVar unbound_tv_set
+	     ; writeMutVar unbound_tv_set (extendVarSet tv_set tv')
+	     ; return (mkTyVarTy tv') }
 
 zonkTypeZapping :: TcType -> TcM Type
 -- This variant is used for everything except the LHS of rules
 -- It zaps unbound type variables to (), or some other arbitrary type
 zonkTypeZapping ty 
-  = zonkType zonk_unbound_tyvar ty 
+  = zonkType (mkZonkTcTyVar zonk_unbound_tyvar) ty 
   where
 	-- Zonk a mutable but unbound type variable to an arbitrary type
 	-- We know it's unbound even though we don't carry an environment,
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index fcf329b..b27d26a 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -40,7 +40,6 @@ import TcType
 import {- Kind parts of -} Type
 import Var
 import VarSet
-import Coercion
 import TyCon
 import Class
 import Name
@@ -475,7 +474,7 @@ mkHsAppTys fun_ty (arg_ty:arg_tys)
 splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind)
 splitFunKind _       _      fk [] = return ([], fk)
 splitFunKind the_fun arg_no fk (arg:args)
-  = do { mb_fk <- unifyFunKind fk
+  = do { mb_fk <- matchExpectedFunKind fk
        ; case mb_fk of
             Nothing       -> failWithTc too_many_args 
             Just (ak,fk') -> do { (aks, rk) <- splitFunKind the_fun (arg_no+1) fk' args
@@ -522,9 +521,9 @@ kc_pred (HsEqualP ty1 ty2)
 ---------------------------
 kcTyVar :: Name -> TcM TcKind
 kcTyVar name = do	-- Could be a tyvar or a tycon
-    traceTc (text "lk1" <+> ppr name)
+    traceTc "lk1" (ppr name)
     thing <- tcLookup name
-    traceTc (text "lk2" <+> ppr name <+> ppr thing)
+    traceTc "lk2" (ppr name <+> ppr thing)
     case thing of 
         ATyVar _ ty             -> return (typeKind ty)
         AThing kind             -> return kind
@@ -851,19 +850,23 @@ tcHsPatSigType ctxt hs_ty
 
 tcPatSig :: UserTypeCtxt
 	 -> LHsType Name
-	 -> BoxySigmaType
+	 -> TcSigmaType
 	 -> TcM (TcType,	   -- The type to use for "inside" the signature
 		 [(Name, TcType)], -- The new bit of type environment, binding
 				   -- the scoped type variables
-                 CoercionI)        -- Coercion due to unification with actual ty
+                 HsWrapper)        -- Coercion due to unification with actual ty
+		 		   -- Of shape:  res_ty ~ sig_ty
 tcPatSig ctxt sig res_ty
   = do	{ (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig
+    	-- sig_tvs are the type variables free in 'sig', 
+	-- and not already in scope. These are the ones
+	-- that should be brought into scope
 
 	; if null sig_tvs then do {
 		-- The type signature binds no type variables, 
 		-- and hence is rigid, so use it to zap the res_ty
-		  coi <- boxyUnify sig_ty res_ty
-		; return (sig_ty, [], coi)
+         	  wrap <- tcSubType PatSigOrigin (SigSkol ctxt) res_ty sig_ty
+		; return (sig_ty, [], wrap)
 
 	} else do {
 		-- Type signature binds at least one scoped type variable
@@ -877,9 +880,6 @@ tcPatSig ctxt sig res_ty
 				_              -> False
 	; ASSERT( not in_pat_bind || null sig_tvs ) return ()
 
-	  	-- Check that pat_ty is rigid
-	; checkTc (isRigidTy res_ty) (wobblyPatSig sig_tvs)
-
 		-- Check that all newly-in-scope tyvars are in fact
 		-- constrained by the pattern.  This catches tiresome
 		-- cases like	
@@ -890,24 +890,20 @@ tcPatSig ctxt sig res_ty
 	; let bad_tvs = filterOut (`elemVarSet` exactTyVarsOfType sig_ty) sig_tvs
 	; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs)
 
-		-- Now match the pattern signature against res_ty
-		-- For convenience, and uniform-looking error messages
-		-- we do the matching by allocating meta type variables, 
-		-- unifying, and reading out the results.
-		-- This is a strictly local operation.
-	; box_tvs <- mapM tcInstBoxyTyVar sig_tvs
-	; coi <- boxyUnify (substTyWith sig_tvs (mkTyVarTys box_tvs) sig_ty) 
-                           res_ty
-	; sig_tv_tys <- mapM readFilledBox box_tvs
-
-		-- Check that each is bound to a distinct type variable,
-		-- and one that is not already in scope
-	; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys
+	-- Now do a subsumption check of the pattern signature against res_ty
+	; sig_tvs' <- tcInstSigTyVars sig_tvs
+        ; let sig_ty' = substTyWith sig_tvs sig_tv_tys' sig_ty
+              sig_tv_tys' = mkTyVarTys sig_tvs'
+	; wrap <- tcSubType PatSigOrigin (SigSkol ctxt) res_ty sig_ty'
+
+	-- Check that each is bound to a distinct type variable,
+	-- and one that is not already in scope
 	; binds_in_scope <- getScopedTyVarBinds
+	; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys'
 	; check binds_in_scope tv_binds
 	
-		-- Phew!
-	; return (res_ty, tv_binds, coi)
+	-- Phew!
+	; return (sig_ty', tv_binds, wrap)
 	} }
   where
     check _ [] = return ()
@@ -915,14 +911,9 @@ tcPatSig ctxt sig res_ty
 				      ; check ((n,ty):in_scope) rest }
 
     check_one in_scope n ty
-	= do { checkTc (tcIsTyVarTy ty) (scopedNonVar n ty)
-		-- Must bind to a type variable
-
-	     ; checkTc (null dups) (dupInScope n (head dups) ty)
+	= checkTc (null dups) (dupInScope n (head dups) ty)
 		-- Must not bind to the same type variable
 		-- as some other in-scope type variable
-
-	     ; return () }
 	where
 	  dups = [n' | (n',ty') <- in_scope, tcEqType ty' ty]
 \end{code}
@@ -1034,12 +1025,6 @@ pprHsSigCtxt ctxt hs_ty = sep [ ptext (sLit "In") <+> pprUserTypeCtxt ctxt <> co
 
     pp_n_colon n = ppr n <+> dcolon <+> ppr (unLoc hs_ty)
 
-wobblyPatSig :: [Var] -> SDoc
-wobblyPatSig sig_tvs
-  = hang (ptext (sLit "A pattern type signature cannot bind scoped type variables") 
-		<+> pprQuotedList sig_tvs)
-       2 (ptext (sLit "unless the pattern has a rigid type context"))
-		
 badPatSigTvs :: TcType -> [TyVar] -> SDoc
 badPatSigTvs sig_ty bad_tvs
   = vcat [ fsep [ptext (sLit "The type variable") <> plural bad_tvs, 
@@ -1049,12 +1034,6 @@ badPatSigTvs sig_ty bad_tvs
          , ptext (sLit "To fix this, expand the type synonym") 
          , ptext (sLit "[Note: I hope to lift this restriction in due course]") ]
 
-scopedNonVar :: Name -> Type -> SDoc
-scopedNonVar n ty
-  = vcat [sep [ptext (sLit "The scoped type variable") <+> quotes (ppr n),
-	       nest 2 (ptext (sLit "is bound to the type") <+> quotes (ppr ty))],
-	  nest 2 (ptext (sLit "You can only bind scoped type variables to type variables"))]
-
 dupInScope :: Name -> Name -> Type -> SDoc
 dupInScope n n' _
   = hang (ptext (sLit "The scoped type variables") <+> quotes (ppr n) <+> ptext (sLit "and") <+> quotes (ppr n'))
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index d7aafc1..571cd70 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -22,15 +22,17 @@ import FamInstEnv
 import TcDeriv
 import TcEnv
 import RnSource ( addTcgDUs )
+import TcSimplify( simplifySuperClass )
 import TcHsType
 import TcUnify
-import TcSimplify
 import Type
 import Coercion
 import TyCon
 import DataCon
 import Class
 import Var
+import VarSet	  ( emptyVarSet )
+import CoreUtils  ( mkPiTypes )
 import CoreUnfold ( mkDFunUnfolding )
 import CoreSyn	  ( Expr(Var) )
 import Id
@@ -45,7 +47,7 @@ import Bag
 import BasicTypes
 import HscTypes
 import FastString
-
+import Maybes	( orElse )
 import Data.Maybe
 import Control.Monad
 import Data.List
@@ -241,7 +243,7 @@ Consider this
   instance C a => C [a] where
     op1 x = op2 x ++ op2 x
     op2 x = ...
-  intance C [Int] where
+  instance C [Int] where
     ...
 
 When type-checking the C [a] instance, we need a C [a] dictionary (for
@@ -461,10 +463,6 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
         case find ((atName ==) . tyConName) (classATs clas) of
           Nothing     -> addErrTc $ badATErr clas atName  -- not in this class
           Just atycon ->
-            case assocTyConArgPoss_maybe atycon of
-              Nothing   -> panic "checkIndexes': AT has no args poss?!?"
-              Just poss ->
-
                 -- The following is tricky!  We need to deal with three
                 -- complications: (1) The AT possibly only uses a subset of
                 -- the class parameters as indexes and those it uses may be in
@@ -492,7 +490,19 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
                 -- instance types with the instance type variable sharing its
                 -- source lexeme.
                 --
-                let relevantInstTys = map (instTys !!) poss
+                let poss :: [Int]
+                    -- For *associated* type families, gives the position
+                    -- of that 'TyVar' in the class argument list (0-indexed)
+	   	    -- e.g.  class C a b c where { type F c a :: *->* }
+           	    --       Then we get Just [2,0]
+	            poss = catMaybes [ tv `elemIndex` classTyVars clas 
+                                     | tv <- tyConTyVars atycon]
+                       -- We will get Nothings for the "extra" type 
+                       -- variables in an associated data type
+                       -- e.g. class C a where { data D a :: *->* }
+                       -- here D gets arity 2 and has two tyvars
+
+                    relevantInstTys = map (instTys !!) poss
                     instArgs        = map Just relevantInstTys ++
                                       repeat Nothing  -- extra arguments
                     renaming        = substSameTyVar atTvs instTvs
@@ -578,133 +588,7 @@ the default method Ids replete with their INLINE pragmas.  Urk.
 \begin{code}
 tc_inst_decl2 :: Id -> InstBindings Name -> TcM (LHsBinds Id)
 -- Returns a binding for the dfun
-
-------------------------
--- Derived newtype instances; surprisingly tricky!
---
---      class Show a => Foo a b where ...
---      newtype N a = MkN (Tree [a]) deriving( Foo Int )
---
--- The newtype gives an FC axiom looking like
---      axiom CoN a ::  N a ~ Tree [a]
---   (see Note [Newtype coercions] in TyCon for this unusual form of axiom)
---
--- So all need is to generate a binding looking like:
---      dfunFooT :: forall a. (Foo Int (Tree [a], Show (N a)) => Foo Int (N a)
---      dfunFooT = /\a. \(ds:Show (N a)) (df:Foo (Tree [a])).
---                case df `cast` (Foo Int (sym (CoN a))) of
---                   Foo _ op1 .. opn -> Foo ds op1 .. opn
---
--- If there are no superclasses, matters are simpler, because we don't need the case
--- see Note [Newtype deriving superclasses] in TcDeriv.lhs
-
-tc_inst_decl2 dfun_id (NewTypeDerived coi _)
-  = do  { let rigid_info = InstSkol
-              origin     = SigOrigin rigid_info
-              inst_ty    = idType dfun_id
-	      inst_tvs   = fst (tcSplitForAllTys inst_ty)
-        ; (inst_tvs', theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
-                -- inst_head_ty is a PredType
-
-        ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
-              (class_tyvars, sc_theta, _, _) = classBigSig cls
-              cls_tycon = classTyCon cls
-              sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta
-              Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys
-
-              (rep_ty, wrapper) 
-	         = case coi of
-	      	     IdCo   -> (last_ty, idHsWrapper)
-		     ACo co -> (snd (coercionKind co'), WpCast (mk_full_coercion co'))
-			    where
-			       co' = substTyWith inst_tvs (mkTyVarTys inst_tvs') co
-				-- NB: the free variable of coi are bound by the
-				-- universally quantified variables of the dfun_id
-				-- This is weird, and maybe we should make NewTypeDerived
-				-- carry a type-variable list too; but it works fine
-
-		 -----------------------
-		 --        mk_full_coercion
-		 -- The inst_head looks like (C s1 .. sm (T a1 .. ak))
-		 -- But we want the coercion (C s1 .. sm (sym (CoT a1 .. ak)))
-		 --        with kind (C s1 .. sm (T a1 .. ak)  ~  C s1 .. sm <rep_ty>)
-		 --        where rep_ty is the (eta-reduced) type rep of T
-		 -- So we just replace T with CoT, and insert a 'sym'
-		 -- NB: we know that k will be >= arity of CoT, because the latter fully eta-reduced
-
-	      mk_full_coercion co = mkTyConApp cls_tycon 
-	      		       	         (initial_cls_inst_tys ++ [mkSymCoercion co])
-                 -- Full coercion : (Foo Int (Tree [a]) ~ Foo Int (N a)
-
-              rep_pred = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty])
-                 -- In our example, rep_pred is (Foo Int (Tree [a]))
-
-        ; sc_loc     <- getInstLoc InstScOrigin
-        ; sc_dicts   <- newDictBndrs sc_loc sc_theta'
-        ; inst_loc   <- getInstLoc origin
-        ; dfun_dicts <- newDictBndrs inst_loc theta
-        ; rep_dict   <- newDictBndr inst_loc rep_pred
-        ; this_dict  <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
-
-        -- Figure out bindings for the superclass context from dfun_dicts
-        -- Don't include this_dict in the 'givens', else
-        -- sc_dicts get bound by just selecting from this_dict!!
-        ; sc_binds <- addErrCtxt superClassCtxt $
-                      tcSimplifySuperClasses inst_loc this_dict dfun_dicts 
-					     (rep_dict:sc_dicts)
-
-	-- It's possible that the superclass stuff might unified something
-	-- in the envt with one of the clas_tyvars
-	; checkSigTyVars inst_tvs'
-
-        ; let coerced_rep_dict = wrapId wrapper (instToId rep_dict)
-
-        ; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
-	; let dict_bind = mkVarBind (instToId this_dict) (noLoc body)
-
-        ; return (unitBag $ noLoc $
-                  AbsBinds inst_tvs' (map instToVar dfun_dicts)
-                            [(inst_tvs', dfun_id, instToId this_dict, noSpecPrags)]
-                            (dict_bind `consBag` sc_binds)) }
-  where
-      -----------------------
-      --     (make_body C tys scs coreced_rep_dict)
-      --                returns
-      --     (case coerced_rep_dict of { C _ ops -> C scs ops })
-      -- But if there are no superclasses, it returns just coerced_rep_dict
-      -- See Note [Newtype deriving superclasses] in TcDeriv.lhs
-
-    make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
-        | null sc_dicts         -- Case (a)
-        = return coerced_rep_dict
-        | otherwise             -- Case (b)
-        = do { op_ids            <- newSysLocalIds (fsLit "op") op_tys
-             ; dummy_sc_dict_ids <- newSysLocalIds (fsLit "sc") (map idType sc_dict_ids)
-             ; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
-                                         pat_dicts = dummy_sc_dict_ids,
-                                         pat_binds = emptyLHsBinds,
-                                         pat_args = PrefixCon (map nlVarPat op_ids),
-                                         pat_ty = pat_ty}
-                   the_match = mkSimpleMatch [noLoc the_pat] the_rhs
-                   the_rhs = mkHsConApp cls_data_con cls_inst_tys $
-                             map HsVar (sc_dict_ids ++ op_ids)
-
-                -- Warning: this HsCase scrutinises a value with a PredTy, which is
-                --          never otherwise seen in Haskell source code. It'd be
-                --          nicer to generate Core directly!
-             ; return (HsCase (noLoc coerced_rep_dict) $
-                       MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
-        where
-          sc_dict_ids  = map instToId sc_dicts
-          pat_ty       = mkTyConApp cls_tycon cls_inst_tys
-          cls_data_con = head (tyConDataCons cls_tycon)
-          cls_arg_tys  = dataConInstArgTys cls_data_con cls_inst_tys
-          op_tys       = dropList sc_dict_ids cls_arg_tys
-
-------------------------
--- Ordinary instances
-
-tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
+tc_inst_decl2 dfun_id inst_binds
  = do { let rigid_info = InstSkol
             inst_ty    = idType dfun_id
             loc        = getSrcSpan dfun_id
@@ -720,63 +604,49 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
 
              -- Instantiate the super-class context with inst_tys
             sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
-            origin    = SigOrigin rigid_info
 
          -- Create dictionary Ids from the specified instance contexts.
-       ; inst_loc   <- getInstLoc origin
-       ; dfun_dicts <- newDictBndrs inst_loc dfun_theta'	-- Includes equalities
-       ; this_dict  <- newDictBndr inst_loc (mkClassPred clas inst_tys')
+       ; dfun_ev_vars <- newEvVars dfun_theta'
+       ; self_dict    <- newSelfDict clas inst_tys'
                 -- Default-method Ids may be mentioned in synthesised RHSs,
                 -- but they'll already be in the environment.
 
-       
-	-- Cook up a binding for "this = df d1 .. dn",
+	-- Cook up a binding for "self = df d1 .. dn",
 	-- to use in each method binding
-	-- Need to clone the dict in case it is floated out, and
-	-- then clashes with its friends
-       ; cloned_this <- cloneDict this_dict
-       ; let cloned_this_bind = mkVarBind (instToId cloned_this) $ 
-		                L loc $ wrapId app_wrapper dfun_id
-	     app_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
-	     dfun_lam_vars = map instToVar dfun_dicts	-- Includes equalities
-	     nested_this_pair 
-		| null inst_tyvars' && null dfun_theta' = (this_dict, emptyBag)
-		| otherwise = (cloned_this, unitBag cloned_this_bind)
+ 	-- Why?  See Note [Subtle interaction of recursion and overlap]
+       ; let self_ev_bind = EvBind self_dict $ 
+                            EvDFunApp dfun_id (mkTyVarTys inst_tyvars') dfun_ev_vars
 
        -- Deal with 'SPECIALISE instance' pragmas
        -- See Note [SPECIALISE instance pragmas]
-       ; let spec_inst_sigs = filter isSpecInstLSig uprags
-       	     -- The filter removes the pragmas for methods
-       ; spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) spec_inst_sigs
+       ; spec_info <- tcSpecInstPrags dfun_id inst_binds
 
         -- Typecheck the methods
-       ; let prag_fn = mkPragFun uprags monobinds
-             tc_meth = tcInstanceMethod loc standalone_deriv
-                                        clas inst_tyvars'
-	     	       	 		dfun_dicts inst_tys'
-	     	     	 		nested_this_pair 
-				 	prag_fn spec_inst_prags monobinds
-
-       ; (meth_ids, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $
-			           mapAndUnzipM tc_meth op_items 
+       ; (meth_ids, meth_binds) 
+           <- tcExtendTyVarEnv inst_tyvars' $
+              tcInstanceMethods dfun_id clas inst_tyvars' dfun_ev_vars 
+	     	     	 	inst_tys' self_ev_bind spec_info
+                                op_items inst_binds
 
          -- Figure out bindings for the superclass context
-       ; sc_loc   <- getInstLoc InstScOrigin
-       ; sc_dicts <- newDictOccs sc_loc sc_theta'		-- These are wanted
-       ; let tc_sc = tcSuperClass inst_loc inst_tyvars' dfun_dicts nested_this_pair
-       ; (sc_ids, sc_binds) <- mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts)
+       ; let tc_sc = tcSuperClass inst_tyvars' dfun_ev_vars self_ev_bind
+             (sc_eqs, sc_dicts) = splitAt (classSCNEqs clas) sc_theta'
+       ; (sc_dict_ids, sc_binds) <- ASSERT( equalLength sc_sels sc_dicts )
+                                    ASSERT( all isEqPred sc_eqs )
+                                    mapAndUnzipM tc_sc (sc_sels `zip` sc_dicts)
 
-	-- It's possible that the superclass stuff might unified
-	-- something in the envt with one of the inst_tyvars'
-       ; checkSigTyVars inst_tyvars'
+				    -- NOT FINISHED!
+       ; (_eq_sc_binds, sc_eq_vars) <- checkConstraints InstSkol emptyVarSet 
+                                           inst_tyvars' dfun_ev_vars $
+                                      emitWanteds ScOrigin sc_eqs
 
        -- Create the result bindings
-       ; let dict_constr   = classDataCon clas
-             this_dict_id  = instToId this_dict
-	     dict_bind     = mkVarBind this_dict_id dict_rhs
-             dict_rhs      = foldl mk_app inst_constr sc_meth_ids
-             sc_meth_ids   = sc_ids ++ meth_ids
- 	     inst_constr   = L loc $ wrapId (mkWpTyApps inst_tys')
+       ; let dict_constr       = classDataCon clas
+	     dict_bind         = mkVarBind self_dict dict_rhs
+             dict_rhs          = foldl mk_app inst_constr dict_and_meth_ids
+             dict_and_meth_ids = sc_dict_ids ++ meth_ids
+ 	     inst_constr   = L loc $ wrapId (mkWpEvVarApps sc_eq_vars 
+                                             <.> mkWpTyApps inst_tys')
 	     			            (dataConWrapId dict_constr)
                      -- We don't produce a binding for the dict_constr; instead we
                      -- rely on the simplifier to unfold this saturated application
@@ -787,120 +657,83 @@ tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
 
 	     mk_app :: LHsExpr Id -> Id -> LHsExpr Id
  	     mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id)))
-	     arg_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
+	     arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
 
 	        -- Do not inline the dfun; instead give it a magic DFunFunfolding
 	        -- See Note [ClassOp/DFun selection]
 		-- See also note [Single-method classes]
              dfun_id_w_fun = dfun_id  
-                             `setIdUnfolding`  mkDFunUnfolding inst_ty (map Var sc_meth_ids)
+                             `setIdUnfolding`  mkDFunUnfolding inst_ty (map Var dict_and_meth_ids)
+			     		       		-- Not right for equality superclasses
                              `setInlinePragma` dfunInlinePragma
 
-             main_bind = AbsBinds
-                         inst_tyvars'
-                         dfun_lam_vars
-                         [(inst_tyvars', dfun_id_w_fun, this_dict_id, SpecPrags spec_inst_prags)]
-                         (unitBag dict_bind)
+             (spec_inst_prags, _) = spec_info
+             main_bind = AbsBinds { abs_tvs = inst_tyvars'
+                                  , abs_ev_vars = dfun_ev_vars
+                                  , abs_exports = [(inst_tyvars', dfun_id_w_fun, self_dict, 
+                                                    SpecPrags spec_inst_prags)]
+                                  , abs_ev_binds = emptyTcEvBinds
+                                  , abs_binds = unitBag dict_bind }
 
-       ; showLIE (text "instance")
        ; return (unitBag (L loc main_bind) `unionBags` 
-		 listToBag meth_binds     `unionBags` 
+		 listToBag meth_binds      `unionBags` 
                  listToBag sc_binds)
        }
 
-{-
-       -- Create the result bindings
-       ; let this_dict_id  = instToId this_dict
-             arg_ids       = sc_ids ++ meth_ids
-             arg_binds     = listToBag meth_binds `unionBags` 
-                             listToBag sc_binds
-
-       ; showLIE (text "instance")
-       ; case newTyConCo_maybe (classTyCon clas) of
-           Nothing 	       -- A multi-method class
-             -> return (unitBag (L loc data_bind)  `unionBags` arg_binds)
-             where
-               data_dfun_id = dfun_id   -- Do not inline; instead give it a magic DFunFunfolding
-			     	       -- See Note [ClassOp/DFun selection]
-                             	`setIdUnfolding`  mkDFunUnfolding dict_constr arg_ids
-                             	`setInlinePragma` dfunInlinePragma
-
-               data_bind = AbsBinds inst_tyvars' dfun_lam_vars
-                             [(inst_tyvars', data_dfun_id, this_dict_id, spec_inst_prags)]
-                             (unitBag dict_bind)
-
-	       dict_bind   = mkVarBind this_dict_id dict_rhs
-               dict_rhs    = foldl mk_app inst_constr arg_ids
-               dict_constr = classDataCon clas
-               inst_constr = L loc $ wrapId (mkWpTyApps inst_tys')
-	       			            (dataConWrapId dict_constr)
-                       -- 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.
-
-	       mk_app :: LHsExpr Id -> Id -> LHsExpr Id
- 	       mk_app fun arg_id = L loc (HsApp fun (L loc (wrapId arg_wrapper arg_id)))
-	       arg_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars')
-
-           Just the_nt_co  	 -- (Just co) for a single-method class
-             -> return (unitBag (L loc nt_bind) `unionBags` arg_binds)
-             where
-               nt_dfun_id = dfun_id   -- Just let the dfun inline; see Note [Single-method classes]
-                            `setInlinePragma` alwaysInlinePragma
-
-	       local_nt_dfun = setIdType this_dict_id inst_ty	-- A bit of a hack, but convenient
-
-	       nt_bind = AbsBinds [] [] 
-                            [([], nt_dfun_id, local_nt_dfun, spec_inst_prags)]
-                            (unitBag (mkVarBind local_nt_dfun (L loc (wrapId nt_cast the_meth_id))))
-
-	       the_meth_id = ASSERT( length arg_ids == 1 ) head arg_ids
-               nt_cast = WpCast $ mkPiTypes (inst_tyvars' ++ dfun_lam_vars) $
-                         mkSymCoercion (mkTyConApp the_nt_co inst_tys')
--}
+------------------------------
+tcSpecInstPrags :: DFunId -> InstBindings Name 
+                -> TcM ([Located TcSpecPrag], PragFun)
+tcSpecInstPrags _ (NewTypeDerived {})
+  = return ([], \_ -> [])
+tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
+  = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
+                            filter isSpecInstLSig uprags
+	     -- The filter removes the pragmas for methods
+       ; return (spec_inst_prags, mkPragFun uprags binds) }
 
 ------------------------------
-tcSuperClass :: InstLoc -> [TyVar] -> [Inst]
-	     -> (Inst, LHsBinds Id)
-	     -> (Id, Inst) -> TcM (Id, LHsBind Id)
+tcSuperClass :: [TyVar] -> [EvVar]
+	     -> EvBind
+	     -> (Id, PredType) -> TcM (Id, LHsBind Id)
 -- Build a top level decl like
 --	sc_op = /\a \d. let this = ... in 
 --		        let sc = ... in
 --			sc
 -- The "this" part is just-in-case (discarded if not used)
 -- See Note [Recursive superclasses]
-tcSuperClass inst_loc tyvars dicts (this_dict, this_bind)
-	     (sc_sel, sc_dict)
-  = addErrCtxt superClassCtxt $
-    do { sc_binds <- tcSimplifySuperClasses inst_loc 
-				this_dict dicts [sc_dict]
-         -- Don't include this_dict in the 'givens', else
-         -- sc_dicts get bound by just selecting  from this_dict!!
+tcSuperClass tyvars dicts 
+             self_ev_bind@(EvBind self_dict _)
+	     (sc_sel, sc_pred)
+  = do { (ev_binds, wanted, sc_dict)
+             <- newImplication InstSkol emptyVarSet tyvars dicts $
+                emitWanted ScOrigin sc_pred
+
+       ; simplifySuperClass self_dict wanted
+         -- We include self_dict in the 'givens'; the simplifier
+         -- is clever enough to stop sc_pred geting bound by just 
+         -- selecting from self_dict!!
 
        ; uniq <- newUnique
-       ; let sc_op_ty = mkSigmaTy tyvars (map dictPred dicts) 
-				  (mkPredTy (dictPred sc_dict))
+       ; let sc_op_ty   = mkForAllTys tyvars $ mkPiTypes dicts (varType sc_dict)
 	     sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq
 						(getName sc_sel)
 	     sc_op_id   = mkLocalId sc_op_name sc_op_ty
-	     sc_id      = instToVar sc_dict
-	     sc_op_bind = AbsBinds tyvars 
-			     (map instToVar dicts) 
-                             [(tyvars, sc_op_id, sc_id, noSpecPrags)]
-                             (this_bind `unionBags` sc_binds)
+	     sc_op_bind = VarBind { var_id = sc_op_id, var_inline = False
+                                  , var_rhs = L noSrcSpan $ wrapId sc_wrapper sc_dict }
+             sc_wrapper = mkWpTyLams tyvars
+                          <.> mkWpLams dicts
+                          <.> mkWpLet (EvBinds (unitBag self_ev_bind))
+			  <.> mkWpLet ev_binds
 
        ; return (sc_op_id, noLoc sc_op_bind) }
 \end{code}
 
 Note [Recursive superclasses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See Trac #1470 for why we would *like* to add "this_dict" to the 
+See Trac #1470 for why we would *like* to add "self_dict" to the 
 available instances here.  But we can't do so because then the superclases
-get satisfied by selection from this_dict, and that leads to an immediate
-loop.  What we need is to add this_dict to Avails without adding its 
+get satisfied by selection from self_dict, and that leads to an immediate
+loop.  What we need is to add self_dict to Avails without adding its 
 superclasses, and we currently have no way to do that.
 
 Note [SPECIALISE instance pragmas]
@@ -952,7 +785,8 @@ tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
     do  { let name = idName dfun_id
         ; (tyvars, theta, tau) <- tcHsInstHead hs_ty	
         ; let spec_ty = mkSigmaTy tyvars theta tau
-        ; co_fn <- tcSubExp (SpecPragOrigin name) (idType dfun_id) spec_ty
+        ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt) 
+                             (idType dfun_id) spec_ty
         ; return (SpecPrag co_fn defaultInlinePragma) }
   where
     spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
@@ -975,99 +809,105 @@ tcInstanceMethod
 - Use tcValBinds to do the checking
 
 \begin{code}
-tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst]
-	 	 -> [TcType]
-		 -> (Inst, LHsBinds Id)  -- "This" and its binding
-          	 -> TcPragFun	    	 -- Local prags
-		 -> [Located TcSpecPrag] -- Arising from 'SPECLALISE instance'
-                 -> LHsBinds Name 
-	  	 -> (Id, DefMeth)
-          	 -> TcM (Id, LHsBind Id)
+tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
+                  -> [EvVar]
+	 	  -> [TcType]
+		  -> EvBind               -- "This" and its binding
+		  -> ([Located TcSpecPrag], PragFun)
+	  	  -> [(Id, DefMeth)]
+                  -> InstBindings Name 
+          	  -> TcM ([Id], [LHsBind Id])
 	-- The returned inst_meth_ids all have types starting
 	--	forall tvs. theta => ...
-
-tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys 
-		 (this_dict, this_dict_bind)
-		 prag_fn spec_inst_prags binds_in (sel_id, dm_info)
-  = do  { uniq <- newUnique
-	; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
-        ; local_meth_name <- newLocalName sel_name
-	  -- Base the local_meth_name on the selector name, becuase
-	  -- type errors from tcInstanceMethodBody come from here
-
-        ; let local_meth_ty = instantiateMethod clas sel_id inst_tys
-	      meth_ty = mkSigmaTy tyvars (map dictPred dfun_dicts) local_meth_ty
-	      meth_id       = mkLocalId meth_name meth_ty
-              local_meth_id = mkLocalId local_meth_name local_meth_ty
-
-    	    --------------
-	      tc_body rn_bind 
-                = add_meth_ctxt rn_bind $
-                  do { (meth_id1, spec_prags) <- tcPrags NonRecursive False True 
-                                                         meth_id (prag_fn sel_name)
-                     ; bind <- tcInstanceMethodBody (instLoc this_dict)
-                                    tyvars dfun_dicts
-				    ([this_dict], this_dict_bind)
-                                    meth_id1 local_meth_id
-				    meth_sig_fn 
-                                    (SpecPrags (spec_inst_prags ++ spec_prags))
-                                    rn_bind 
-                     ; return (meth_id1, bind) }
-
-    	    --------------
-	      tc_default :: DefMeth -> TcM (Id, LHsBind Id)
-		-- The user didn't supply a method binding, so we have to make 
-		-- up a default binding, in a way depending on the default-method info
-
-              tc_default NoDefMeth	    -- No default method at all
-		= do { warnMissingMethod sel_id
-		     ; return (meth_id, mkVarBind meth_id $ 
-                                        mkLHsWrap lam_wrapper error_rhs) }
-	      
-	      tc_default GenDefMeth    -- Derivable type classes stuff
-                = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
-                     ; tc_body meth_bind }
-		  
-	      tc_default (DefMeth dm_name)	-- An polymorphic default method
-	        = do {   -- Build the typechecked version directly, 
-			 -- without calling typecheck_method; 
-			 -- see Note [Default methods in instances]
-			 -- Generate   /\as.\ds. let this = df as ds 
-                         --                      in $dm inst_tys this
-			 -- The 'let' is necessary only because HsSyn doesn't allow
-			 -- you to apply a function to a dictionary *expression*.
-
-		     ; dm_id <- tcLookupId dm_name
-                     ; let dm_inline_prag = idInlinePragma dm_id
-                           rhs = HsWrap (WpApp (instToId this_dict) <.> mkWpTyApps inst_tys) $
-			         HsVar dm_id 
-
-		           meth_bind = L loc $ VarBind { var_id = local_meth_id
-                                                       , var_rhs = L loc rhs 
-						       , var_inline = False }
-                           meth_id1 = meth_id `setInlinePragma` dm_inline_prag
-			   	    -- Copy the inline pragma (if any) from the default
-				    -- method to this version. Note [INLINE and default methods]
-				    
-                           bind = AbsBinds { abs_tvs = tyvars, abs_dicts =  dfun_lam_vars
-                                           , abs_exports = [( tyvars, meth_id1, local_meth_id
-                                                            , SpecPrags spec_inst_prags)]
-                                           , abs_binds = this_dict_bind `unionBags` unitBag meth_bind }
-		     -- Default methods in an instance declaration can't have their own 
-		     -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
-   		     -- currently they are rejected with 
-		     --		  "INLINE pragma lacks an accompanying binding"
-
-		     ; return (meth_id1, L loc bind) } 
-
-        ; case findMethodBind sel_name local_meth_name binds_in of
-	    Just user_bind -> tc_body user_bind	   -- User-supplied method binding
-	    Nothing	   -> tc_default dm_info   -- None supplied
-	}
+tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys 
+		  self_dict_ev (spec_inst_prags, prag_fn)
+                  op_items (VanillaInst binds _ standalone_deriv)
+  = mapAndUnzipM tc_item op_items
   where
-    sel_name = idName sel_id
-
-    meth_sig_fn _ = Just []	-- The 'Just' says "yes, there's a type sig"
+    ----------------------
+    tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
+    tc_item (sel_id, dm_info)
+      = case findMethodBind (idName sel_id) binds of
+  	    Just user_bind -> tc_body sel_id standalone_deriv user_bind
+  	    Nothing	   -> tc_default sel_id dm_info
+
+    ----------------------
+    tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
+    tc_body sel_id generated_code rn_bind 
+      = add_meth_ctxt generated_code rn_bind $
+        do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars 
+                                                   inst_tys sel_id
+           ; (meth_id1, spec_prags) <- tcPrags NonRecursive False True 
+                                               meth_id (prag_fn (idName sel_id))
+
+           ; bind <- tcInstanceMethodBody InstSkol
+                          tyvars dfun_ev_vars
+    			    mb_dict_ev
+                          meth_id1 local_meth_id
+    			    meth_sig_fn 
+                          (SpecPrags (spec_inst_prags ++ spec_prags))
+                          rn_bind 
+           ; return (meth_id1, bind) }
+
+    ----------------------
+    tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
+    tc_default sel_id GenDefMeth    -- Derivable type classes stuff
+      = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
+           ; tc_body sel_id False {- Not generated code? -} meth_bind }
+    	  
+    tc_default sel_id NoDefMeth	    -- No default method at all
+      = do { warnMissingMethod sel_id
+    	   ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars 
+                                         inst_tys sel_id
+           ; return (meth_id, mkVarBind meth_id $ 
+                              mkLHsWrap lam_wrapper error_rhs) }
+      where
+    	error_rhs    = L loc $ HsApp error_fun error_msg
+    	error_fun    = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
+    	error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
+    	meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
+    	error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
+        lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
+
+    tc_default sel_id (DefMeth dm_name)	-- A polymorphic default method
+      = do {   -- Build the typechecked version directly, 
+    		 -- without calling typecheck_method; 
+    		 -- see Note [Default methods in instances]
+    		 -- Generate   /\as.\ds. let this = df as ds 
+               --                      in $dm inst_tys this
+    		 -- The 'let' is necessary only because HsSyn doesn't allow
+    		 -- you to apply a function to a dictionary *expression*.
+
+           ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars 
+                                                   inst_tys sel_id
+           ; dm_id <- tcLookupId dm_name
+           ; let dm_inline_prag = idInlinePragma dm_id
+                 EvBind self_dict _ = self_dict_ev
+                 rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
+    		         HsVar dm_id 
+
+    	         meth_bind = L loc $ VarBind { var_id = local_meth_id
+                                             , var_rhs = L loc rhs 
+    					       , var_inline = False }
+                 meth_id1 = meth_id `setInlinePragma` dm_inline_prag
+    		   	    -- Copy the inline pragma (if any) from the default
+    			    -- method to this version. Note [INLINE and default methods]
+    			    
+                 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars =  dfun_ev_vars
+                                 , abs_exports = [( tyvars, meth_id1, local_meth_id
+                                                  , SpecPrags spec_inst_prags)]
+                                 , abs_ev_binds = EvBinds (unitBag self_dict_ev)
+                                 , abs_binds    = unitBag meth_bind }
+    	     -- Default methods in an instance declaration can't have their own 
+    	     -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
+    	     -- currently they are rejected with 
+    	     --		  "INLINE pragma lacks an accompanying binding"
+
+           ; return (meth_id1, L loc bind) } 
+
+    ----------------------
+    loc = getSrcSpan dfun_id
+    meth_sig_fn _ = Just ([],loc)	-- The 'Just' says "yes, there's a type sig"
 	-- But there are no scoped type variables from local_method_id
 	-- Only the ones from the instance decl itself, which are already
 	-- in scope.  Example:
@@ -1075,22 +915,114 @@ tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts inst_tys
 	-- 	instance C [c] where { op = <rhs> }
 	-- In <rhs>, 'c' is scope but 'b' is not!
 
-    error_rhs    = L loc $ HsApp error_fun error_msg
-    error_fun    = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
-    error_msg    = L loc (HsLit (HsStringPrim (mkFastString error_string)))
-    meth_tau     = funResultTy (applyTys (idType sel_id) inst_tys)
-    error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
-
-    dfun_lam_vars = map instToVar dfun_dicts
-    lam_wrapper   = mkWpTyLams tyvars <.> mkWpLams dfun_lam_vars
+    mb_dict_ev = if null tyvars then Nothing else Just self_dict_ev
+		-- Only need the self_dict stuff if there are type 
+		-- variables involved; otherwise overlap is not possible
+		-- See Note [Subtle interaction of recursion and overlap]
+		-- in TcInstDcls
 
 	-- For instance decls that come from standalone deriving clauses
 	-- we want to print out the full source code if there's an error
 	-- because otherwise the user won't see the code at all
-    add_meth_ctxt rn_bind thing 
-      | standalone_deriv = addLandmarkErrCtxt (derivBindCtxt clas inst_tys rn_bind) thing
-      | otherwise        = thing
+    add_meth_ctxt generated_code rn_bind thing 
+      | generated_code = addLandmarkErrCtxt (derivBindCtxt clas inst_tys rn_bind) thing
+      | otherwise      = thing
+
+
+tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys 
+		  _ _ op_items (NewTypeDerived coi _)
+
+-- Running example:
+--   class Show b => Foo a b where
+--     op :: a -> b -> b
+--   newtype N a = MkN (Tree [a]) 
+--   deriving instance (Show p, Foo Int p) => Foo Int (N p)
+--		 -- NB: standalone deriving clause means
+--		 --     that the contex is user-specified
+-- Hence op :: forall a b. Foo a b => a -> b -> b
+--
+-- We're going to make an instance like
+--   instance (Show p, Foo Int p) => Foo Int (N p)
+--      op = $copT
+--
+--   $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
+--   $copT p (d1:Show p) (d2:Foo Int p) 
+--     = op Int (Tree [p]) rep_d |> op_co
+--     where 
+--       rep_d :: Foo Int (Tree [p]) = ...d1...d2...
+--       op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
+-- We get op_co by substituting [Int/a] and [co/b] in type for op
+-- where co : [p] ~ T p
+--
+-- Notice that the dictionary bindings "..d1..d2.." must be generated
+-- by the constraint solver, since the <context> may be
+-- user-specified.
+
+  = do { rep_d_stuff <- checkConstraints InstSkol emptyVarSet tyvars dfun_ev_vars $
+                        emitWanted ScOrigin rep_pred
+                         
+       ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
+  where
+     loc = getSrcSpan dfun_id
+
+     inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
+     Just (init_inst_tys, _) = snocView inst_tys
+     rep_ty   = fst (coercionKind co)  -- [p]
+     rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
+
+     -- co : [p] ~ T p
+     co = substTyWith inst_tvs (mkTyVarTys tyvars) $
+          case coi of { IdCo ty -> ty ;
+                        ACo co  -> mkSymCoercion co }
+
+     ----------------
+     tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
+     tc_item (rep_ev_binds, rep_d) (sel_id, _)
+       = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars 
+                                                    inst_tys sel_id
+
+            ; let meth_rhs  = wrapId (mk_op_wrapper sel_id rep_d) sel_id
+                  meth_bind = VarBind { var_id = local_meth_id
+                                      , var_rhs = L loc meth_rhs
+    				      , var_inline = False }
+
+	          bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
+                                   , abs_exports = [(tyvars, meth_id, 
+                                                     local_meth_id, noSpecPrags)]
+				   , abs_ev_binds = rep_ev_binds
+                                   , abs_binds = unitBag $ L loc meth_bind }
+
+            ; return (meth_id, L loc bind) }
+
+     ----------------
+     mk_op_wrapper :: Id -> EvVar -> HsWrapper
+     mk_op_wrapper sel_id rep_d 
+       = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
+         <.> WpEvApp (EvId rep_d)
+         <.> mkWpTyApps (init_inst_tys ++ [rep_ty]) 
+       where
+         (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
+         (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
+                              `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
+
+----------------------
+mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
+mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
+  = do  { uniq <- newUnique
+  	; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
+  	; local_meth_name <- newLocalName sel_name
+  		  -- Base the local_meth_name on the selector name, becuase
+  		  -- type errors from tcInstanceMethodBody come from here
+
+  	; let meth_id       = mkLocalId meth_name meth_ty
+  	      local_meth_id = mkLocalId local_meth_name local_meth_ty
+        ; return (meth_id, local_meth_id) }
+  where
+    local_meth_ty = instantiateMethod clas sel_id inst_tys
+    meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
+    sel_name = idName sel_id
 
+----------------------
 wrapId :: HsWrapper -> id -> HsExpr id
 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
 
@@ -1234,9 +1166,6 @@ instDeclCtxt2 dfun_ty
 inst_decl_ctxt :: SDoc -> SDoc
 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
 
-superClassCtxt :: SDoc
-superClassCtxt = ptext (sLit "When checking the super-classes of an instance declaration")
-
 atInstCtxt :: Name -> SDoc
 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
                   quotes (ppr name)
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
new file mode 100644
index 0000000..6f48a4f
--- /dev/null
+++ b/compiler/typecheck/TcInteract.lhs
@@ -0,0 +1,1669 @@
+\begin{code}
+module TcInteract ( 
+     solveInteract, AtomicInert, 
+     InertSet, emptyInert, extendInertSet, extractUnsolved, solveOne,
+     listToWorkList
+  ) where  
+
+#include "HsVersions.h"
+
+import BasicTypes 
+import TcCanonical
+import VarSet
+import Type
+
+import Id 
+import Var
+
+import TcType
+import HsBinds 
+
+import InstEnv 
+import Class 
+import TyCon 
+import Name
+
+import FunDeps
+
+import Control.Monad ( when ) 
+
+import Coercion
+import Outputable
+
+import TcRnTypes 
+import TcErrors
+import TcSMonad 
+import qualified Bag as Bag
+import Control.Monad( zipWithM, unless )
+import FastString ( sLit ) 
+import DynFlags
+\end{code}
+
+Note [InsertSet invariants]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+An InertSet is a bag of canonical constraints, with the following invariants:
+
+  1 No two constraints react with each other. 
+    
+    A tricky case is when there exists a given (solved) dictionary 
+    constraint and a wanted identical constraint in the inert set, but do 
+    not react because reaction would create loopy dictionary evidence for 
+    the wanted. See note [Recursive dictionaries]
+
+  2 Given equalities form an idempotent substitution [none of the
+    given LHS's occur in any of the given RHS's or reactant parts]
+
+  3 Wanted equalities also form an idempotent substitution
+  4 The entire set of equalities is acyclic.
+
+  5 Wanted dictionaries are inert with the top-level axiom set 
+
+  6 Equalities of the form tv1 ~ tv2 always have a touchable variable
+    on the left (if possible).
+  7 No wanted constraints tv1 ~ tv2 with tv1 touchable. Such constraints 
+    will be marked as solved right before being pushed into the inert set. 
+    See note [Touchables and givens].
+ 
+Note that 6 and 7 are /not/ enforced by canonicalization but rather by 
+insertion in the inert list, ie by TcInteract. 
+
+During the process of solving, the inert set will contain some
+previously given constraints, some wanted constraints, and some given
+constraints which have arisen from solving wanted constraints. For
+now we do not distinguish between given and solved constraints.
+
+Note that we must switch wanted inert items to given when going under an
+implication constraint (when in top-level inference mode).
+
+\begin{code}
+
+-- See Note [InertSet invariants]
+
+newtype InertSet = IS (Bag.Bag CanonicalCt)
+instance Outputable InertSet where
+  ppr (IS cts) = vcat (map ppr (Bag.bagToList cts))
+
+{- TODO: Later ...
+data Inert = IS { class_inerts :: FiniteMap Class Atomics
+     	          ip_inerts    :: FiniteMap Class Atomics
+     	          tyfun_inerts :: FiniteMap TyCon Atomics
+		  tyvar_inerts :: FiniteMap TyVar Atomics
+                }
+
+Later should we also separate out givens and wanteds?
+-}
+
+emptyInert :: InertSet
+emptyInert = IS Bag.emptyBag
+
+extendInertSet :: InertSet -> AtomicInert -> InertSet
+extendInertSet (IS cts) item = IS (cts `Bag.snocBag` item)
+
+foldlInertSetM :: (Monad m) => (a -> AtomicInert -> m a) -> a -> InertSet -> m a 
+foldlInertSetM k z (IS cts) = Bag.foldlBagM k z cts
+
+extractUnsolved :: InertSet -> (InertSet, CanonicalCts)
+extractUnsolved (IS cts)
+  = (IS cts', unsolved)
+  where (unsolved, cts') = Bag.partitionBag isWantedCt cts
+
+isWantedCt :: CanonicalCt -> Bool 
+isWantedCt ct = isWanted (cc_flavor ct)
+\end{code}
+
+Note [Touchables and givens]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Touchable variables will never show up in givens which are inputs to
+the solver.  However, touchables may show up in givens generated by the flattener.  
+For example,
+
+  axioms:
+    G Int ~ Char
+    F Char ~ Int
+
+  wanted:
+    F (G alpha) ~w Int
+  
+canonicalises to
+
+  G alpha ~g b
+  F b ~w Int
+
+which can be put in the inert set.  Suppose we also have a wanted
+
+  alpha ~w Int
+
+We cannot rewrite the given G alpha ~g b using the wanted alpha ~w
+Int.  Instead, after reacting alpha ~w Int with the whole inert set,
+we observe that we can solve it by unifying alpha with Int, so we mark
+it as solved and put it back in the *work list*. [We also immediately unify
+alpha := Int, without telling anyone, see trySpontaneousSolve function, to 
+avoid doing this in the end.]
+
+Later, because it is solved (given, in effect), we can use it to rewrite 
+G alpha ~g b to G Int ~g b, which gets put back in the work list. Eventually, 
+we will dispatch the remaining wanted constraints using the top-level axioms.
+
+Finally, note that after reacting a wanted equality with the entire inert set
+we may end up with something like
+
+  b ~w alpha
+
+which we should flip around to generate the solved constraint alpha ~s b.
+
+%*********************************************************************
+%*                                                                   * 
+*                      Main Interaction Solver                       *
+*                                                                    *
+**********************************************************************
+
+Note [Basic plan] 
+~~~~~~~~~~~~~~~~~
+1. Canonicalise (unary)
+2. Pairwise interaction (binary)
+    * Take one from work list 
+    * Try all pair-wise interactions with each constraint in inert
+3. Try to solve spontaneously for equalities involving touchables 
+4. Top-level interaction (binary wrt top-level)
+   Superclass decomposition belongs in (4), see note [Superclasses]
+
+\begin{code}
+
+type AtomicInert = CanonicalCt     -- constraint pulled from InertSet
+type WorkItem    = CanonicalCt     -- constraint pulled from WorkList
+type SWorkItem   = WorkItem        -- a work item we know is solved
+
+type WorkList    = CanonicalCts    -- A mixture of Given, Wanted, and Solved
+                   
+
+listToWorkList :: [WorkItem] -> WorkList
+listToWorkList = Bag.listToBag
+
+unionWorkLists :: WorkList -> WorkList -> WorkList 
+unionWorkLists = Bag.unionBags 
+
+foldlWorkListM :: (Monad m) => (a -> WorkItem -> m a) -> a -> WorkList -> m a 
+foldlWorkListM = Bag.foldlBagM 
+
+isEmptyWorkList :: WorkList -> Bool 
+isEmptyWorkList = Bag.isEmptyBag
+
+emptyWorkList :: WorkList
+emptyWorkList = Bag.emptyBag
+
+data StopOrContinue 
+  = Stop			-- Work item is consumed
+  | ContinueWith WorkItem	-- Not consumed
+
+instance Outputable StopOrContinue where
+  ppr Stop             = ptext (sLit "Stop")
+  ppr (ContinueWith w) = ptext (sLit "ContinueWith") <+> ppr w
+
+-- Results after interacting a WorkItem as far as possible with an InertSet
+data StageResult
+  = SR { sr_inerts     :: InertSet
+           -- The new InertSet to use (REPLACES the old InertSet)
+       , sr_new_work   :: WorkList
+           -- Any new work items generated (should be ADDED to the old WorkList)
+           -- Invariant: 
+           --    sr_stop = Just workitem => workitem is *not* in sr_inerts and
+           --                               workitem is inert wrt to sr_inerts
+       , sr_stop       :: StopOrContinue
+       }
+
+instance Outputable StageResult where
+  ppr (SR { sr_inerts = inerts, sr_new_work = work, sr_stop = stop })
+    = ptext (sLit "SR") <+> 
+      braces (sep [ ptext (sLit "inerts =") <+> ppr inerts <> comma
+             	  , ptext (sLit "new work =") <+> ppr work <> comma
+             	  , ptext (sLit "stop =") <+> ppr stop])
+
+type SimplifierStage = WorkItem -> InertSet -> TcS StageResult 
+
+-- Combine a sequence of simplifier 'stages' to create a pipeline 
+runSolverPipeline :: [(String, SimplifierStage)]
+                  -> InertSet -> WorkItem 
+                  -> TcS (InertSet, WorkList)
+-- Precondition: non-empty list of stages 
+runSolverPipeline pipeline inerts workItem
+  = do { traceTcS "Start solver pipeline" $ 
+            vcat [ ptext (sLit "work item =") <+> ppr workItem
+                 , ptext (sLit "inerts    =") <+> ppr inerts]
+
+       ; let itr_in = SR { sr_inerts = inerts
+                        , sr_new_work = emptyWorkList
+                        , sr_stop = ContinueWith workItem }
+       ; itr_out <- run_pipeline pipeline itr_in
+       ; let new_inert 
+              = case sr_stop itr_out of 
+       	          Stop              -> sr_inerts itr_out
+                  ContinueWith item -> sr_inerts itr_out `extendInertSet` item
+       ; return (new_inert, sr_new_work itr_out) }
+  where 
+    run_pipeline :: [(String, SimplifierStage)]
+                 -> StageResult -> TcS StageResult
+    run_pipeline [] itr                         = return itr
+    run_pipeline _  itr@(SR { sr_stop = Stop }) = return itr
+
+    run_pipeline ((name,stage):stages) 
+                 (SR { sr_new_work = accum_work
+                     , sr_inerts   = inerts
+                     , sr_stop     = ContinueWith work_item })
+      = do { itr <- stage work_item inerts 
+           ; traceTcS ("Stage result (" ++ name ++ ")") (ppr itr)
+           ; let itr' = itr { sr_new_work = sr_new_work itr 
+                                            `unionWorkLists` accum_work }
+           ; run_pipeline stages itr' }
+\end{code}
+
+Example 1:
+  Inert:   {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given)
+  Reagent: a ~ [b] (given)
+
+React with (c~d)     ==> IR (ContinueWith (a~[b]))  True    []
+React with (F a ~ t) ==> IR (ContinueWith (a~[b]))  False   [F [b] ~ t]
+React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True    []
+
+Example 2:
+  Inert:  {c ~w d, F a ~g t, b ~w Int, a ~w ty}
+  Reagent: a ~w [b]
+
+React with (c ~w d)   ==> IR (ContinueWith (a~[b]))  True    []
+React with (F a ~g t) ==> IR (ContinueWith (a~[b]))  True    []    (can't rewrite given with wanted!)
+etc.
+
+Example 3:
+  Inert:  {a ~ Int, F Int ~ b} (given)
+  Reagent: F a ~ b (wanted)
+
+React with (a ~ Int)   ==> IR (ContinueWith (F Int ~ b)) True []
+React with (F Int ~ b) ==> IR Stop True []    -- after substituting we re-canonicalize and get nothing
+
+\begin{code}
+-- Main interaction solver: we fully solve the worklist 'in one go', 
+-- returning an extended inert set.
+--
+-- See Note [Touchables and givens].
+solveInteract :: InertSet -> WorkList -> TcS InertSet
+solveInteract inert ws 
+  = do { dyn_flags <- getDynFlags
+       ; solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) inert ws 
+       }
+solveOne :: InertSet -> WorkItem -> TcS InertSet 
+solveOne inerts workItem 
+  = do { dyn_flags <- getDynFlags
+       ; solveOneWithDepth (ctxtStkDepth dyn_flags,0,[]) inerts workItem
+       }
+
+-----------------
+solveInteractWithDepth :: (Int, Int, [WorkItem])
+                       -> InertSet -> WorkList -> TcS InertSet
+solveInteractWithDepth ctxt@(max_depth,n,stack) inert ws 
+  | isEmptyWorkList ws
+  = return inert
+
+  | n > max_depth 
+  = solverDepthErrorTcS n stack
+
+  | otherwise 
+  = do { traceTcS "solveInteractWithDepth" $ 
+         vcat [ text "Current depth =" <+> ppr n
+              , text "Max depth =" <+> ppr max_depth
+              ]
+       ; foldlWorkListM (solveOneWithDepth ctxt) inert ws }
+
+------------------
+-- Fully interact the given work item with an inert set, and return a
+-- new inert set which has assimilated the new information.
+solveOneWithDepth :: (Int, Int, [WorkItem])
+                  -> InertSet -> WorkItem -> TcS InertSet
+solveOneWithDepth (max_depth, n, stack) inert work
+  = do { traceTcS0 (indent ++ "Solving {") (ppr work)
+       ; (new_inert, new_work) <- runSolverPipeline thePipeline inert work
+         
+       ; traceTcS0 (indent ++ "Subgoals:") (ppr new_work)
+
+	 -- Recursively solve the new work generated 
+         -- from workItem, with a greater depth
+       ; res_inert <- solveInteractWithDepth (max_depth, n+1, work:stack)
+                                new_inert new_work 
+
+       ; traceTcS0 (indent ++ "Done }") (ppr work) 
+       ; return res_inert }
+  where
+    indent = replicate (2*n) ' '
+
+thePipeline :: [(String,SimplifierStage)]
+thePipeline = [ ("interact with inerts", interactWithInertsStage)
+              , ("spontaneous solve",    spontaneousSolveStage)
+              , ("top-level reactions",  topReactionsStage) ]
+\end{code}
+
+*********************************************************************************
+*                                                                               * 
+                       The spontaneous-solve Stage
+*                                                                               *
+*********************************************************************************
+
+\begin{code}
+spontaneousSolveStage :: SimplifierStage 
+spontaneousSolveStage workItem inerts 
+  = do { mSolve <- trySpontaneousSolve workItem 
+       ; case mSolve of 
+           Nothing -> -- no spontaneous solution for him, keep going
+               return $ SR { sr_new_work   = emptyWorkList 
+                           , sr_inerts     = inerts 
+                           , sr_stop       = ContinueWith workItem }
+
+           Just workItem' -- He has been solved; workItem' is a Given
+               | isWantedCt workItem 
+                           -- Original was wanted we have now made him given so 
+                           -- we have to ineract him with the inerts again because 
+                           -- of the change in his status. This may produce some work. 
+                   -> do { traceTcS "recursive interact with inerts {" $ vcat
+                               [ text "work = " <+> ppr workItem'
+                               , text "inerts = " <+> ppr inerts ]
+                         ; itr_again <- interactWithInertsStage workItem' inerts 
+                         ; case sr_stop itr_again of 
+                            Stop -> pprPanic "BUG: Impossible to happen" $ 
+                                    vcat [ text "Original workitem:" <+> ppr workItem
+                                         , text "Spontaneously solved:" <+> ppr workItem'
+                                         , text "Solved was consumed, when reacting with inerts:"
+                                         , nest 2 (ppr inerts) ]
+                            ContinueWith workItem'' -- Now *this* guy is inert wrt to inerts
+                                ->  do { traceTcS "end recursive interact }" $ ppr workItem''
+                                       ; return $ SR { sr_new_work = sr_new_work itr_again
+                                                     , sr_inerts   = sr_inerts itr_again 
+                                                                     `extendInertSet` workItem'' 
+                                                     , sr_stop     = Stop } }
+                         }
+               | otherwise
+                   -> return $ SR { sr_new_work   = emptyWorkList 
+                                  , sr_inerts     = inerts `extendInertSet` workItem' 
+                                  , sr_stop       = Stop } }
+
+-- @trySpontaneousSolve wi@ solves equalities where one side is a
+-- touchable unification variable. Returns:
+--   * Nothing if we were not able to solve it
+--   * Just wi' if we solved it, wi' (now a "given") should be put in the work list.
+--     	    See Note [Touchables and givens] 
+trySpontaneousSolve :: WorkItem -> TcS (Maybe SWorkItem)
+trySpontaneousSolve (CTyEqCan { cc_id = cv, cc_flavor = gw, cc_tyvar = tv1, cc_rhs = xi }) 
+  | Just tv2 <- tcGetTyVar_maybe xi
+  = do { tch1 <- isTouchableMetaTyVar tv1
+       ; tch2 <- isTouchableMetaTyVar tv2
+       ; case (tch1, tch2) of
+           (True,  True)  -> trySpontaneousEqTwoWay cv gw tv1 tv2
+           (True,  False) -> trySpontaneousEqOneWay cv gw tv1 xi
+           (False, True)  | tyVarKind tv1 `isSubKind` tyVarKind tv2
+                          -> trySpontaneousEqOneWay cv gw tv2 (mkTyVarTy tv1)
+	   _ -> return Nothing }
+  | otherwise
+  = do { tch1 <- isTouchableMetaTyVar tv1
+       ; if tch1 then trySpontaneousEqOneWay cv gw tv1 xi
+                 else return Nothing }
+
+  -- No need for 
+  --      trySpontaneousSolve (CFunEqCan ...) = ...
+  -- See Note [No touchables as FunEq RHS] in TcSMonad
+trySpontaneousSolve _ = return Nothing 
+
+----------------
+trySpontaneousEqOneWay :: CoVar -> CtFlavor -> TcTyVar -> Xi
+                       -> TcS (Maybe SWorkItem)
+-- tv is a MetaTyVar, not untouchable
+-- Precondition: kind(xi) is a sub-kind of kind(tv)
+trySpontaneousEqOneWay cv gw tv xi	
+  | not (isSigTyVar tv) || isTyVarTy xi
+  = solveWithIdentity cv gw tv xi
+  | otherwise
+  = return Nothing
+
+----------------
+trySpontaneousEqTwoWay :: CoVar -> CtFlavor -> TcTyVar -> TcTyVar
+                       -> TcS (Maybe SWorkItem)
+-- Both tyvars are *touchable* MetaTyvars
+-- By the CTyEqCan invariant, k2 `isSubKind` k1
+trySpontaneousEqTwoWay cv gw tv1 tv2
+  | k1 `eqKind` k2
+  , nicer_to_update_tv2 = solveWithIdentity cv gw tv2 (mkTyVarTy tv1)
+  | otherwise           = ASSERT( k2 `isSubKind` k1 )
+                          solveWithIdentity cv gw tv1 (mkTyVarTy tv2)
+  where
+    k1 = tyVarKind tv1
+    k2 = tyVarKind tv2
+    nicer_to_update_tv2 = isSigTyVar tv1 || isSystemName (Var.varName tv2)
+\end{code}
+
+Note [Loopy spontaneous solving] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the original wanted: 
+   wanted :  Maybe (E alpha) ~ alpha 
+where E is a type family, such that E (T x) = x. After canonicalization, 
+as a result of flattening, we will get: 
+   given  : E alpha ~ fsk 
+   wanted : alpha ~ Maybe fsk
+where (fsk := E alpha, on the side). Now, if we spontaneously *solve* 
+(alpha := Maybe fsk) we are in trouble! Instead, we should refrain from solving 
+it and keep it as wanted.  In inference mode we'll end up quantifying over
+   (alpha ~ Maybe (E alpha))
+Hence, 'solveWithIdentity' performs a small occurs check before
+actually solving. But this occurs check *must look through* flatten
+skolems.
+
+Note [Avoid double unifications] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The spontaneous solver has to return a given which mentions the unified unification
+variable *on the left* of the equality. Here is what happens if not: 
+  Original wanted:  (a ~ alpha),  (alpha ~ Int) 
+We spontaneously solve the first wanted, without changing the order! 
+      given : a ~ alpha      [having unifice alpha := a] 
+Now the second wanted comes along, but he cannot rewrite the given, so we simply continue.
+At the end we spontaneously solve that guy, *reunifying*  [alpha := Int] 
+
+We avoid this problem by orienting the given so that the unification variable is on the left. 
+[Note that alternatively we could attempt to enforce this at canonicalization] 
+
+Avoiding double unifications is yet another reason to disallow touchable unification variables
+as RHS of type family equations: F xis ~ alpha. Consider having already spontaneously solved 
+a wanted (alpha ~ [b]) by setting alpha := [b]. So the inert set looks like: 
+         given : alpha ~ [b]
+And now a new wanted (F tau ~ alpha) comes along. Since it does not react with anything 
+we will be left with a constraint (F tau ~ alpha) that must cause a unification of 
+(alpha := F tau) at some point (either in spontaneous solving, or at the end). But alpha 
+is *already* unified so we must not do anything to it. By disallowing naked touchables in 
+the RHS of constraints (in favor of introduced flatten skolems) we do not have to worry at 
+all about unifying or spontaneously solving (F xis ~ alpha) by unification. 
+
+\begin{code}
+----------------
+solveWithIdentity :: CoVar -> CtFlavor -> TcTyVar -> Xi -> TcS (Maybe SWorkItem)
+-- Solve with the identity coercion 
+-- Precondition: kind(xi) is a sub-kind of kind(tv)
+-- See [New Wanted Superclass Work] to see why we do this for *given* as well
+solveWithIdentity cv gw tv xi 
+  | tv `elemVarSet` tyVarsOfUnflattenedType xi 
+       		    -- Beware of Note [Loopy spontaneous solving] 
+                    -- Can't spontaneously solve loopy equalities
+                    -- though they are not a type error 
+  = return Nothing 
+  | not (isGiven gw) -- Wanted or Derived 
+  = do { traceTcS "Sneaky unification:" $ 
+         vcat [text "Coercion variable:  " <+> ppr gw, 
+               text "Coercion:           " <+> pprEq (mkTyVarTy tv) xi,
+               text "Left  Kind is     : " <+> ppr (typeKind (mkTyVarTy tv)),
+               text "Right Kind is     : " <+> ppr (typeKind xi)
+              ]
+       ; setWantedTyBind tv xi                  -- Set tv := xi
+       ; cv_given <- newGivOrDerCoVar (mkTyVarTy tv) xi xi  
+                                                -- Create new given with identity evidence
+
+       ; case gw of 
+           Wanted  {} -> setWantedCoBind  cv xi 
+           Derived {} -> setDerivedCoBind cv xi 
+           _          -> pprPanic "Can't spontaneously solve *given*" empty 
+
+       ; let solved = CTyEqCan { cc_id = cv_given
+                               , cc_flavor = mkGivenFlavor gw UnkSkol
+                               , cc_tyvar = tv, cc_rhs = xi }
+       -- See Note [Avoid double unifications] 
+
+       -- The reason that we create a new given variable (cv_given) instead of reusing cv
+       -- is because we do not want to end up with coercion unification variables in the givens.
+       ; return (Just solved) }
+  | otherwise        -- Given 
+  = return Nothing 
+
+tyVarsOfUnflattenedType :: TcType -> TcTyVarSet
+-- A version of tyVarsOfType which looks through flatSkols
+tyVarsOfUnflattenedType ty
+  = foldVarSet (unionVarSet . do_tv) emptyVarSet (tyVarsOfType ty)
+  where
+    do_tv :: TyVar -> TcTyVarSet
+    do_tv tv = ASSERT( isTcTyVar tv)
+               case tcTyVarDetails tv of 
+                  FlatSkol ty -> tyVarsOfUnflattenedType ty
+                  _           -> unitVarSet tv 
+\end{code}
+
+
+*********************************************************************************
+*                                                                               * 
+                       The interact-with-inert Stage
+*                                                                               *
+*********************************************************************************
+
+\begin{code}
+-- Interaction result of  WorkItem <~> AtomicInert
+data InteractResult
+   = IR { ir_stop         :: StopOrContinue
+            -- Stop
+            --   => Reagent (work item) consumed.
+            -- ContinueWith new_reagent
+            --   => Reagent transformed but keep gathering interactions. 
+            --      The transformed item remains inert with respect 
+            --      to any previously encountered inerts.
+
+        , ir_inert_action :: InertAction
+            -- Whether the inert item should remain in the InertSet.
+
+        , ir_new_work     :: WorkList
+            -- new work items to add to the WorkList
+        }
+
+-- What to do with the inert reactant.
+data InertAction = KeepInert | DropInert
+  deriving Eq
+
+mkIRContinue :: Monad m => WorkItem -> InertAction -> WorkList -> m InteractResult
+mkIRContinue wi keep newWork = return $ IR (ContinueWith wi) keep newWork
+
+mkIRStop :: Monad m => InertAction -> WorkList -> m InteractResult
+mkIRStop keep newWork = return $ IR Stop keep newWork
+
+dischargeWorkItem :: Monad m => m InteractResult
+dischargeWorkItem = mkIRStop KeepInert emptyCCan
+
+noInteraction :: Monad m => WorkItem -> m InteractResult
+noInteraction workItem = mkIRContinue workItem KeepInert emptyCCan
+
+
+---------------------------------------------------
+-- Interact a single WorkItem with an InertSet as far as possible, i.e. until we get a Stop 
+-- result from an individual interaction (i.e. when the WorkItem is consumed), or until we've 
+-- interacted the WorkItem with the entire InertSet.
+--
+-- Postcondition: the new InertSet in the resulting StageResult is subset 
+-- of the input InertSet.
+
+interactWithInertsStage :: SimplifierStage
+interactWithInertsStage workItem inert
+  = foldlInertSetM interactNext initITR inert
+  where 
+    initITR = SR { sr_inerts   = emptyInert
+                 , sr_new_work = emptyCCan
+                 , sr_stop     = ContinueWith workItem }
+
+    interactNext :: StageResult -> AtomicInert -> TcS StageResult 
+    interactNext it inert  
+      | ContinueWith workItem <- sr_stop it
+        = do { ir <- interactWithInert inert workItem 
+             ; let inerts = sr_inerts it 
+             ; return $ SR { sr_inerts   = if ir_inert_action ir == KeepInert
+                                           then inerts `extendInertSet` inert
+                                           else inerts
+                           , sr_new_work = sr_new_work it `unionWorkLists` ir_new_work ir
+                           , sr_stop     = ir_stop ir } }
+      | otherwise = return $ itrAddInert inert it
+    
+                             
+    itrAddInert :: AtomicInert -> StageResult -> StageResult
+    itrAddInert inert itr = itr { sr_inerts = (sr_inerts itr) `extendInertSet` inert }
+
+-- Do a single interaction of two constraints.
+interactWithInert :: AtomicInert -> WorkItem -> TcS InteractResult
+interactWithInert inert workitem 
+  =  do { ctxt <- getTcSContext
+        ; let is_allowed  = allowedInteraction (simplEqsOnly ctxt) inert workitem 
+              inert_ev    = cc_id inert 
+              work_ev     = cc_id workitem 
+
+        -- Never interact a wanted and a derived where the derived's evidence 
+        -- mentions the wanted evidence in an unguarded way. 
+        -- See Note [Superclasses and recursive dictionaries] 
+        -- and Note [New Wanted Superclass Work] 
+        -- We don't have to do this for givens, as we fully know the evidence for them. 
+        ; rec_ev_ok <- 
+            case (cc_flavor inert, cc_flavor workitem) of 
+              (Wanted loc, Derived _) -> isGoodRecEv work_ev  (WantedEvVar inert_ev loc)
+              (Derived _, Wanted loc) -> isGoodRecEv inert_ev (WantedEvVar work_ev loc)
+              _                       -> return True 
+
+        ; if is_allowed && rec_ev_ok then 
+              doInteractWithInert inert workitem 
+          else 
+              noInteraction workitem 
+        }
+
+allowedInteraction :: Bool -> AtomicInert -> WorkItem -> Bool 
+-- Allowed interactions 
+allowedInteraction eqs_only (CDictCan {}) (CDictCan {}) = not eqs_only
+allowedInteraction eqs_only (CIPCan {})   (CIPCan {})   = not eqs_only
+allowedInteraction _ _ _ = True 
+
+--------------------------------------------
+doInteractWithInert :: CanonicalCt -> CanonicalCt -> TcS InteractResult
+-- Identical class constraints.
+
+doInteractWithInert 
+           (CDictCan { cc_id = d1, cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 }) 
+  workItem@(CDictCan { cc_id = d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 })
+  | cls1 == cls2 && (and $ zipWith tcEqType tys1 tys2)
+  = solveOneFromTheOther (d1,fl1) workItem 
+
+  | cls1 == cls2 && (not (isGiven fl1 && isGiven fl2))
+  = 	 -- See Note [When improvement happens]
+    do { let work_item_pred_loc = (ClassP cls2 tys2, ppr d2)
+             inert_pred_loc     = (ClassP cls1 tys1, ppr d1)
+	     loc                = combineCtLoc fl1 fl2
+             eqn_pred_locs = improveFromAnother work_item_pred_loc inert_pred_loc         
+       ; wevvars <- mkWantedFunDepEqns loc eqn_pred_locs 
+              	 -- See Note [Generating extra equalities]
+       ; workList <- canWanteds wevvars 
+       ; mkIRContinue workItem KeepInert workList -- Keep the inert there so we avoid 
+                                                  -- re-introducing the fundep equalities
+         -- See Note [FunDep Reactions] 
+       }
+
+-- Class constraint and given equality: use the equality to rewrite
+-- the class constraint. 
+doInteractWithInert (CTyEqCan { cc_id = cv, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi }) 
+                    (CDictCan { cc_id = dv, cc_flavor = wfl, cc_class = cl, cc_tyargs = xis }) 
+  | ifl `canRewrite` wfl 
+  , tv `elemVarSet` tyVarsOfTypes xis
+    -- substitute for tv in xis.  Note that the resulting class
+    -- constraint is still canonical, since substituting xi-types in
+    -- xi-types generates xi-types.  However, it may no longer be
+    -- inert with respect to the inert set items we've already seen.
+    -- For example, consider the inert set
+    --
+    --   D Int (g)
+    --   a ~g Int
+    --
+    -- and the work item D a (w). D a does not interact with D Int.
+    -- Next, it does interact with a ~g Int, getting rewritten to D
+    -- Int (w).  But now we must go back through the rest of the inert
+    -- set again, to find that it can now be discharged by the given D
+    -- Int instance.
+  = do { rewritten_dict <- rewriteDict (cv,tv,xi) (dv,wfl,cl,xis)
+       ; mkIRStop KeepInert (singleCCan rewritten_dict) }
+    
+doInteractWithInert (CDictCan { cc_id = dv, cc_flavor = ifl, cc_class = cl, cc_tyargs = xis }) 
+           workItem@(CTyEqCan { cc_id = cv, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi })
+  | wfl `canRewrite` ifl
+  , tv `elemVarSet` tyVarsOfTypes xis
+  = do { rewritten_dict <- rewriteDict (cv,tv,xi) (dv,ifl,cl,xis) 
+       ; mkIRContinue workItem DropInert (singleCCan rewritten_dict) }
+
+-- Class constraint and given equality: use the equality to rewrite
+-- the class constraint.
+doInteractWithInert (CTyEqCan { cc_id = cv, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi }) 
+                    (CIPCan { cc_id = ipid, cc_flavor = wfl, cc_ip_nm = nm, cc_ip_ty = ty }) 
+  | ifl `canRewrite` wfl
+  , tv `elemVarSet` tyVarsOfType ty 
+  = do { rewritten_ip <- rewriteIP (cv,tv,xi) (ipid,wfl,nm,ty) 
+       ; mkIRStop KeepInert (singleCCan rewritten_ip) }
+
+doInteractWithInert (CIPCan { cc_id = ipid, cc_flavor = ifl, cc_ip_nm = nm, cc_ip_ty = ty }) 
+           workItem@(CTyEqCan { cc_id = cv, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi })
+  | wfl `canRewrite` ifl
+  , tv `elemVarSet` tyVarsOfType ty
+  = do { rewritten_ip <- rewriteIP (cv,tv,xi) (ipid,ifl,nm,ty) 
+       ; mkIRContinue workItem DropInert (singleCCan rewritten_ip) } 
+
+-- Two implicit parameter constraints.  If the names are the same,
+-- but their types are not, we generate a wanted type equality 
+-- that equates the type (this is "improvement").  
+-- However, we don't actually need the coercion evidence,
+-- so we just generate a fresh coercion variable that isn't used anywhere.
+doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 }) 
+           workItem@(CIPCan { cc_flavor = wfl, cc_ip_nm = nm2, cc_ip_ty = ty2 })
+  | nm1 == nm2 && ty1 `tcEqType` ty2 
+  = solveOneFromTheOther (id1,ifl) workItem 
+
+  | nm1 == nm2 && (not (isGiven ifl && isGiven wfl))
+  =  	-- See Note [When improvement happens]
+    do { co_var <- newWantedCoVar ty1 ty2 
+       ; let flav = Wanted (combineCtLoc ifl wfl) 
+       ; mkCanonical flav co_var >>= mkIRContinue workItem KeepInert } 
+
+
+-- Inert: equality, work item: function equality
+
+-- Never rewrite a given with a wanted equality, and a type function
+-- equality can never rewrite an equality.  Note also that if we have
+-- F x1 ~ x2 and a ~ x3, and a occurs in x2, we don't rewrite it.  We
+-- can wait until F x1 ~ x2 matches another F x1 ~ x4, and only then
+-- we will ``expose'' x2 and x4 to rewriting.
+
+-- Otherwise, we can try rewriting the type function equality with the equality.
+doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = ifl, cc_tyvar = tv, cc_rhs = xi1 }) 
+                    (CFunEqCan { cc_id = cv2, cc_flavor = wfl, cc_fun = tc
+                               , cc_tyargs = args, cc_rhs = xi2 })
+  | ifl `canRewrite` wfl 
+  , tv `elemVarSet` tyVarsOfTypes args
+  = do { rewritten_funeq <- rewriteFunEq (cv1,tv,xi1) (cv2,wfl,tc,args,xi2) 
+       ; mkIRStop KeepInert (singleCCan rewritten_funeq) }
+
+-- Inert: function equality, work item: equality
+
+doInteractWithInert (CFunEqCan {cc_id = cv1, cc_flavor = ifl, cc_fun = tc
+                              , cc_tyargs = args, cc_rhs = xi1 }) 
+           workItem@(CTyEqCan { cc_id = cv2, cc_flavor = wfl, cc_tyvar = tv, cc_rhs = xi2 })
+  | wfl `canRewrite` ifl
+  , tv `elemVarSet` tyVarsOfTypes args
+  = do { rewritten_funeq <- rewriteFunEq (cv2,tv,xi2) (cv1,ifl,tc,args,xi1) 
+       ; mkIRContinue workItem DropInert (singleCCan rewritten_funeq) } 
+
+doInteractWithInert (CFunEqCan { cc_id = cv1, cc_flavor = fl1, cc_fun = tc1
+                               , cc_tyargs = args1, cc_rhs = xi1 }) 
+           workItem@(CFunEqCan { cc_id = cv2, cc_flavor = fl2, cc_fun = tc2
+                               , cc_tyargs = args2, cc_rhs = xi2 })
+  | fl1 `canRewrite` fl2 && lhss_match
+  = do { cans <- rewriteEqLHS (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2) 
+       ; mkIRStop KeepInert cans } 
+  | fl2 `canRewrite` fl1 && lhss_match
+  = do { cans <- rewriteEqLHS (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1) 
+       ; mkIRContinue workItem DropInert cans }
+  where
+    lhss_match = tc1 == tc2 && and (zipWith tcEqType args1 args2) 
+
+doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 }) 
+           workItem@(CTyEqCan { cc_id = cv2, cc_flavor = fl2, cc_tyvar = tv2, cc_rhs = xi2 })
+-- Check for matching LHS 
+  | fl1 `canRewrite` fl2 && tv1 == tv2 
+  = do { cans <- rewriteEqLHS (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2) 
+       ; mkIRStop KeepInert cans } 
+
+{-
+  | fl1 `canRewrite` fl2			-- If at all possible, keep the inert, 
+  , Just tv1_rhs <- tcGetTyVar_maybe xi1	-- special case of inert a~b
+  , tv1_rhs == tv2
+  = do { cans <- rewriteEqLHS (mkSymCoercion (mkCoVarCoercion cv1), mkTyVarTy tv1) 
+                              (cv2,fl2,xi2) 
+       ; mkIRStop KeepInert cans } 
+-}
+  | fl2 `canRewrite` fl1 && tv1 == tv2 
+  = do { cans <- rewriteEqLHS (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1) 
+       ; mkIRContinue workItem DropInert cans } 
+
+-- Check for rewriting RHS 
+  | fl1 `canRewrite` fl2 && tv1 `elemVarSet` tyVarsOfType xi2 
+  = do { rewritten_eq <- rewriteEqRHS (cv1,tv1,xi1) (cv2,fl2,tv2,xi2) 
+       ; mkIRStop KeepInert rewritten_eq }
+  | fl2 `canRewrite` fl1 && tv2 `elemVarSet` tyVarsOfType xi1
+  = do { rewritten_eq <- rewriteEqRHS (cv2,tv2,xi2) (cv1,fl1,tv1,xi1) 
+       ; mkIRContinue workItem DropInert rewritten_eq } 
+
+
+-- Fall-through case for all other cases
+doInteractWithInert _ workItem = noInteraction workItem
+
+--------------------------------------------
+combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc
+-- Precondition: At least one of them should be wanted 
+combineCtLoc (Wanted loc) _ = loc 
+combineCtLoc _ (Wanted loc) = loc 
+combineCtLoc _ _ = panic "Expected one of wanted constraints (BUG)" 
+
+
+-- Equational Rewriting 
+rewriteDict  :: (CoVar, TcTyVar, Xi) -> (DictId, CtFlavor, Class, [Xi]) -> TcS CanonicalCt
+rewriteDict (cv,tv,xi) (dv,gw,cl,xis) 
+  = do { let cos  = substTysWith [tv] [mkCoVarCoercion cv] xis -- xis[tv] ~ xis[xi]
+             args = substTysWith [tv] [xi] xis
+             con  = classTyCon cl 
+             dict_co = mkTyConCoercion con cos 
+       ; dv' <- newDictVar cl args 
+       ; case gw of 
+           Wanted {}         -> setDictBind dv (EvCast dv' (mkSymCoercion dict_co))
+           _given_or_derived -> setDictBind dv' (EvCast dv dict_co) 
+       ; return (CDictCan { cc_id = dv'
+                          , cc_flavor = gw 
+                          , cc_class = cl 
+                          , cc_tyargs = args }) } 
+
+rewriteIP :: (CoVar,TcTyVar,Xi) -> (EvVar,CtFlavor, IPName Name, TcType) -> TcS CanonicalCt 
+rewriteIP (cv,tv,xi) (ipid,gw,nm,ty) 
+  = do { let ip_co = substTyWith [tv] [mkCoVarCoercion cv] ty     -- ty[tv] ~ t[xi] 
+             ty'   = substTyWith [tv] [xi] ty
+       ; ipid' <- newIPVar nm ty' 
+       ; case gw of 
+           Wanted {}         -> setIPBind ipid  (EvCast ipid' (mkSymCoercion ip_co))
+           _given_or_derived -> setIPBind ipid' (EvCast ipid ip_co) 
+       ; return (CIPCan { cc_id = ipid'
+                        , cc_flavor = gw
+                        , cc_ip_nm = nm
+                        , cc_ip_ty = ty' }) }
+   
+rewriteFunEq :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TyCon, [Xi], Xi) -> TcS CanonicalCt
+rewriteFunEq (cv1,tv,xi1) (cv2,gw, tc,args,xi2) 
+  = do { let arg_cos = substTysWith [tv] [mkCoVarCoercion cv1] args 
+             args'   = substTysWith [tv] [xi1] args 
+             fun_co  = mkTyConCoercion tc arg_cos 
+       ; cv2' <- case gw of 
+                   Wanted {} -> do { cv2' <- newWantedCoVar (mkTyConApp tc args') xi2 
+                                   ; setWantedCoBind cv2 $ 
+                                     mkTransCoercion fun_co (mkCoVarCoercion cv2') 
+                                   ; return cv2' } 
+                   _giv_or_der -> newGivOrDerCoVar (mkTyConApp tc args') xi2 $
+                                  mkTransCoercion (mkSymCoercion fun_co) (mkCoVarCoercion cv2) 
+       ; return (CFunEqCan { cc_id = cv2'
+                           , cc_flavor = gw
+                           , cc_tyargs = args'
+                           , cc_fun = tc 
+                           , cc_rhs = xi2 }) }
+
+
+rewriteEqRHS :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TcTyVar,Xi) -> TcS CanonicalCts
+-- Use the first equality to rewrite the second, flavors already checked. 
+-- E.g.          c1 : tv1 ~ xi1   c2 : tv2 ~ xi2
+-- rewrites c2 to give
+--               c2' : tv2 ~ xi2[xi1/tv1]
+-- We must do an occurs check to sure the new constraint is canonical
+-- So we might return an empty bag
+rewriteEqRHS (cv1,tv1,xi1) (cv2,gw,tv2,xi2) 
+  | Just tv2' <- tcGetTyVar_maybe xi2'
+  , tv2 == tv2'	 -- In this case xi2[xi1/tv1] = tv2, so we have tv2~tv2
+  = do { when (isWanted gw) (setWantedCoBind cv2 (mkSymCoercion co2')) 
+       ; return emptyCCan } 
+  | otherwise 
+  = do { cv2' <- 
+           case gw of 
+             Wanted {} 
+                 -> do { cv2' <- newWantedCoVar (mkTyVarTy tv2) xi2' 
+                       ; setWantedCoBind cv2 $ 
+                         mkCoVarCoercion cv2' `mkTransCoercion` mkSymCoercion co2'
+                       ; return cv2' } 
+             _giv_or_der 
+                 -> newGivOrDerCoVar (mkTyVarTy tv2) xi2' $ 
+                    mkCoVarCoercion cv2 `mkTransCoercion` co2'
+
+       ; xi2'' <- canOccursCheck gw tv2 xi2' -- we know xi2' is *not* tv2 
+       ; return (singleCCan $ CTyEqCan { cc_id = cv2' 
+                                       , cc_flavor = gw 
+                                       , cc_tyvar = tv2 
+                                       , cc_rhs   = xi2'' }) 
+       }
+  where 
+    xi2' = substTyWith [tv1] [xi1] xi2 
+    co2' = substTyWith [tv1] [mkCoVarCoercion cv1] xi2  -- xi2 ~ xi2[xi1/tv1]
+
+rewriteEqLHS :: (Coercion,Xi) -> (CoVar,CtFlavor,Xi) -> TcS CanonicalCts
+-- Used to ineratct two equalities of the following form: 
+-- First Equality:   co1: (XXX ~ xi1)  
+-- Second Equality:  cv2: (XXX ~ xi2) 
+-- Where the cv1 `canRewrite` cv2 equality 
+rewriteEqLHS (co1,xi1) (cv2,gw,xi2) 
+  = do { cv2' <- if isWanted gw then 
+                     do { cv2' <- newWantedCoVar xi1 xi2 
+                        ; setWantedCoBind cv2 $ 
+                          co1 `mkTransCoercion` mkCoVarCoercion cv2'
+                        ; return cv2' } 
+                 else newGivOrDerCoVar xi1 xi2 $ 
+                      mkSymCoercion co1 `mkTransCoercion` mkCoVarCoercion cv2 
+       ; mkCanonical gw cv2' }
+
+
+solveOneFromTheOther :: (EvVar, CtFlavor) -> CanonicalCt -> TcS InteractResult 
+-- First argument inert, second argument workitem. They both represent 
+-- wanted/given/derived evidence for the *same* predicate so we try here to 
+-- discharge one directly from the other. 
+--
+-- Precondition: value evidence only (implicit parameters, classes) 
+--               not coercion
+solveOneFromTheOther (iid,ifl) workItem 
+      -- Both derived needs a special case. You might think that we do not need
+      -- two evidence terms for the same claim. But, since the evidence is partial, 
+      -- either evidence may do in some cases; see TcSMonad.isGoodRecEv.
+      -- See also Example 3 in Note [Superclasses and recursive dictionaries] 
+  | isDerived ifl && isDerived wfl 
+  = noInteraction workItem 
+
+  | wfl `canRewrite` ifl 
+  = do { unless (isGiven ifl) $ setEvBind iid (EvId wid)
+          	 -- Overwrite the binding, if one exists
+		 -- (For Givens, they are lambda-bound so nothing to overwrite,
+		 -- but we still drop the overridden one and replace it in
+		 -- the inert set with the new one
+       ; mkIRContinue workItem DropInert emptyCCan }
+       -- The order is important here: must do (wfl `canRewrite` ifl) first
+       -- so that we override the inert item with an inner given if possible.  
+       -- See Note [Overriding implicit parameters]
+
+  | otherwise   -- ifl `canRewrite` wfl
+  = do { unless (isGiven wfl) $ setEvBind wid (EvId iid) 
+       ; dischargeWorkItem }
+  where 
+     wfl = cc_flavor workItem
+     wid = cc_id workItem
+\end{code}
+
+Note [Superclasses and recursive dictionaries]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+    Overlaps with Note [SUPERCLASS-LOOP 1]
+                  Note [SUPERCLASS-LOOP 2]
+                  Note [Recursive instances and superclases]
+    ToDo: check overlap and delete redundant stuff
+
+Right before adding a given into the inert set, we must
+produce some more work, that will bring the superclasses 
+of the given into scope. The superclass constraints go into 
+our worklist. 
+
+When we simplify a wanted constraint, if we first see a matching
+instance, we may produce new wanted work. To (1) avoid doing this work 
+twice in the future and (2) to handle recursive dictionaries we may ``cache'' 
+this item as solved (in effect, given) into our inert set and with that add 
+its superclass constraints (as given) in our worklist. 
+
+But now we have added partially solved constraints to the worklist which may 
+interact with other wanteds. Consider the example: 
+
+Example 1: 
+
+    class Eq b => Foo a b        --- 0-th selector
+    instance Eq a => Foo [a] a   --- fooDFun
+
+and wanted (Foo [t] t). We are first going to see that the instance matches 
+and create an inert set that includes the solved (Foo [t] t) and its 
+superclasses. 
+       d1 :_g Foo [t] t                 d1 := EvDFunApp fooDFun d3 
+       d2 :_g Eq t                      d2 := EvSuperClass d1 0 
+Our work list is going to contain a new *wanted* goal
+       d3 :_w Eq t 
+It is wrong to react the wanted (Eq t) with the given (Eq t) because that would 
+construct loopy evidence. Hence the check isGoodRecEv in doInteractWithInert. 
+
+OK, so we have ruled out bad behaviour, but how do we ge recursive dictionaries, 
+at all? Consider
+
+Example 2:
+
+    data D r = ZeroD | SuccD (r (D r));
+    
+    instance (Eq (r (D r))) => Eq (D r) where
+        ZeroD     == ZeroD     = True
+        (SuccD a) == (SuccD b) = a == b
+        _         == _         = False;
+    
+    equalDC :: D [] -> D [] -> Bool;
+    equalDC = (==);
+
+We need to prove (Eq (D [])). Here's how we go:
+
+	d1 :_w Eq (D [])
+
+by instance decl, holds if
+	d2 :_w Eq [D []]
+	where 	d1 = dfEqD d2
+
+*BUT* we have an inert set which gives us (no superclasses): 
+        d1 :_g Eq (D []) 
+By the instance declaration of Eq we can show the 'd2' goal if 
+	d3 :_w Eq (D [])
+	where	d2 = dfEqList d3
+		d1 = dfEqD d2
+Now, however this wanted can interact with our inert d1 to set: 
+        d3 := d1 
+and solve the goal. Why was this interaction OK? Because, if we chase the 
+evidence of d1 ~~> dfEqD d2 ~~-> dfEqList d3, so by setting d3 := d1 we 
+are really setting
+        d3 := dfEqD2 (dfEqList d3) 
+which is FINE because the use of d3 is protected by the instance function 
+applications. 
+
+So, our strategy is to try to put solved wanted dictionaries into the
+inert set along with their superclasses (when this is meaningful,
+i.e. when new wanted goals are generated) but solve a wanted dictionary
+from a given only in the case where the evidence variable of the
+wanted is mentioned in the evidence of the given (recursively through
+the evidence binds) in a protected way: more instance function applications 
+than superclass selectors.
+
+Here are some more examples from GHC's previous type checker
+
+
+Example 3: 
+This code arises in the context of "Scrap Your Boilerplate with Class"
+
+    class Sat a
+    class Data ctx a
+    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1
+    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2
+
+    class Data Maybe a => Foo a    
+
+    instance Foo t => Sat (Maybe t)                             -- dfunSat
+
+    instance Data Maybe a => Foo a                              -- dfunFoo1
+    instance Foo a        => Foo [a]                            -- dfunFoo2
+    instance                 Foo [Char]                         -- dfunFoo3
+
+Consider generating the superclasses of the instance declaration
+	 instance Foo a => Foo [a]
+
+So our problem is this
+    d0 :_g Foo t
+    d1 :_w Data Maybe [t] 
+
+We may add the given in the inert set, along with its superclasses
+[assuming we don't fail because there is a matching instance, see 
+ tryTopReact, given case ]
+  Inert:
+    d0 :_g Foo t 
+  WorkList 
+    d01 :_g Data Maybe t  -- d2 := EvDictSuperClass d0 0 
+    d1 :_w Data Maybe [t] 
+Then d2 can readily enter the inert, and we also do solving of the wanted
+  Inert: 
+    d0 :_g Foo t 
+    d1 :_s Data Maybe [t]           d1 := dfunData2 d2 d3 
+  WorkList
+    d2 :_w Sat (Maybe [t])          
+    d3 :_w Data Maybe t
+    d01 :_g Data Maybe t 
+Now, we may simplify d2 more: 
+  Inert:
+      d0 :_g Foo t 
+      d1 :_s Data Maybe [t]           d1 := dfunData2 d2 d3 
+      d1 :_g Data Maybe [t] 
+      d2 :_g Sat (Maybe [t])          d2 := dfunSat d4 
+  WorkList: 
+      d3 :_w Data Maybe t 
+      d4 :_w Foo [t] 
+      d01 :_g Data Maybe t 
+
+Now, we can just solve d3.
+  Inert
+      d0 :_g Foo t 
+      d1 :_s Data Maybe [t]           d1 := dfunData2 d2 d3 
+      d2 :_g Sat (Maybe [t])          d2 := dfunSat d4 
+  WorkList
+      d4 :_w Foo [t] 
+      d01 :_g Data Maybe t 
+And now we can simplify d4 again, but since it has superclasses we *add* them to the worklist:
+  Inert
+      d0 :_g Foo t 
+      d1 :_s Data Maybe [t]           d1 := dfunData2 d2 d3 
+      d2 :_g Sat (Maybe [t])          d2 := dfunSat d4 
+      d4 :_g Foo [t]                  d4 := dfunFoo2 d5 
+  WorkList:
+      d5 :_w Foo t 
+      d6 :_g Data Maybe [t]           d6 := EvDictSuperClass d4 0
+      d01 :_g Data Maybe t 
+Now, d5 can be solved! (and its superclass enter scope) 
+  Inert
+      d0 :_g Foo t 
+      d1 :_s Data Maybe [t]           d1 := dfunData2 d2 d3 
+      d2 :_g Sat (Maybe [t])          d2 := dfunSat d4 
+      d4 :_g Foo [t]                  d4 := dfunFoo2 d5 
+      d5 :_g Foo t                    d5 := dfunFoo1 d7
+  WorkList:
+      d7 :_w Data Maybe t
+      d6 :_g Data Maybe [t]
+      d8 :_g Data Maybe t            d8 := EvDictSuperClass d5 0
+      d01 :_g Data Maybe t 
+
+Now, two problems: 
+   [1] Suppose we pick d8 and we react him with d01. Which of the two givens should 
+       we keep? Well, we *MUST NOT* drop d01 because d8 contains recursive evidence 
+       that must not be used (look at case interactInert where both inert and workitem
+       are givens). So we have several options: 
+       - Drop the workitem always (this will drop d8)
+              This feels very unsafe -- what if the work item was the "good" one
+              that should be used later to solve another wanted?
+       - Don't drop anyone: the inert set may contain multiple givens! 
+              [This is currently implemented] 
+
+The "don't drop anyone" seems the most safe thing to do, so now we come to problem 2: 
+  [2] We have added both d6 and d01 in the inert set, and we are interacting our wanted
+      d7. Now the [isRecDictEv] function in the ineration solver 
+      [case inert-given workitem-wanted] will prevent us from interacting d7 := d8 
+      precisely because chasing the evidence of d8 leads us to an unguarded use of d7. 
+
+      So, no interaction happens there. Then we meet d01 and there is no recursion 
+      problem there [isRectDictEv] gives us the OK to interact and we do solve d7 := d01! 
+             
+Note [SUPERCLASS-LOOP 1]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We have to be very, very careful when generating superclasses, lest we
+accidentally build a loop. Here's an example:
+
+  class S a
+
+  class S a => C a where { opc :: a -> a }
+  class S b => D b where { opd :: b -> b }
+  
+  instance C Int where
+     opc = opd
+  
+  instance D Int where
+     opd = opc
+
+From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int}
+Simplifying, we may well get:
+	$dfCInt = :C ds1 (opd dd)
+	dd  = $dfDInt
+	ds1 = $p1 dd
+Notice that we spot that we can extract ds1 from dd.  
+
+Alas!  Alack! We can do the same for (instance D Int):
+
+	$dfDInt = :D ds2 (opc dc)
+	dc  = $dfCInt
+	ds2 = $p1 dc
+
+And now we've defined the superclass in terms of itself.
+Two more nasty cases are in
+	tcrun021
+	tcrun033
+
+Solution: 
+  - Satisfy the superclass context *all by itself* 
+    (tcSimplifySuperClasses)
+  - And do so completely; i.e. no left-over constraints
+    to mix with the constraints arising from method declarations
+
+
+Note [SUPERCLASS-LOOP 2]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We need to be careful when adding "the constaint we are trying to prove".
+Suppose we are *given* d1:Ord a, and want to deduce (d2:C [a]) where
+
+	class Ord a => C a where
+	instance Ord [a] => C [a] where ...
+
+Then we'll use the instance decl to deduce C [a] from Ord [a], and then add the
+superclasses of C [a] to avails.  But we must not overwrite the binding
+for Ord [a] (which is obtained from Ord a) with a superclass selection or we'll just
+build a loop! 
+
+Here's another variant, immortalised in tcrun020
+	class Monad m => C1 m
+	class C1 m => C2 m x
+	instance C2 Maybe Bool
+For the instance decl we need to build (C1 Maybe), and it's no good if
+we run around and add (C2 Maybe Bool) and its superclasses to the avails 
+before we search for C1 Maybe.
+
+Here's another example 
+ 	class Eq b => Foo a b
+	instance Eq a => Foo [a] a
+If we are reducing
+	(Foo [t] t)
+
+we'll first deduce that it holds (via the instance decl).  We must not
+then overwrite the Eq t constraint with a superclass selection!
+
+At first I had a gross hack, whereby I simply did not add superclass constraints
+in addWanted, though I did for addGiven and addIrred.  This was sub-optimal,
+becuase it lost legitimate superclass sharing, and it still didn't do the job:
+I found a very obscure program (now tcrun021) in which improvement meant the
+simplifier got two bites a the cherry... so something seemed to be an Stop
+first time, but reducible next time.
+
+Now we implement the Right Solution, which is to check for loops directly 
+when adding superclasses.  It's a bit like the occurs check in unification.
+
+Note [Recursive instances and superclases]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this code, which arises in the context of "Scrap Your 
+Boilerplate with Class".  
+
+    class Sat a
+    class Data ctx a
+    instance  Sat (ctx Char)             => Data ctx Char
+    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]
+
+    class Data Maybe a => Foo a
+
+    instance Foo t => Sat (Maybe t)
+
+    instance Data Maybe a => Foo a
+    instance Foo a        => Foo [a]
+    instance                 Foo [Char]
+
+In the instance for Foo [a], when generating evidence for the superclasses
+(ie in tcSimplifySuperClasses) we need a superclass (Data Maybe [a]).
+Using the instance for Data, we therefore need
+        (Sat (Maybe [a], Data Maybe a)
+But we are given (Foo a), and hence its superclass (Data Maybe a).
+So that leaves (Sat (Maybe [a])).  Using the instance for Sat means
+we need (Foo [a]).  And that is the very dictionary we are bulding
+an instance for!  So we must put that in the "givens".  So in this
+case we have
+	Given:  Foo a, Foo [a]
+	Wanted: Data Maybe [a]
+
+BUT we must *not not not* put the *superclasses* of (Foo [a]) in
+the givens, which is what 'addGiven' would normally do. Why? Because
+(Data Maybe [a]) is the superclass, so we'd "satisfy" the wanted 
+by selecting a superclass from Foo [a], which simply makes a loop.
+
+On the other hand we *must* put the superclasses of (Foo a) in
+the givens, as you can see from the derivation described above.
+
+Conclusion: in the very special case of tcSimplifySuperClasses
+we have one 'given' (namely the "this" dictionary) whose superclasses
+must not be added to 'givens' by addGiven.  
+
+There is a complication though.  Suppose there are equalities
+      instance (Eq a, a~b) => Num (a,b)
+Then we normalise the 'givens' wrt the equalities, so the original
+given "this" dictionary is cast to one of a different type.  So it's a
+bit trickier than before to identify the "special" dictionary whose
+superclasses must not be added. See test
+   indexed-types/should_run/EqInInstance
+
+We need a persistent property of the dictionary to record this
+special-ness.  Current I'm using the InstLocOrigin (a bit of a hack,
+but cool), which is maintained by dictionary normalisation.
+Specifically, the InstLocOrigin is
+	     NoScOrigin
+then the no-superclass thing kicks in.  WATCH OUT if you fiddle
+with InstLocOrigin!
+
+Note [MATCHING-SYNONYMS]
+~~~~~~~~~~~~~~~~~~~~~~~~
+When trying to match a dictionary (D tau) to a top-level instance, or a 
+type family equation (F taus_1 ~ tau_2) to a top-level family instance, 
+we do *not* need to expand type synonyms because the matcher will do that for us.
+
+
+Note [RHS-FAMILY-SYNONYMS] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+The RHS of a family instance is represented as yet another constructor which is 
+like a type synonym for the real RHS the programmer declared. Eg: 
+    type instance F (a,a) = [a] 
+Becomes: 
+    :R32 a = [a]      -- internal type synonym introduced
+    F (a,a) ~ :R32 a  -- instance 
+
+When we react a family instance with a type family equation in the work list 
+we keep the synonym-using RHS without expansion. 
+
+
+*********************************************************************************
+*                                                                               * 
+                       The top-reaction Stage
+*                                                                               *
+*********************************************************************************
+
+\begin{code}
+-- If a work item has any form of interaction with top-level we get this 
+data TopInteractResult 
+  = NoTopInt 	           -- No top-level interaction
+  | SomeTopInt 
+      { tir_new_work  :: WorkList	-- Sub-goals or new work (could be given, 
+                                        --                        for superclasses)
+      , tir_new_inert :: StopOrContinue -- The input work item, ready to become *inert* now: 
+      }                       		-- NB: in ``given'' (solved) form if the 
+                              		-- original was wanted or given and instance match
+                              		-- was found, but may also be in wanted form if we 
+                                        -- only reacted with functional dependencies 
+					-- arising from top-level instances.
+
+topReactionsStage :: SimplifierStage 
+topReactionsStage workItem inerts 
+  = do { tir <- tryTopReact workItem 
+       ; case tir of 
+           NoTopInt -> 
+               return $ SR { sr_inerts   = inerts 
+                           , sr_new_work = emptyWorkList 
+                           , sr_stop     = ContinueWith workItem } 
+           SomeTopInt tir_new_work tir_new_inert -> 
+               return $ SR { sr_inerts   = inerts 
+                           , sr_new_work = tir_new_work
+                           , sr_stop     = tir_new_inert
+                           }
+       }
+
+tryTopReact :: WorkItem -> TcS TopInteractResult 
+tryTopReact workitem 
+  = do {  -- A flag controls the amount of interaction allowed
+          -- See Note [Simplifying RULE lhs constraints]
+         ctxt <- getTcSContext
+       ; if allowedTopReaction (simplEqsOnly ctxt) workitem 
+         then do { traceTcS "tryTopReact / calling doTopReact" (ppr workitem)
+                 ; doTopReact workitem }
+         else return NoTopInt 
+       } 
+
+allowedTopReaction :: Bool -> WorkItem -> Bool 
+allowedTopReaction eqs_only (CDictCan {}) = not eqs_only
+allowedTopReaction _        _             = True 
+
+
+doTopReact :: WorkItem -> TcS TopInteractResult 
+-- The work item does not react with the inert set, 
+-- so try interaction with top-level instances
+doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = Wanted loc
+                              , cc_class = cls, cc_tyargs = xis }) 
+  = do { -- See Note [MATCHING-SYNONYMS]
+       ; lkp_inst_res <- matchClassInst cls xis loc
+       ; case lkp_inst_res of 
+           NoInstance -> do { traceTcS "doTopReact/ no class instance for" (ppr dv) 
+                            ; funDepReact }
+           GenInst wtvs ev_term ->  -- Solved 
+	   	   -- No need to do fundeps stuff here; the instance 
+		   -- matches already so we won't get any more info
+		   -- from functional dependencies
+               do { traceTcS "doTopReact/ found class instance for" (ppr dv) 
+                  ; setDictBind dv ev_term 
+                  ; workList <- canWanteds wtvs
+                  ; if null wtvs
+                    -- Solved in one step and no new wanted work produced. 
+                    -- i.e we directly matched a top-level instance
+		    -- No point in caching this in 'inert', nor in adding superclasses
+                    then return $ SomeTopInt { tir_new_work  = emptyCCan 
+                                             , tir_new_inert = Stop }
+
+                    -- Solved and new wanted work produced, you may cache the 
+		    -- (tentatively solved) dictionary as Derived and its superclasses
+                    else do { let solved = makeSolved workItem
+                            ; sc_work <- newSCWorkFromFlavored dv (Derived loc) cls xis 
+                            ; return $ SomeTopInt 
+                                  { tir_new_work = workList `unionWorkLists` sc_work 
+                                  , tir_new_inert = ContinueWith solved } }
+                  }
+       }
+  where 
+    -- Try for a fundep reaction beween the wanted item 
+    -- and a top-level instance declaration
+    funDepReact 
+      = do { instEnvs <- getInstEnvs
+           ; let eqn_pred_locs = improveFromInstEnv (classInstances instEnvs)
+                                                    (ClassP cls xis, ppr dv)
+           ; wevvars <- mkWantedFunDepEqns loc eqn_pred_locs 
+	     	      -- NB: fundeps generate some wanted equalities, but 
+	   	      --     we don't use their evidence for anything
+           ; fd_work <- canWanteds wevvars 
+           ; sc_work <- newSCWorkFromFlavored dv (Derived loc) cls xis
+           ; return $ SomeTopInt { tir_new_work = fd_work `unionWorkLists` sc_work
+                                 , tir_new_inert = ContinueWith workItem }
+           -- NB: workItem is inert, but it isn't solved
+	   -- keep it as inert, although it's not solved because we
+           -- have now reacted all its top-level fundep-induced equalities!
+                    
+           -- See Note [FunDep Reactions]
+           }
+
+-- Otherwise, we have a given or derived 
+doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl
+                              , cc_class = cls, cc_tyargs = xis }) 
+  = do { sc_work <- newSCWorkFromFlavored dv fl cls xis 
+       ; return $ SomeTopInt sc_work (ContinueWith workItem) }
+    -- See Note [Given constraint that matches an instance declaration]
+
+-- Type functions
+doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl
+                      , cc_fun = tc, cc_tyargs = args, cc_rhs = xi })
+  = ASSERT (isSynFamilyTyCon tc)   -- No associated data families have reached that far 
+    do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS]
+       ; case match_res of 
+           MatchInstNo 
+             -> return NoTopInt 
+           MatchInstSingle (rep_tc, rep_tys)
+             -> do { let Just coe_tc = tyConFamilyCoercion_maybe rep_tc
+                         Just rhs_ty = tcView (mkTyConApp rep_tc rep_tys)
+			    -- Eagerly expand away the type synonym on the
+			    -- RHS of a type function, so that it never
+			    -- appears in an error message
+                            -- See Note [Type synonym families] in TyCon
+                         coe = mkTyConApp coe_tc rep_tys 
+                   ; cv' <- case fl of
+                              Wanted {} -> do { cv' <- newWantedCoVar rhs_ty xi
+                                              ; setWantedCoBind cv $ 
+                                                    coe `mkTransCoercion`
+                                                      mkCoVarCoercion cv'
+                                              ; return cv' }
+                              _ -> newGivOrDerCoVar xi rhs_ty $ 
+                                   mkSymCoercion (mkCoVarCoercion cv) `mkTransCoercion` coe 
+
+                   ; workList <- mkCanonical fl cv'
+                   ; return $ SomeTopInt workList Stop }
+           _ 
+             -> panicTcS $ text "TcSMonad.matchFam returned multiple instances!"
+       }
+
+
+-- Any other work item does not react with any top-level equations
+doTopReact _workItem = return NoTopInt 
+\end{code}
+
+Note [FunDep and implicit parameter reactions] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Currently, our story of interacting two dictionaries (or a dictionary
+and top-level instances) for functional dependencies, and implicit
+paramters, is that we simply produce new wanted equalities.  So for example
+
+        class D a b | a -> b where ... 
+    Inert: 
+        d1 :g D Int Bool
+    WorkItem: 
+        d2 :w D Int alpha
+
+    We generate the extra work item
+        cv :w alpha ~ Bool
+    where 'cv' is currently unused.  However, this new item reacts with d2,
+    discharging it in favour of a new constraint d2' thus:
+        d2' :w D Int Bool
+	d2 := d2' |> D Int cv
+    Now d2' can be discharged from d1
+
+We could be more aggressive and try to *immediately* solve the dictionary 
+using those extra equalities. With the same inert set and work item we
+might dischard d2 directly:
+
+        cv :w alpha ~ Bool
+        d2 := d1 |> D Int cv
+
+But in general it's a bit painful to figure out the necessary coercion,
+so we just take the first approach.
+
+It's exactly the same with implicit parameters, except that the
+"aggressive" approach would be much easier to implement.
+
+Note [When improvement happens]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We fire an improvement rule when
+
+  * Two constraints match (modulo the fundep)
+      e.g. C t1 t2, C t1 t3    where C a b | a->b
+    The two match because the first arg is identical
+
+  * At least one is not Given.  If they are both given, we don't fire
+    the reaction because we have no way of constructing evidence for a
+    new equality nor does it seem right to create a new wanted goal
+    (because the goal will most likely contain untouchables, which
+    can't be solved anyway)!
+   
+Note that we *do* fire the improvement if one is Given and one is Derived.
+The latter can be a superclass of a wanted goal. Example (tcfail138)
+    class L a b | a -> b
+    class (G a, L a b) => C a b
+
+    instance C a b' => G (Maybe a)
+    instance C a b  => C (Maybe a) a
+    instance L (Maybe a) a
+
+When solving the superclasses of the (C (Maybe a) a) instance, we get
+  Given:  C a b  ... and hance by superclasses, (G a, L a b)
+  Wanted: G (Maybe a)
+Use the instance decl to get
+  Wanted: C a b'
+The (C a b') is inert, so we generate its Derived superclasses (L a b'),
+and now we need improvement between that derived superclass an the Given (L a b)
+
+Note [Overriding implicit parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+   f :: (?x::a) -> Bool -> a
+  
+   g v = let ?x::Int = 3 
+         in (f v, let ?x::Bool = True in f v)
+
+This should probably be well typed, with
+   g :: Bool -> (Int, Bool)
+
+So the inner binding for ?x::Bool *overrides* the outer one.
+Hence a work-item Given overrides an inert-item Given.
+
+Note [Given constraint that matches an instance declaration]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+What should we do when we discover that one (or more) top-level 
+instances match a given (or solved) class constraint? We have 
+two possibilities:
+
+  1. Reject the program. The reason is that there may not be a unique
+     best strategy for the solver. Example, from the OutsideIn(X) paper:
+       instance P x => Q [x] 
+       instance (x ~ y) => R [x] y 
+     
+       wob :: forall a b. (Q [b], R b a) => a -> Int 
+
+       g :: forall a. Q [a] => [a] -> Int 
+       g x = wob x 
+
+       will generate the impliation constraint: 
+            Q [a] => (Q [beta], R beta [a]) 
+       If we react (Q [beta]) with its top-level axiom, we end up with a 
+       (P beta), which we have no way of discharging. On the other hand, 
+       if we react R beta [a] with the top-level we get  (beta ~ a), which 
+       is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is 
+       now solvable by the given Q [a]. 
+ 
+     However, this option is restrictive, for instance [Example 3] from 
+     Note [Recursive dictionaries] will fail to work. 
+
+  2. Ignore the problem, hoping that the situations where there exist indeed
+     such multiple strategies are rare: Indeed the cause of the previous 
+     problem is that (R [x] y) yields the new work (x ~ y) which can be 
+     *spontaneously* solved, not using the givens. 
+
+We are choosing option 2 below but we might consider having a flag as well.
+
+
+Note [New Wanted Superclass Work] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Even in the case of wanted constraints, we add all of its superclasses as 
+new given work. There are several reasons for this: 
+     a) to minimise error messages; 
+        eg suppose we have wanted (Eq a, Ord a)
+	     then we report only (Ord a) unsoluble
+
+     b) to make the smallest number of constraints when *inferring* a type
+        (same Eq/Ord example)
+
+     c) for recursive dictionaries we *must* add the superclasses
+        so that we can use them when solving a sub-problem
+
+     d) To allow FD-like improvement for type families. Assume that 
+        we have a class 
+             class C a b | a -> b 
+        and we have to solve the implication constraint: 
+             C a b => C a beta 
+        Then, FD improvement can help us to produce a new wanted (beta ~ b) 
+
+        We want to have the same effect with the type family encoding of 
+        functional dependencies. Namely, consider: 
+             class (F a ~ b) => C a b 
+        Now suppose that we have: 
+               given: C a b 
+               wanted: C a beta 
+        By interacting the given we will get that (F a ~ b) which is not 
+        enough by itself to make us discharge (C a beta). However, we 
+        may create a new given equality from the super-class that we promise
+        to solve: (F a ~ beta). Now we may interact this with the rest of 
+        constraint to finally get: 
+                  given :  beta ~ b 
+        
+        But 'beta' is a touchable unification variable, and hence OK to 
+        unify it with 'b', replacing the given evidence with the identity. 
+
+        This requires trySpontaneousSolve to solve given equalities that
+        have a touchable in their RHS, *in addition* to solving wanted 
+        equalities. 
+
+Here is another example where this is useful. 
+
+Example 1:
+----------
+   class (F a ~ b) => C a b 
+And we are given the wanteds:
+      w1 : C a b 
+      w2 : C a c 
+      w3 : b ~ c 
+We surely do *not* want to quantify over (b ~ c), since if someone provides
+dictionaries for (C a b) and (C a c), these dictionaries can provide a proof 
+of (b ~ c), hence no extra evidence is necessary. Here is what will happen: 
+
+     Step 1: We will get new *given* superclass work, 
+             provisionally to our solving of w1 and w2
+             
+               g1: F a ~ b, g2 : F a ~ c, 
+               w1 : C a b, w2 : C a c, w3 : b ~ c
+
+             The evidence for g1 and g2 is a superclass evidence term: 
+
+               g1 := sc w1, g2 := sc w2
+
+     Step 2: The givens will solve the wanted w3, so that 
+               w3 := sym (sc w1) ; sc w2 
+                  
+     Step 3: Now, one may naively assume that then w2 can be solve from w1
+             after rewriting with the (now solved equality) (b ~ c). 
+             
+             But this rewriting is ruled out by the isGoodRectDict! 
+
+Conclusion, we will (correctly) end up with the unsolved goals 
+    (C a b, C a c)   
+
+NB: The desugarer needs be more clever to deal with equalities 
+    that participate in recursive dictionary bindings. 
+
+\begin{code}
+newSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi]
+                      -> TcS WorkList
+newSCWorkFromFlavored ev flavor cls xis
+  | Given loc <- flavor	 	-- The NoScSkol says "don't add superclasses"
+  , NoScSkol <- ctLocOrigin loc
+  = pprTrace "Oh dear! Superclasses of self" (pprEvVarWithType ev) $
+    return emptyWorkList
+    
+  | otherwise
+  = do { let (tyvars, sc_theta, _, _) = classBigSig cls 
+             sc_theta1 = substTheta (zipTopTvSubst tyvars xis) sc_theta
+             -- Add *all* its superclasses (equalities or not) as new given work 
+             -- See Note [New Wanted Superclass Work] 
+       ; sc_vars <- zipWithM inst_one sc_theta1 [0..]
+       ; mkCanonicals flavor sc_vars } 
+  where
+    inst_one pred n = newGivOrDerEvVar pred (EvSuperClass ev n)
+
+data LookupInstResult
+  = NoInstance
+  | GenInst [WantedEvVar] EvTerm 
+
+matchClassInst :: Class -> [Type] -> WantedLoc -> TcS LookupInstResult
+matchClassInst clas tys loc
+   = do { let pred = mkClassPred clas tys 
+        ; mb_result <- matchClass clas tys
+        ; case mb_result of
+            MatchInstNo   -> return NoInstance
+            MatchInstMany -> return NoInstance -- defer any reactions of a multitude until 
+                                               -- we learn more about the reagent 
+            MatchInstSingle (dfun_id, mb_inst_tys) -> 
+              do { checkWellStagedDFun pred dfun_id loc
+
+ 	-- It's possible that not all the tyvars are in
+	-- the substitution, tenv. For example:
+	--	instance C X a => D X where ...
+	-- (presumably there's a functional dependency in class C)
+	-- Hence mb_inst_tys :: Either TyVar TcType 
+
+                 ; tys <- instDFunTypes mb_inst_tys 
+                 ; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
+                 ; if null theta then
+                       return (GenInst [] (EvDFunApp dfun_id tys [])) 
+                   else do
+                     { ev_vars <- instDFunConstraints theta
+                     ; let wevs = [WantedEvVar w loc | w <- ev_vars]
+                     ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) }
+                 }
+        }
+\end{code}
+
+
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 4d6ced3..8a81b48 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -18,42 +18,46 @@ module TcMType (
   newFlexiTyVarTy,		-- Kind -> TcM TcType
   newFlexiTyVarTys,		-- Int -> Kind -> TcM [TcType]
   newKindVar, newKindVars, 
-  lookupTcTyVar, LookupTyVarResult(..),
 
-  newMetaTyVar, readMetaTyVar, writeMetaTyVar, isFilledMetaTyVar,
+  newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
+  isFilledMetaTyVar, isFlexiMetaTyVar,
 
   --------------------------------
-  -- Boxy type variables
-  newBoxyTyVar, newBoxyTyVars, newBoxyTyVarTys, readFilledBox, 
+  -- Creating new evidence variables
+  newEvVar, newCoVar, newEvVars,
+  newWantedCoVar, writeWantedCoVar, readWantedCoVar, 
+  newIP, newDict, newSelfDict, isSelfDict,
 
-  --------------------------------
-  -- Creating new coercion variables
-  newCoVars, newMetaCoVar,
+  newWantedEvVar, newWantedEvVars, 
+  newKindConstraint,
+  newTcEvBinds, addTcEvBind,
 
   --------------------------------
   -- Instantiation
-  tcInstTyVar, tcInstType, tcInstTyVars, tcInstBoxyTyVar,
+  tcInstTyVar, tcInstTyVars, tcInstSigTyVars,
   tcInstType, tcInstSigType,
-  tcInstSkolTyVars, tcInstSkolType, 
-  tcSkolSigType, tcSkolSigTyVars, occurCheckErr, execTcTyVarBinds,
+  tcInstSkolTyVars, tcInstSkolTyVar, tcInstSkolType, 
+  tcSkolSigType, tcSkolSigTyVars, 
 
   --------------------------------
   -- Checking type validity
   Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,
   SourceTyCtxt(..), checkValidTheta, 
   checkValidInstHead, checkValidInstance, 
-  checkInstTermination, checkValidTypeInst, checkTyFamFreeness, checkKinds,
-  checkUpdateMeta, updateMeta, checkTauTvUpdate, fillBoxWithTau, unifyKindCtxt,
-  unifyKindMisMatch, validDerivPred, arityErr, notMonoType, notMonoArgs,
-  growPredTyVars, growTyVars, growThetaTyVars,
+  checkInstTermination, checkValidTypeInst, checkTyFamFreeness, 
+  arityErr, 
+  growPredTyVars, growThetaTyVars, validDerivPred,
 
   --------------------------------
   -- Zonking
-  zonkType, zonkTcPredType, 
+  zonkType, mkZonkTcTyVar, zonkTcPredType, 
+  zonkTcTypeCarefully,
   zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar,
   zonkQuantifiedTyVar, zonkQuantifiedTyVars,
   zonkTcType, zonkTcTypes, zonkTcThetaType,
-  zonkTcKindToKind, zonkTcKind, zonkTopTyVar,
+  zonkTcKindToKind, zonkTcKind, 
+  zonkImplication, zonkWanted, zonkEvVar, zonkWantedEvVar,
+  tcGetGlobalTyVars, 
 
   readKindVar, writeKindVar
   ) where
@@ -72,20 +76,20 @@ import Var
 -- others:
 import HsSyn		-- HsType
 import TcRnMonad        -- TcType, amongst others
+import Id
 import FunDeps
 import Name
-import VarEnv
 import VarSet
 import ErrUtils
 import DynFlags
 import Util
-import Bag
 import Maybes
 import ListSetOps
-import UniqSupply
+import BasicTypes
 import SrcLoc
 import Outputable
 import FastString
+import Bag
 
 import Control.Monad
 import Data.List	( (\\) )
@@ -94,359 +98,145 @@ import Data.List	( (\\) )
 
 %************************************************************************
 %*									*
-	Instantiation in general
+	Kind variables
 %*									*
 %************************************************************************
 
 \begin{code}
-tcInstType :: ([TyVar] -> TcM [TcTyVar]) 		-- How to instantiate the type variables
-	   -> TcType 					-- Type to instantiate
-	   -> TcM ([TcTyVar], TcThetaType, TcType)	-- Result
-		-- (type vars (excl coercion vars), preds (incl equalities), rho)
-tcInstType inst_tyvars ty
-  = case tcSplitForAllTys ty of
-	([],     rho) -> let	-- There may be overloading despite no type variables;
-				-- 	(?x :: Int) => Int -> Int
-			   (theta, tau) = tcSplitPhiTy rho
-			 in
-			 return ([], theta, tau)
-
-	(tyvars, rho) -> do { tyvars' <- inst_tyvars tyvars
-
-			    ; let  tenv = zipTopTvSubst tyvars (mkTyVarTys tyvars')
-				-- Either the tyvars are freshly made, by inst_tyvars,
-				-- or (in the call from tcSkolSigType) any nested foralls
-				-- have different binders.  Either way, zipTopTvSubst is ok
+newKindVar :: TcM TcKind
+newKindVar = do	{ uniq <- newUnique
+		; ref <- newMutVar Flexi
+		; return (mkTyVarTy (mkKindVar uniq ref)) }
 
-			    ; let  (theta, tau) = tcSplitPhiTy (substTy tenv rho)
-			    ; return (tyvars', theta, tau) }
+newKindVars :: Int -> TcM [TcKind]
+newKindVars n = mapM (\ _ -> newKindVar) (nOfThem n ())
 \end{code}
 
 
 %************************************************************************
 %*									*
-	Updating tau types
+     Evidence variables; range over constraints we can abstract over
 %*									*
 %************************************************************************
 
-Can't be in TcUnify, as we also need it in TcTyFuns.
-
 \begin{code}
-type SwapFlag = Bool
-	-- False <=> the two args are (actual, expected) respectively
-	-- True  <=> the two args are (expected, actual) respectively
-
-checkUpdateMeta :: SwapFlag
-	        -> TcTyVar -> IORef MetaDetails -> TcType -> TcM ()
--- Update tv1, which is flexi; occurs check is alrady done
--- The 'check' version does a kind check too
--- We do a sub-kind check here: we might unify (a b) with (c d) 
---	where b::*->* and d::*; this should fail
-
-checkUpdateMeta swapped tv1 ref1 ty2
-  = do	{ checkKinds swapped tv1 ty2
-	; updateMeta tv1 ref1 ty2 }
-
-updateMeta :: TcTyVar -> IORef MetaDetails -> TcType -> TcM ()
-updateMeta tv1 ref1 ty2
-  = ASSERT( isMetaTyVar tv1 )
-    ASSERT( isBoxyTyVar tv1 || isTauTy ty2 )
-    do	{ ASSERTM2( do { details <- readMetaTyVar tv1; return (isFlexi details) }, ppr tv1 )
-	; traceTc (text "updateMeta" <+> ppr tv1 <+> text ":=" <+> ppr ty2)
-	; writeMutVar ref1 (Indirect ty2) 
-	}
-
-----------------
-checkKinds :: Bool -> TyVar -> Type -> TcM ()
-checkKinds swapped tv1 ty2
--- We're about to unify a type variable tv1 with a non-tyvar-type ty2.
--- ty2 has been zonked at this stage, which ensures that
--- its kind has as much boxity information visible as possible.
-  | tk2 `isSubKind` tk1 = return ()
-
-  | otherwise
-	-- Either the kinds aren't compatible
-	--	(can happen if we unify (a b) with (c d))
-	-- or we are unifying a lifted type variable with an
-	-- 	unlifted type: e.g.  (id 3#) is illegal
-  = addErrCtxtM (unifyKindCtxt swapped tv1 ty2)	$
-    unifyKindMisMatch k1 k2
-  where
-    (k1,k2) | swapped   = (tk2,tk1)
-	    | otherwise = (tk1,tk2)
-    tk1 = tyVarKind tv1
-    tk2 = typeKind ty2
-
-----------------
-checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType)
---    (checkTauTvUpdate tv ty)
--- We are about to update the TauTv tv with ty.
--- Check (a) that tv doesn't occur in ty (occurs check)
---       (b) that ty is a monotype
--- Furthermore, in the interest of (b), if you find an
--- empty box (BoxTv that is Flexi), fill it in with a TauTv
--- 
--- We have three possible outcomes:
--- (1) Return the (non-boxy) type to update the type variable with, 
---     [we know the update is ok!]
--- (2) return Nothing, or 
---     [we cannot tell whether the update is ok right now]
--- (3) fails.
---     [the update is definitely invalid]
--- We return Nothing in case the tv occurs in ty *under* a type family
--- application.  In this case, we must not update tv (to avoid a cyclic type
--- term), but we also cannot fail claiming an infinite type.  Given
---   type family F a
---   type instance F Int = Int
--- consider
---   a ~ F a
--- This is perfectly reasonable, if we later get a ~ Int.
-
-checkTauTvUpdate orig_tv orig_ty
-  = do { result <- go orig_ty
-       ; case result of 
-           Right ty    -> return $ Just ty
-           Left  True  -> return $ Nothing
-           Left  False -> occurCheckErr (mkTyVarTy orig_tv) orig_ty
-       }
-  where
-    go :: TcType -> TcM (Either Bool TcType)
-    -- go returns
-    --   Right ty    if everything is fine
-    --   Left True   if orig_tv occurs in orig_ty, but under a type family app
-    --   Left False  if orig_tv occurs in orig_ty (with no type family app)
-    -- It fails if it encounters a forall type, except as an argument for a
-    -- closed type synonym that expands to a tau type.
-    go (TyConApp tc tys)
-	| isSynTyCon tc  = go_syn tc tys
-	| otherwise	 = do { tys' <- mapM go tys
-                              ; return $ occurs (TyConApp tc) tys' }
-    go (PredTy p)	      = do { p' <- go_pred p
-                              ; return $ occurs1 PredTy p' }
-    go (FunTy arg res)   = do { arg' <- go arg
-                              ; res' <- go res
-                              ; return $ occurs2 FunTy arg' res' }
-    go (AppTy fun arg)	 = do { fun' <- go fun
-                              ; arg' <- go arg
-                              ; return $ occurs2 mkAppTy fun' arg' }
-		-- NB the mkAppTy; we might have instantiated a
-		-- type variable to a type constructor, so we need
-		-- to pull the TyConApp to the top.
-    go (ForAllTy _ _) = notMonoType orig_ty		-- (b)
-
-    go (TyVarTy tv)
-	| orig_tv == tv = return $ Left False           -- (a)
-	| isTcTyVar tv  = go_tyvar tv (tcTyVarDetails tv)
-	| otherwise     = return $ Right (TyVarTy tv)
-		 -- Ordinary (non Tc) tyvars
-		 -- occur inside quantified types
-
-    go_pred (ClassP c tys) = do { tys' <- mapM go tys
-                                ; return $ occurs (ClassP c) tys' }
-    go_pred (IParam n ty)  = do { ty' <- go ty
-                                ; return $ occurs1 (IParam n) ty' }
-    go_pred (EqPred t1 t2) = do { t1' <- go t1
-                                ; t2' <- go t2
-                                ; return $ occurs2 EqPred t1' t2' }
-
-    go_tyvar tv (SkolemTv _) = return $ Right (TyVarTy tv)
-    go_tyvar tv (MetaTv box ref)
-	= do { cts <- readMutVar ref
-	     ; case cts of
-		  Indirect ty -> go ty 
-		  Flexi -> case box of
-				BoxTv -> do { ty <- fillBoxWithTau tv ref
-                                            ; return $ Right ty }
-				_     -> return $ Right (TyVarTy tv)
-	     }
-
-	-- go_syn is called for synonyms only
-	-- See Note [Type synonyms and the occur check]
-    go_syn tc tys
-	| not (isTauTyCon tc)
-	= notMonoType orig_ty	-- (b) again
-	| otherwise
-	= do { (_msgs, mb_tys') <- tryTc (mapM go tys)
-	     ; case mb_tys' of
-
-                -- we had a type error => forall in type parameters
-		Nothing 
-                  | isOpenTyCon tc -> notMonoArgs (TyConApp tc tys)
-		        -- Synonym families must have monotype args
-		  | otherwise      -> go (expectJust "checkTauTvUpdate(1)" 
-					    (tcView (TyConApp tc tys)))
-		        -- Try again, expanding the synonym
-
-                -- no type error, but need to test whether occurs check happend
-		Just tys' -> 
-                  case occurs id tys' of
-                    Left _ 
-                      | isOpenTyCon tc -> return $ Left True
-                        -- Variable occured under type family application
-                      | otherwise      -> go (expectJust "checkTauTvUpdate(2)" 
-					       (tcView (TyConApp tc tys)))
-		        -- Try again, expanding the synonym
-                    Right raw_tys'     -> return $ Right (TyConApp tc raw_tys')
-		        -- Retain the synonym (the common case)
-	     }
-
-    -- Left results (= occurrence of orig_ty) dominate and
-    -- (Left False) (= fatal occurrence) dominates over (Left True)
-    occurs :: ([a] -> b) -> [Either Bool a] -> Either Bool b
-    occurs c = either Left (Right . c) . foldr combine (Right [])
-      where
-        combine (Left famInst1) (Left famInst2) = Left (famInst1 && famInst2)
-        combine (Right _      ) (Left famInst)  = Left famInst
-        combine (Left famInst)  (Right _)       = Left famInst
-        combine (Right arg)     (Right args)    = Right (arg:args)
-
-    occurs1 c x   = occurs (\[x']     -> c x')    [x]
-    occurs2 c x y = occurs (\[x', y'] -> c x' y') [x, y]
-
-fillBoxWithTau :: BoxyTyVar -> IORef MetaDetails -> TcM TcType
--- (fillBoxWithTau tv ref) fills ref with a freshly allocated 
---  tau-type meta-variable, whose print-name is the same as tv
--- Choosing the same name is good: when we instantiate a function
--- we allocate boxy tyvars with the same print-name as the quantified
--- tyvar; and then we often fill the box with a tau-tyvar, and again
--- we want to choose the same name.
-fillBoxWithTau tv ref 
-  = do	{ tv' <- tcInstTyVar tv		-- Do not gratuitously forget
-	; let tau = mkTyVarTy tv'	-- name of the type variable
-	; writeMutVar ref (Indirect tau)
-	; return tau }
-\end{code}
-
-Note [Type synonyms and the occur check]
-~~~~~~~~~~~~~~~~~~~~
-Basically we want to update     tv1 := ps_ty2
-because ps_ty2 has type-synonym info, which improves later error messages
-
-But consider 
-	type A a = ()
-
-	f :: (A a -> a -> ()) -> ()
-	f = \ _ -> ()
-
-	x :: ()
-	x = f (\ x p -> p x)
-
-In the application (p x), we try to match "t" with "A t".  If we go
-ahead and bind t to A t (= ps_ty2), we'll lead the type checker into 
-an infinite loop later.
-But we should not reject the program, because A t = ().
-Rather, we should bind t to () (= non_var_ty2).
+newEvVars :: TcThetaType -> TcM [EvVar]
+newEvVars theta = mapM newEvVar theta
+
+newWantedEvVar :: TcPredType -> TcM EvVar 
+newWantedEvVar (EqPred ty1 ty2) = newWantedCoVar ty1 ty2
+newWantedEvVar (ClassP cls tys) = newDict cls tys
+newWantedEvVar (IParam ip ty)   = newIP ip ty
+
+newWantedEvVars :: TcThetaType -> TcM [EvVar] 
+newWantedEvVars theta = mapM newWantedEvVar theta 
+
+newWantedCoVar :: TcType -> TcType -> TcM CoVar 
+newWantedCoVar ty1 ty2 = newCoVar ty1 ty2
+
+-- We used to create a mutable co-var
+{-
+-- A wanted coercion variable is a MetaTyVar
+-- that can be filled in with its binding
+  = do { uniq <- newUnique 
+       ; ref <- newMutVar Flexi 
+       ; let name = mkSysTvName uniq (fsLit "c")
+             kind = mkPredTy (EqPred ty1 ty2) 
+       ; return (mkTcTyVar name kind (MetaTv TauTv ref)) }
+-}
 
 --------------
+newEvVar :: TcPredType -> TcM EvVar
+-- Creates new *rigid* variables for predicates
+newEvVar (EqPred ty1 ty2) = newCoVar ty1 ty2
+newEvVar (ClassP cls tys) = newDict  cls tys
+newEvVar (IParam ip ty)   = newIP    ip ty
+
+newCoVar :: TcType -> TcType -> TcM CoVar
+newCoVar ty1 ty2
+  = do { name <- newName (mkTyVarOccFS (fsLit "co"))
+       ; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) }
+
+newIP :: IPName Name -> TcType -> TcM IpId
+newIP ip ty
+  = do 	{ name <- newName (getOccName (ipNameName ip))
+        ; return (mkLocalId name (mkPredTy (IParam ip ty))) }
+
+newDict :: Class -> [TcType] -> TcM DictId
+newDict cls tys 
+  = do { name <- newName (mkDictOcc (getOccName cls))
+       ; return (mkLocalId name (mkPredTy (ClassP cls tys))) }
+
+newName :: OccName -> TcM Name
+newName occ
+  = do { uniq <- newUnique
+       ; loc  <- getSrcSpanM
+       ; return (mkInternalName uniq occ loc) }
 
-Execute a bag of type variable bindings.
-
-\begin{code}
-execTcTyVarBinds :: TcTyVarBinds -> TcM ()
-execTcTyVarBinds = mapM_ execTcTyVarBind . bagToList
-  where
-    execTcTyVarBind (TcTyVarBind tv ty)
-      = do { ASSERTM2( do { details <- readMetaTyVar tv
-                          ; return (isFlexi details) }, ppr tv )
-           ; ty' <- if isCoVar tv 
-                    then return ty 
-                    else do { maybe_ty <- checkTauTvUpdate tv ty
-                            ; case maybe_ty of
-                                Nothing -> pprPanic "TcRnMonad.execTcTyBind"
-                                             (ppr tv <+> text ":=" <+> ppr ty)
-                                Just ty' -> return ty'
-                            }
-           ; writeMetaTyVar tv ty'
-           }
-\end{code}
-
-Error mesages in case of kind mismatch.
+-----------------
+newKindConstraint :: Type -> Kind -> TcM (CoVar, Type)
+-- Create a new wanted CoVar that constrains the type
+-- to have the specified kind
+newKindConstraint ty kind
+  = do { ty_k <- newFlexiTyVarTy kind
+       ; co_var <- newWantedCoVar ty ty_k
+       ; return (co_var, ty_k) }
 
-\begin{code}
-unifyKindMisMatch :: TcKind -> TcKind -> TcM ()
-unifyKindMisMatch ty1 ty2 = do
-    ty1' <- zonkTcKind ty1
-    ty2' <- zonkTcKind ty2
-    let
-	msg = hang (ptext (sLit "Couldn't match kind"))
-		   2 (sep [quotes (ppr ty1'), 
-			   ptext (sLit "against"), 
-			   quotes (ppr ty2')])
-    failWithTc msg
-
-unifyKindCtxt :: Bool -> TyVar -> Type -> TidyEnv -> TcM (TidyEnv, SDoc)
-unifyKindCtxt swapped tv1 ty2 tidy_env	-- not swapped => tv1 expected, ty2 inferred
-	-- tv1 and ty2 are zonked already
-  = return msg
-  where
-    msg = (env2, ptext (sLit "When matching the kinds of") <+> 
-		 sep [quotes pp_expected <+> ptext (sLit "and"), quotes pp_actual])
-
-    (pp_expected, pp_actual) | swapped   = (pp2, pp1)
-		             | otherwise = (pp1, pp2)
-    (env1, tv1') = tidyOpenTyVar tidy_env tv1
-    (env2, ty2') = tidyOpenType  env1 ty2
-    pp1 = ppr tv1' <+> dcolon <+> ppr (tyVarKind tv1)
-    pp2 = ppr ty2' <+> dcolon <+> ppr (typeKind ty2)
+-----------------
+newSelfDict :: Class -> [TcType] -> TcM DictId
+-- Make a dictionary for "self". It behaves just like a normal DictId
+-- except that it responds True to isSelfDict
+-- This is used only to suppress confusing error reports
+newSelfDict cls tys 
+  = do { uniq <- newUnique
+       ; let name = mkSystemName uniq selfDictOcc
+       ; return (mkLocalId name (mkPredTy (ClassP cls tys))) }
+
+selfDictOcc :: OccName
+selfDictOcc = mkVarOcc "self"
+
+isSelfDict :: EvVar -> Bool
+isSelfDict v = isSystemName (Var.varName v)
+  -- Notice that all *other* evidence variables get Internal Names
 \end{code}
 
-Error message for failure due to an occurs check.
-
-\begin{code}
-occurCheckErr :: TcType -> TcType -> TcM a
-occurCheckErr ty containingTy
-  = do	{ env0 <- tcInitTidyEnv
-	; ty'           <- zonkTcType ty
-	; containingTy' <- zonkTcType containingTy
-	; let (env1, tidy_ty1) = tidyOpenType env0 ty'
-	      (env2, tidy_ty2) = tidyOpenType env1 containingTy'
-	      extra = sep [ppr tidy_ty1, char '=', ppr tidy_ty2]
-	; failWithTcM (env2, hang msg 2 extra) }
-  where
-    msg = ptext (sLit "Occurs check: cannot construct the infinite type:")
-\end{code}
 
 %************************************************************************
 %*									*
-	Kind variables
+	SkolemTvs (immutable)
 %*									*
 %************************************************************************
 
 \begin{code}
-newCoVars :: [(TcType,TcType)] -> TcM [CoVar]
-newCoVars spec
-  = do	{ us <- newUniqueSupply 
-	; return [ mkCoVar (mkSysTvName uniq (fsLit "co_kv"))
-			   (mkCoKind ty1 ty2)
-		 | ((ty1,ty2), uniq) <- spec `zip` uniqsFromSupply us] }
-
-newMetaCoVar :: TcType -> TcType -> TcM TcTyVar
-newMetaCoVar ty1 ty2 = newMetaTyVar TauTv (mkCoKind ty1 ty2)
-
-newKindVar :: TcM TcKind
-newKindVar = do	{ uniq <- newUnique
-		; ref <- newMutVar Flexi
-		; return (mkTyVarTy (mkKindVar uniq ref)) }
+tcInstType :: ([TyVar] -> TcM [TcTyVar]) 		-- How to instantiate the type variables
+	   -> TcType 					-- Type to instantiate
+	   -> TcM ([TcTyVar], TcThetaType, TcType)	-- Result
+		-- (type vars (excl coercion vars), preds (incl equalities), rho)
+tcInstType inst_tyvars ty
+  = case tcSplitForAllTys ty of
+	([],     rho) -> let	-- There may be overloading despite no type variables;
+				-- 	(?x :: Int) => Int -> Int
+			   (theta, tau) = tcSplitPhiTy rho
+			 in
+			 return ([], theta, tau)
 
-newKindVars :: Int -> TcM [TcKind]
-newKindVars n = mapM (\ _ -> newKindVar) (nOfThem n ())
-\end{code}
+	(tyvars, rho) -> do { tyvars' <- inst_tyvars tyvars
 
+			    ; let  tenv = zipTopTvSubst tyvars (mkTyVarTys tyvars')
+				-- Either the tyvars are freshly made, by inst_tyvars,
+				-- or (in the call from tcSkolSigType) any nested foralls
+				-- have different binders.  Either way, zipTopTvSubst is ok
 
-%************************************************************************
-%*									*
-	SkolemTvs (immutable)
-%*									*
-%************************************************************************
+			    ; let  (theta, tau) = tcSplitPhiTy (substTy tenv rho)
+			    ; return (tyvars', theta, tau) }
 
-\begin{code}
 mkSkolTyVar :: Name -> Kind -> SkolemInfo -> TcTyVar
 mkSkolTyVar name kind info = mkTcTyVar name kind (SkolemTv info)
 
 tcSkolSigType :: SkolemInfo -> Type -> TcM ([TcTyVar], TcThetaType, TcType)
 -- Instantiate a type signature with skolem constants, but 
 -- do *not* give them fresh names, because we want the name to
--- be in the type environment -- it is lexically scoped.
+-- be in the type environment: it is lexically scoped.
 tcSkolSigType info ty = tcInstType (\tvs -> return (tcSkolSigTyVars info tvs)) ty
 
 tcSkolSigTyVars :: SkolemInfo -> [TyVar] -> [TcTyVar]
@@ -454,39 +244,48 @@ tcSkolSigTyVars :: SkolemInfo -> [TyVar] -> [TcTyVar]
 tcSkolSigTyVars info tyvars = [ mkSkolTyVar (tyVarName tv) (tyVarKind tv) info
 			      | tv <- tyvars ]
 
-tcInstSkolTyVar :: SkolemInfo -> (Name -> SrcSpan) -> TyVar -> TcM TcTyVar
+tcInstSkolTyVar :: SkolemInfo -> TyVar -> TcM TcTyVar
 -- Instantiate the tyvar, using 
 --	* the occ-name and kind of the supplied tyvar, 
 --	* the unique from the monad,
---	* the location either from the tyvar (mb_loc = Nothing)
---	  or from mb_loc (Just loc)
-tcInstSkolTyVar info get_loc tyvar
+--	* the location either from the tyvar (skol_info = SigSkol)
+--	               or from the monad (otehrwise)
+tcInstSkolTyVar skol_info tyvar
   = do	{ uniq <- newUnique
-	; let old_name = tyVarName tyvar
-	      kind     = tyVarKind tyvar
-	      loc      = get_loc old_name
-	      new_name = mkInternalName uniq (nameOccName old_name) loc
-	; return (mkSkolTyVar new_name kind info) }
+	; loc <- case skol_info of
+                    SigSkol {} -> return (getSrcSpan old_name)
+                    _          -> getSrcSpanM
+	; let new_name = mkInternalName uniq occ loc
+	; return (mkSkolTyVar new_name kind skol_info) }
+  where
+    old_name = tyVarName tyvar
+    occ      = nameOccName old_name
+    kind     = tyVarKind tyvar
 
 tcInstSkolTyVars :: SkolemInfo -> [TyVar] -> TcM [TcTyVar]
 -- Get the location from the monad
 tcInstSkolTyVars info tyvars 
-  = do 	{ span <- getSrcSpanM
-	; mapM (tcInstSkolTyVar info (const span)) tyvars }
+  = mapM (tcInstSkolTyVar info) tyvars
 
 tcInstSkolType :: SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcType)
 -- Instantiate a type with fresh skolem constants
 -- Binding location comes from the monad
 tcInstSkolType info ty = tcInstType (tcInstSkolTyVars info) ty
 
-tcInstSigType :: Bool -> SkolemInfo -> TcType -> TcM ([TcTyVar], TcThetaType, TcRhoType)
+tcInstSigType :: Bool -> Name -> TcType -> TcM ([TcTyVar], TcThetaType, TcRhoType)
 -- Instantiate with skolems or meta SigTvs; depending on use_skols
 -- Always take location info from the supplied tyvars
-tcInstSigType use_skols skol_info ty
-  = tcInstType (mapM inst_tyvar) ty
-  where
-    inst_tyvar | use_skols = tcInstSkolTyVar skol_info getSrcSpan
-    	       | otherwise = instMetaTyVar (SigTv skol_info)
+tcInstSigType use_skols name ty
+  | use_skols
+  = tcInstType (tcInstSkolTyVars (SigSkol (FunSigCtxt name))) ty
+  | otherwise
+  = tcInstType tcInstSigTyVars ty
+
+tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar]
+-- Make meta SigTv type variables for patten-bound scoped type varaibles
+-- We use SigTvs for them, so that they can't unify with arbitrary types
+tcInstSigTyVars = mapM (\tv -> instMetaTyVar (SigTv (tyVarName tv)) tv)
+		-- ToDo: the "function binding site is bogus
 \end{code}
 
 
@@ -497,36 +296,37 @@ tcInstSigType use_skols skol_info ty
 %************************************************************************
 
 \begin{code}
-newMetaTyVar :: BoxInfo -> Kind -> TcM TcTyVar
+newMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar
 -- Make a new meta tyvar out of thin air
-newMetaTyVar box_info kind
+newMetaTyVar meta_info kind
   = do	{ uniq <- newUnique
  	; ref <- newMutVar Flexi
 	; let name = mkSysTvName uniq fs 
-	      fs = case box_info of
-			BoxTv   -> fsLit "t"
+	      fs = case meta_info of
 			TauTv   -> fsLit "t"
 			SigTv _ -> fsLit "a"
-		-- We give BoxTv and TauTv the same string, because
-		-- otherwise we get user-visible differences in error
-		-- messages, which are confusing.  If you want to see
-		-- the box_info of each tyvar, use -dppr-debug
-	; return (mkTcTyVar name kind (MetaTv box_info ref)) }
+	; return (mkTcTyVar name kind (MetaTv meta_info ref)) }
 
-instMetaTyVar :: BoxInfo -> TyVar -> TcM TcTyVar
+instMetaTyVar :: MetaInfo -> TyVar -> TcM TcTyVar
 -- Make a new meta tyvar whose Name and Kind 
 -- come from an existing TyVar
-instMetaTyVar box_info tyvar
+instMetaTyVar meta_info tyvar
   = do	{ uniq <- newUnique
  	; ref <- newMutVar Flexi
 	; let name = setNameUnique (tyVarName tyvar) uniq
 	      kind = tyVarKind tyvar
-	; return (mkTcTyVar name kind (MetaTv box_info ref)) }
+	; return (mkTcTyVar name kind (MetaTv meta_info ref)) }
 
 readMetaTyVar :: TyVar -> TcM MetaDetails
 readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )
 		      readMutVar (metaTvRef tyvar)
 
+readWantedCoVar :: CoVar -> TcM MetaDetails
+readWantedCoVar covar = ASSERT2( isMetaTyVar covar, ppr covar )
+		        readMutVar (metaTvRef covar)
+
+
+
 isFilledMetaTyVar :: TyVar -> TcM Bool
 -- True of a filled-in (Indirect) meta type variable
 isFilledMetaTyVar tv
@@ -536,26 +336,65 @@ isFilledMetaTyVar tv
 	; return (isIndirect details) }
   | otherwise = return False
 
+isFlexiMetaTyVar :: TyVar -> TcM Bool
+-- True of a un-filled-in (Flexi) meta type variable
+isFlexiMetaTyVar tv
+  | not (isTcTyVar tv) = return False
+  | MetaTv _ ref <- tcTyVarDetails tv
+  = do 	{ details <- readMutVar ref
+	; return (isFlexi details) }
+  | otherwise = return False
+
+--------------------
 writeMetaTyVar :: TcTyVar -> TcType -> TcM ()
+-- Write into a currently-empty MetaTyVar
+
 writeMetaTyVar tyvar ty
-  | not debugIsOn = writeMutVar (metaTvRef tyvar) (Indirect ty)
-writeMetaTyVar tyvar ty
-  | not (isMetaTyVar tyvar)
-  = pprTrace "writeMetaTyVar" (ppr tyvar) $
+  | not debugIsOn 
+  = writeMetaTyVarRef tyvar (metaTvRef tyvar) ty
+
+-- Everything from here on only happens if DEBUG is on
+  | not (isTcTyVar tyvar)
+  = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar )
+    return ()
+
+  | MetaTv _ ref <- tcTyVarDetails tyvar
+  = writeMetaTyVarRef tyvar ref ty
+
+  | otherwise
+  = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar )
     return ()
+
+writeWantedCoVar :: CoVar -> Coercion -> TcM () 
+writeWantedCoVar cv co = writeMetaTyVar cv co 
+
+--------------------
+writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()
+-- Here the tyvar is for error checking only; 
+-- the ref cell must be for the same tyvar
+writeMetaTyVarRef tyvar ref ty
+  | not debugIsOn 
+  = do { traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
+       ; writeMutVar ref (Indirect ty) }
+
+-- Everything from here on only happens if DEBUG is on
+  | not (isPredTy tv_kind)   -- Don't check kinds for updates to coercion variables
+  , not (ty_kind `isSubKind` tv_kind)
+  = WARN( True, hang (text "Ill-kinded update to meta tyvar")
+                   2 (ppr tyvar $$ ppr tv_kind $$ ppr ty $$ ppr ty_kind) )
+    return ()
+
   | otherwise
-  = ASSERT( isMetaTyVar tyvar )
-    ASSERT2( isCoVar tyvar || typeKind ty `isSubKind` tyVarKind tyvar, 
-             (ppr tyvar <+> ppr (tyVarKind tyvar)) 
-             $$ (ppr ty <+> ppr (typeKind ty)) )
-    do	{ if debugIsOn then do { details <- readMetaTyVar tyvar; 
--- FIXME   	     	       	       ; ASSERT2( not (isFlexi details), ppr tyvar )
-    	     	       	       ; WARN( not (isFlexi details), ppr tyvar )
-			       	 return () }
-			else return () 
-
-	; traceTc (text "writeMetaTyVar" <+> ppr tyvar <+> text ":=" <+> ppr ty)
-	; writeMutVar (metaTvRef tyvar) (Indirect ty) }
+  = do { meta_details <- readMutVar ref; 
+       ; WARN( not (isFlexi meta_details), 
+                hang (text "Double update of meta tyvar")
+                   2 (ppr tyvar $$ ppr meta_details) )
+
+         traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)
+       ; writeMutVar ref (Indirect ty) }
+  where
+    tv_kind = tyVarKind tyvar
+    ty_kind = typeKind ty
 \end{code}
 
 
@@ -613,107 +452,27 @@ zonkSigTyVar sig_tv
 \end{code}
 
 
-%************************************************************************
-%*									*
-	MetaTvs: BoxTvs
-%*									*
-%************************************************************************
-
-\begin{code}
-newBoxyTyVar :: Kind -> TcM BoxyTyVar
-newBoxyTyVar kind = newMetaTyVar BoxTv kind
-
-newBoxyTyVars :: [Kind] -> TcM [BoxyTyVar]
-newBoxyTyVars kinds = mapM newBoxyTyVar kinds
-
-newBoxyTyVarTys :: [Kind] -> TcM [BoxyType]
-newBoxyTyVarTys kinds = do { tvs <- mapM newBoxyTyVar kinds; return (mkTyVarTys tvs) }
-
-readFilledBox :: BoxyTyVar -> TcM TcType
--- Read the contents of the box, which should be filled in by now
-readFilledBox box_tv = ASSERT( isBoxyTyVar box_tv )
-		       do { cts <- readMetaTyVar box_tv
-		 	  ; case cts of
-				Flexi -> pprPanic "readFilledBox" (ppr box_tv)
-				Indirect ty -> return ty }
-
-tcInstBoxyTyVar :: TyVar -> TcM BoxyTyVar
--- Instantiate with a BOXY type variable
-tcInstBoxyTyVar tyvar = instMetaTyVar BoxTv tyvar
-\end{code}
-
 
 %************************************************************************
 %*									*
-\subsection{Putting and getting  mutable type variables}
+\subsection{Zonking -- the exernal interfaces}
 %*									*
 %************************************************************************
 
-But it's more fun to short out indirections on the way: If this
-version returns a TyVar, then that TyVar is unbound.  If it returns
-any other type, then there might be bound TyVars embedded inside it.
-
-We return Nothing iff the original box was unbound.
+@tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment.
+To improve subsequent calls to the same function it writes the zonked set back into
+the environment.
 
 \begin{code}
-data LookupTyVarResult	-- The result of a lookupTcTyVar call
-  = DoneTv TcTyVarDetails	-- SkolemTv or virgin MetaTv
-  | IndirectTv TcType
-
-lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult
-lookupTcTyVar tyvar 
-  = ASSERT2( isTcTyVar tyvar, ppr tyvar )
-    case details of
-      SkolemTv _   -> return (DoneTv details)
-      MetaTv _ ref -> do { meta_details <- readMutVar ref
-			 ; case meta_details of
-			    Indirect ty -> return (IndirectTv ty)
-			    Flexi -> return (DoneTv details) }
-  where
-    details =  tcTyVarDetails tyvar
-
-{- 
--- gaw 2004 We aren't shorting anything out anymore, at least for now
-getTcTyVar tyvar
-  | not (isTcTyVar tyvar)
-  = pprTrace "getTcTyVar" (ppr tyvar) $
-    return (Just (mkTyVarTy tyvar))
-
-  | otherwise
-  = ASSERT2( isTcTyVar tyvar, ppr tyvar ) do
-    maybe_ty <- readMetaTyVar tyvar
-    case maybe_ty of
-        Just ty -> do ty' <- short_out ty
-                      writeMetaTyVar tyvar (Just ty')
-                      return (Just ty')
-
-	Nothing	   -> return Nothing
-
-short_out :: TcType -> TcM TcType
-short_out ty@(TyVarTy tyvar)
-  | not (isTcTyVar tyvar)
-  = return ty
-
-  | otherwise = do
-    maybe_ty <- readMetaTyVar tyvar
-    case maybe_ty of
-        Just ty' -> do ty' <- short_out ty'
-                       writeMetaTyVar tyvar (Just ty')
-                       return ty'
-
-	other    -> return ty
-
-short_out other_ty = return other_ty
--}
+tcGetGlobalTyVars :: TcM TcTyVarSet
+tcGetGlobalTyVars
+  = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
+       ; gbl_tvs  <- readMutVar gtv_var
+       ; gbl_tvs' <- zonkTcTyVarsAndFV (varSetElems gbl_tvs)
+       ; writeMutVar gtv_var gbl_tvs'
+       ; return gbl_tvs' }
 \end{code}
 
-
-%************************************************************************
-%*									*
-\subsection{Zonking -- the exernal interfaces}
-%*									*
-%************************************************************************
-
 -----------------  Type variables
 
 \begin{code}
@@ -723,16 +482,44 @@ zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars
 zonkTcTyVarsAndFV :: [TcTyVar] -> TcM TcTyVarSet
 zonkTcTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTcTyVar tyvars
 
-zonkTcTyVar :: TcTyVar -> TcM TcType
-zonkTcTyVar tyvar = ASSERT2( isTcTyVar tyvar, ppr tyvar)
-		    zonk_tc_tyvar (\ tv -> return (TyVarTy tv)) tyvar
-\end{code}
-
 -----------------  Types
 
-\begin{code}
+zonkTcTypeCarefully :: TcType -> TcM TcType
+zonkTcTypeCarefully ty
+  = do { env_tvs <- tcGetGlobalTyVars
+       ; zonkType (zonkTcTyVarCarefully env_tvs) ty }
+
+
+zonkTcTyVarCarefully :: TcTyVarSet -> TcTyVar -> TcM TcType
+-- Do not zonk type variables free in the environment
+zonkTcTyVarCarefully env_tvs tv 
+  | tv `elemVarSet` env_tvs 
+  = return (TyVarTy tv)
+  | otherwise
+  = ASSERT( isTcTyVar tv )
+    case tcTyVarDetails tv of
+      SkolemTv {}  -> return (TyVarTy tv)
+      FlatSkol ty  -> zonkType (zonkTcTyVarCarefully env_tvs) ty
+      MetaTv _ ref -> do { cts <- readMutVar ref
+			 ; case cts of    
+			     Flexi       -> return (TyVarTy tv)
+			     Indirect ty -> zonkType (zonkTcTyVarCarefully env_tvs) ty }
+
 zonkTcType :: TcType -> TcM TcType
-zonkTcType ty = zonkType (\ tv -> return (TyVarTy tv)) ty
+-- Simply look through all Flexis
+zonkTcType ty = zonkType zonkTcTyVar ty
+
+zonkTcTyVar :: TcTyVar -> TcM TcType
+-- Simply look through all Flexis
+zonkTcTyVar tv
+  = ASSERT2( isTcTyVar tv, ppr tv )
+    case tcTyVarDetails tv of
+      SkolemTv {}  -> return (TyVarTy tv)
+      FlatSkol ty  -> zonkTcType ty
+      MetaTv _ ref -> do { cts <- readMutVar ref
+			 ; case cts of    
+			     Flexi       -> return (TyVarTy tv)
+			     Indirect ty -> zonkTcType ty }
 
 zonkTcTypes :: [TcType] -> TcM [TcType]
 zonkTcTypes tys = mapM zonkTcType tys
@@ -750,30 +537,6 @@ zonkTcPredType (EqPred t1 t2) = EqPred <$> zonkTcType t1 <*> zonkTcType t2
 		     are used at the end of type checking
 
 \begin{code}
-zonkTopTyVar :: TcTyVar -> TcM TcTyVar
--- zonkTopTyVar is used, at the top level, on any un-instantiated meta type variables
--- to default the kind of ? and ?? etc to *.  This is important to ensure that
--- instance declarations match.  For example consider
---	instance Show (a->b)
---	foo x = show (\_ -> True)
--- Then we'll get a constraint (Show (p ->q)) where p has argTypeKind (printed ??), 
--- and that won't match the typeKind (*) in the instance decl.
---
--- Because we are at top level, no further constraints are going to affect these
--- type variables, so it's time to do it by hand.  However we aren't ready
--- to default them fully to () or whatever, because the type-class defaulting
--- rules have yet to run.
-
-zonkTopTyVar tv
-  | k `eqKind` default_k = return tv
-  | otherwise
-  = do	{ tv' <- newFlexiTyVar default_k
-	; writeMetaTyVar tv (mkTyVarTy tv') 
-	; return tv' }
-  where
-    k = tyVarKind tv
-    default_k = defaultKind k
-
 zonkQuantifiedTyVars :: [TcTyVar] -> TcM [TcTyVar]
 zonkQuantifiedTyVars = mapM zonkQuantifiedTyVar
 
@@ -820,6 +583,29 @@ zonkQuantifiedTyVar tv
 	; return final_tv }
 \end{code}
 
+\begin{code}
+zonkImplication :: Implication -> TcM Implication
+zonkImplication implic@(Implic { ic_env_tvs = env_tvs, ic_given = given 
+                               , ic_wanted = wanted })
+  = do { env_tvs' <- zonkTcTyVarsAndFV (varSetElems env_tvs)
+       ; given'   <- mapM zonkEvVar given
+       ; wanted'  <- mapBagM zonkWanted wanted
+       ; return (implic { ic_env_tvs = env_tvs', ic_given = given'
+                        , ic_wanted = wanted' }) }
+
+zonkEvVar :: EvVar -> TcM EvVar
+zonkEvVar var = do { ty' <- zonkTcType (varType var)
+                   ; return (setVarType var ty') }
+
+zonkWanted :: WantedConstraint -> TcM WantedConstraint
+zonkWanted (WcImplic imp) = do { imp' <- zonkImplication imp; return (WcImplic imp') }
+zonkWanted (WcEvVar ev)   = do { ev' <- zonkWantedEvVar ev; return (WcEvVar ev') }
+
+zonkWantedEvVar :: WantedEvVar -> TcM WantedEvVar
+zonkWantedEvVar (WantedEvVar v l) = do { v' <- zonkEvVar v; return (WantedEvVar v' l) }
+\end{code}
+
+
 Note [Silly Type Synonyms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this:
@@ -866,9 +652,9 @@ leads to problems.  Consider this program from the regression test suite:
   evalRHS :: Int -> a
   evalRHS 0 root actual = eval 0 root actual
 
-It leads to the deferral of an equality
+It leads to the deferral of an equality (wrapped in an implication constraint)
 
-  (String -> String -> String) ~ a
+  forall a. (String -> String -> String) ~ a
 
 which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck).
 In the meantime `a' is zonked and quantified to form `evalRHS's signature.
@@ -883,7 +669,7 @@ variable now floating around in the simplifier, which in many places assumes to
 only see proper TcTyVars.
 
 We can avoid this problem by zonking with a skolem.  The skolem is rigid
-(which we requirefor a quantified variable), but is still a TcTyVar that the
+(which we require for a quantified variable), but is still a TcTyVar that the
 simplifier knows how to deal with.
 
 
@@ -904,7 +690,7 @@ zonkType :: (TcTyVar -> TcM Type) 	-- What to do with unbound mutable type varia
 					-- see zonkTcType, and zonkTcTypeToType
          -> TcType
 	 -> TcM Type
-zonkType unbound_var_fn ty
+zonkType zonk_tc_tyvar ty
   = go ty
   where
     go (TyConApp tc tys) = do tys' <- mapM go tys
@@ -925,14 +711,14 @@ zonkType unbound_var_fn ty
 		-- to pull the TyConApp to the top.
 
 	-- The two interesting cases!
-    go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar unbound_var_fn tyvar
+    go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar
 		       | otherwise	 = liftM TyVarTy $ 
-                                             zonkTyVar unbound_var_fn tyvar
+                                           zonkTyVar zonk_tc_tyvar tyvar
 		-- Ordinary (non Tc) tyvars occur inside quantified types
 
     go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do
                              ty' <- go ty
-                             tyvar' <- zonkTyVar unbound_var_fn tyvar
+                             tyvar' <- zonkTyVar zonk_tc_tyvar tyvar
                              return (ForAllTy tyvar' ty')
 
     go_pred (ClassP c tys)   = do tys' <- mapM go tys
@@ -943,28 +729,26 @@ zonkType unbound_var_fn ty
                                   ty2' <- go ty2
                                   return (EqPred ty1' ty2')
 
-zonk_tc_tyvar :: (TcTyVar -> TcM Type)	-- What to do for an unbound mutable var
+mkZonkTcTyVar :: (TcTyVar -> TcM Type)	-- What to do for an unbound mutable var
  	      -> TcTyVar -> TcM TcType
-zonk_tc_tyvar unbound_var_fn tyvar 
+mkZonkTcTyVar unbound_var_fn tyvar 
   = ASSERT( isTcTyVar tyvar )
     case tcTyVarDetails tyvar of
       SkolemTv {}  -> return (TyVarTy tyvar)
-      FlatSkol ty  -> zonkType unbound_var_fn ty
+      FlatSkol ty  -> zonkType (mkZonkTcTyVar unbound_var_fn) ty
       MetaTv _ ref -> do { cts <- readMutVar ref
 			 ; case cts of    
 			     Flexi       -> unbound_var_fn tyvar  
-			     Indirect ty -> zonkType unbound_var_fn ty  }
+			     Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty }
 
--- Zonk the kind of a non-TC tyvar in case it is a coercion variable (their
--- kind contains types).
---
-zonkTyVar :: (TcTyVar -> TcM Type)      -- What to do for an unbound mutable var
+-- Zonk the kind of a non-TC tyvar in case it is a coercion variable 
+-- (their kind contains types).
+zonkTyVar :: (TcTyVar -> TcM Type)      -- What to do for a TcTyVar
  	  -> TyVar -> TcM TyVar
-zonkTyVar unbound_var_fn tv 
+zonkTyVar zonk_tc_tyvar tv 
   | isCoVar tv
-  = do { kind <- zonkType unbound_var_fn (tyVarKind tv)
-       ; return $ setTyVarKind tv kind
-       }
+  = do { kind <- zonkType zonk_tc_tyvar (tyVarKind tv)
+       ; return $ setTyVarKind tv kind }
   | otherwise = return tv
 \end{code}
 
@@ -990,7 +774,8 @@ zonkTcKind k = zonkTcType k
 zonkTcKindToKind :: TcKind -> TcM Kind
 -- When zonking a TcKind to a kind, we need to instantiate kind variables,
 -- Haskell specifies that * is to be used, so we follow that.
-zonkTcKindToKind k = zonkType (\ _ -> return liftedTypeKind) k
+zonkTcKindToKind k 
+  = zonkType (mkZonkTcTyVar (\ _ -> return liftedTypeKind)) k
 \end{code}
 			
 %************************************************************************
@@ -1031,7 +816,7 @@ This might not necessarily show up in kind checking.
 checkValidType :: UserTypeCtxt -> Type -> TcM ()
 -- Checks that the type is valid for the given context
 checkValidType ctxt ty = do
-    traceTc (text "checkValidType" <+> ppr ty)
+    traceTc "checkValidType" (ppr ty)
     unboxed  <- doptM Opt_UnboxedTuples
     rank2    <- doptM Opt_Rank2Types
     rankn    <- doptM Opt_RankNTypes
@@ -1087,7 +872,7 @@ checkValidType ctxt ty = do
 	-- ill-formed type such as (a~Int)
     checkTc kind_ok (kindErr actual_kind)
 
-    traceTc (text "checkValidType done" <+> ppr ty)
+    traceTc "checkValidType done" (ppr ty)
 
 checkValidMonoType :: Type -> TcM ()
 checkValidMonoType ty = check_mono_type MustBeMonoType ty
@@ -1142,7 +927,7 @@ check_type rank ubx_tup ty
    
 -- Naked PredTys should, I think, have been rejected before now
 check_type _ _ ty@(PredTy {})
-  = failWithTc (text "Predicate used as a type:" <+> ppr ty)
+  = failWithTc (text "Predicate" <+> ppr ty <+> text "used as a type") 
 
 check_type _ _ (TyVarTy _) = return ()
 
@@ -1166,7 +951,7 @@ check_type rank ubx_tup ty@(TyConApp tc tys)
 
 	-- See Note [Liberal type synonyms]
 	; liberal <- doptM Opt_LiberalTypeSynonyms
-	; if not liberal || isOpenSynTyCon tc then
+	; if not liberal || isSynFamilyTyCon tc then
 		-- For H98 and synonym families, do check the type args
 		mapM_ (check_mono_type SynArgMonoType) tys
 
@@ -1353,13 +1138,6 @@ check_pred_ty dflags ctxt pred@(ClassP cls tys)
     arity_err  = arityErr "Class" class_name arity n_tys
     how_to_allow = parens (ptext (sLit "Use -XFlexibleContexts to permit this"))
 
-check_pred_ty _ (ClassSCCtxt _) (EqPred _ _)
-  =   -- We do not yet support superclass equalities.
-    failWithTc $
-      sep [ ptext (sLit "The current implementation of type families does not")
-          , ptext (sLit "support equality constraints in superclass contexts.")
-          , ptext (sLit "They are planned for a future release.")
-          ]
 
 check_pred_ty dflags _ pred@(EqPred ty1 ty2)
   = do {	-- Equational constraints are valid in all contexts if type
@@ -1438,6 +1216,10 @@ If the list of tv_names is empty, we have a monotype, and then we
 don't need to check for ambiguity either, because the test can't fail
 (see is_ambig).
 
+In addition, GHC insists that at least one type variable
+in each constraint is in V.  So we disallow a type like
+	forall a. Eq b => b -> b
+even in a scope where b is in scope.
 
 \begin{code}
 checkAmbiguity :: [TyVar] -> ThetaType -> TyVarSet -> TcM ()
@@ -1457,36 +1239,59 @@ checkAmbiguity forall_tyvars theta tau_tyvars
 ambigErr :: PredType -> SDoc
 ambigErr pred
   = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPred pred),
-	 nest 4 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$
+	 nest 2 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$
 		 ptext (sLit "must be reachable from the type after the '=>'"))]
+\end{code}
 
---------------------------
--- For this 'grow' stuff see Note [Growing the tau-tvs using constraints] in Inst
+Note [Growing the tau-tvs using constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(growInstsTyVars insts tvs) is the result of extending the set 
+    of tyvars tvs using all conceivable links from pred
 
+E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}
+Then grow precs tvs = {a,b,c}
+
+\begin{code}
 growThetaTyVars :: TcThetaType -> TyVarSet -> TyVarSet
--- Finds a fixpoint
+-- See Note [Growing the tau-tvs using constraints]
 growThetaTyVars theta tvs
   | null theta = tvs
   | otherwise  = fixVarSet mk_next tvs
   where
-    mk_next tvs = foldr growPredTyVars tvs theta
-
-
-growPredTyVars :: TcPredType -> TyVarSet -> TyVarSet
--- Here is where the special case for inplicit parameters happens
-growPredTyVars (IParam _ ty) tvs = tvs `unionVarSet` tyVarsOfType ty
-growPredTyVars pred          tvs = growTyVars (tyVarsOfPred pred) tvs
-
-growTyVars :: TyVarSet -> TyVarSet -> TyVarSet
-growTyVars new_tvs tvs 
-  | new_tvs `intersectsVarSet` tvs = tvs `unionVarSet` new_tvs
-  | otherwise			   = tvs
+    mk_next tvs = foldr grow_one tvs theta
+    grow_one pred tvs = growPredTyVars pred tvs `unionVarSet` tvs
+
+growPredTyVars :: TcPredType
+               -> TyVarSet	-- The set to extend
+	       -> TyVarSet	-- TyVars of the predicate if it intersects
+	       	  		-- the set, or is implicit parameter
+growPredTyVars pred tvs 
+  | IParam {} <- pred               = pred_tvs	-- See Note [Implicit parameters and ambiguity]
+  | pred_tvs `intersectsVarSet` tvs = pred_tvs
+  | otherwise                       = emptyVarSet
+  where
+    pred_tvs = tyVarsOfPred pred
 \end{code}
     
-In addition, GHC insists that at least one type variable
-in each constraint is in V.  So we disallow a type like
-	forall a. Eq b => b -> b
-even in a scope where b is in scope.
+Note [Implicit parameters and ambiguity] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Only a *class* predicate can give rise to ambiguity
+An *implicit parameter* cannot.  For example:
+	foo :: (?x :: [a]) => Int
+	foo = length ?x
+is fine.  The call site will suppply a particular 'x'
+
+Furthermore, the type variables fixed by an implicit parameter
+propagate to the others.  E.g.
+	foo :: (Show a, ?x::[a]) => Int
+	foo = show (?x++?x)
+The type of foo looks ambiguous.  But it isn't, because at a call site
+we might have
+	let ?x = 5::Int in foo
+and all is well.  In effect, implicit parameters are, well, parameters,
+so we can take their type variables into account as part of the
+"tau-tvs" stuff.  This is done in the function 'FunDeps.grow'.
+
 
 \begin{code}
 checkThetaCtxt :: SourceTyCtxt -> ThetaType -> SDoc
@@ -1513,26 +1318,8 @@ arityErr kind name n m
 	n_arguments | n == 0 = ptext (sLit "no arguments")
 		    | n == 1 = ptext (sLit "1 argument")
 		    | True   = hsep [int n, ptext (sLit "arguments")]
-
------------------
-notMonoType :: TcType -> TcM a
-notMonoType ty
-  = do	{ ty' <- zonkTcType ty
-	; env0 <- tcInitTidyEnv
-	; let (env1, tidy_ty) = tidyOpenType env0 ty'
-	      msg = ptext (sLit "Cannot match a monotype with") <+> quotes (ppr tidy_ty)
-	; failWithTcM (env1, msg) }
-
-notMonoArgs :: TcType -> TcM a
-notMonoArgs ty
-  = do	{ ty' <- zonkTcType ty
-	; env0 <- tcInitTidyEnv
-	; let (env1, tidy_ty) = tidyOpenType env0 ty'
-	      msg = ptext (sLit "Arguments of type synonym families must be monotypes") <+> quotes (ppr tidy_ty)
-	; failWithTcM (env1, msg) }
 \end{code}
 
-
 %************************************************************************
 %*									*
 \subsection{Checking for a decent instance head type}
@@ -1607,7 +1394,7 @@ check_inst_head dflags clas tys
 instTypeErr :: SDoc -> SDoc -> SDoc
 instTypeErr pp_ty msg
   = sep [ptext (sLit "Illegal instance declaration for") <+> quotes pp_ty, 
-	 nest 4 msg]
+	 nest 2 msg]
 \end{code}
 
 
@@ -1694,63 +1481,9 @@ smallerMsg = ptext (sLit "Constraint is no smaller than the instance head")
 undecidableMsg = ptext (sLit "Use -XUndecidableInstances to permit this")
 \end{code}
 
-
-%************************************************************************
-%*									*
-	Checking the context of a derived instance declaration
-%*									*
-%************************************************************************
-
-Note [Exotic derived instance contexts]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In a 'derived' instance declaration, we *infer* the context.  It's a
-bit unclear what rules we should apply for this; the Haskell report is
-silent.  Obviously, constraints like (Eq a) are fine, but what about
-	data T f a = MkT (f a) deriving( Eq )
-where we'd get an Eq (f a) constraint.  That's probably fine too.
-
-One could go further: consider
-	data T a b c = MkT (Foo a b c) deriving( Eq )
-	instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
-
-Notice that this instance (just) satisfies the Paterson termination 
-conditions.  Then we *could* derive an instance decl like this:
-
-	instance (C Int a, Eq b, Eq c) => Eq (T a b c) 
-even though there is no instance for (C Int a), because there just
-*might* be an instance for, say, (C Int Bool) at a site where we
-need the equality instance for T's.  
-
-However, this seems pretty exotic, and it's quite tricky to allow
-this, and yet give sensible error messages in the (much more common)
-case where we really want that instance decl for C.
-
-So for now we simply require that the derived instance context
-should have only type-variable constraints.
-
-Here is another example:
-	data Fix f = In (f (Fix f)) deriving( Eq )
-Here, if we are prepared to allow -XUndecidableInstances we
-could derive the instance
-	instance Eq (f (Fix f)) => Eq (Fix f)
-but this is so delicate that I don't think it should happen inside
-'deriving'. If you want this, write it yourself!
-
-NB: if you want to lift this condition, make sure you still meet the
-termination conditions!  If not, the deriving mechanism generates
-larger and larger constraints.  Example:
-  data Succ a = S a
-  data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
-
-Note the lack of a Show instance for Succ.  First we'll generate
-  instance (Show (Succ a), Show a) => Show (Seq a)
-and then
-  instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
-and so on.  Instead we want to complain of no instance for (Show (Succ a)).
-
-The bottom line
-~~~~~~~~~~~~~~~
-Allow constraints which consist only of type variables, with no repeats.
+validDeivPred checks for OK 'deriving' context.  See Note [Exotic
+derived instance contexts] in TcSimplify.  However the predicate is
+here because it uses sizeTypes, fvTypes.
 
 \begin{code}
 validDerivPred :: PredType -> Bool
@@ -1759,6 +1492,7 @@ validDerivPred (ClassP _ tys) = hasNoDups fvs && sizeTypes tys == length fvs
 validDerivPred _              = False
 \end{code}
 
+
 %************************************************************************
 %*									*
 	Checking type instance well-formedness and termination
@@ -1826,7 +1560,7 @@ isTyFamFree = null . tyFamInsts
 tyFamInstIllegalErr :: Type -> SDoc
 tyFamInstIllegalErr ty
   = hang (ptext (sLit "Illegal type synonym family application in instance") <> 
-         colon) 4 $
+         colon) 2 $
       ppr ty
 
 famInstUndecErr :: Type -> SDoc -> SDoc
diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index cb18b04..255d97b 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -12,7 +12,7 @@ module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
 		   tcDoStmt, tcMDoStmt, tcGuardStmt
        ) where
 
-import {-# SOURCE #-}	TcExpr( tcSyntaxOp, tcInferRhoNC, 
+import {-# SOURCE #-}	TcExpr( tcSyntaxOp, tcInferRhoNC, tcCheckId,
                                 tcMonoExpr, tcMonoExprNC, tcPolyExpr )
 
 import HsSyn
@@ -24,14 +24,16 @@ import TcMType
 import TcType
 import TcBinds
 import TcUnify
-import TcSimplify
 import Name
 import TysWiredIn
 import PrelNames
 import Id
 import TyCon
 import TysPrim
+import Coercion		( mkSymCoI )
 import Outputable
+import VarSet
+import BasicTypes	( Arity )
 import Util
 import SrcLoc
 import FastString
@@ -52,12 +54,17 @@ import Control.Monad
 is used in error messages.  It checks that all the equations have the
 same number of arguments before using @tcMatches@ to do the work.
 
+Note [Polymorphic expected type for tcMatchesFun]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+tcMatchesFun may be given a *sigma* (polymorphic) type
+so it must be prepared to use tcGen to skolemise it.
+See Note [sig_tau may be polymorphic] in TcPat.
+
 \begin{code}
 tcMatchesFun :: Name -> Bool
 	     -> MatchGroup Name
-	     -> BoxyRhoType 		-- Expected type of function
-	     -> TcM (HsWrapper, MatchGroup TcId)	-- Returns type of body
-
+	     -> TcSigmaType			   -- Expected type of function
+	     -> TcM (HsWrapper, MatchGroup TcId)   -- Returns type of body
 tcMatchesFun fun_name inf matches exp_ty
   = do	{  -- Check that they all have the same no of arguments
 	   -- Location is in the monad, set the caller so that 
@@ -65,23 +72,19 @@ tcMatchesFun fun_name inf matches exp_ty
 	   -- sensible location.	Note: we have to do this odd
 	   -- ann-grabbing, because we don't always have annotations in
 	   -- hand when we call tcMatchesFun...
-          traceTc (text "tcMatchesFun" <+> (ppr fun_name $$ ppr exp_ty))
+          traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
 	; checkArgs fun_name matches
 
-	-- ToDo: Don't use "expected" stuff if there ain't a type signature
-	-- because inconsistency between branches
-	-- may show up as something wrong with the (non-existent) type signature
-
-		-- This is one of two places places we call subFunTys
-		-- The point is that if expected_y is a "hole", we want 
-		-- to make pat_tys and rhs_ty as "holes" too.
-	; subFunTys doc n_pats exp_ty (Just (FunSigCtxt fun_name)) $ \ pat_tys rhs_ty -> 
-	  tcMatches match_ctxt pat_tys rhs_ty matches
-	}
+	; (wrap_gen, (wrap_fun, group)) 
+            <- tcGen (SigSkol (FunSigCtxt fun_name)) emptyVarSet exp_ty $ \ _ exp_rho ->
+	          -- Note [Polymorphic expected type for tcMatchesFun]
+               matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty -> 
+	       tcMatches match_ctxt pat_tys rhs_ty matches 
+        ; return (wrap_gen <.> wrap_fun, group) }
   where
-    doc = ptext (sLit "The equation(s) for") <+> quotes (ppr fun_name)
-	  <+> ptext (sLit "have") <+> speakNOf n_pats (ptext (sLit "argument"))
-    n_pats = matchGroupArity matches
+    arity = matchGroupArity matches
+    herald = ptext (sLit "The equation(s) for")
+             <+> quotes (ppr fun_name) <+> ptext (sLit "have")
     match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
 \end{code}
 
@@ -92,22 +95,19 @@ parser guarantees that each equation has exactly one argument.
 tcMatchesCase :: TcMatchCtxt		-- Case context
 	      -> TcRhoType		-- Type of scrutinee
 	      -> MatchGroup Name	-- The case alternatives
-	      -> BoxyRhoType 		-- Type of whole case expressions
+	      -> TcRhoType 		-- Type of whole case expressions
 	      -> TcM (MatchGroup TcId)	-- Translated alternatives
 
 tcMatchesCase ctxt scrut_ty matches res_ty
-  | isEmptyMatchGroup matches
-  =	  -- Allow empty case expressions
-    do {  -- Make sure we follow the invariant that res_ty is filled in
-          res_ty' <- refineBoxToTau res_ty
-       ;  return (MatchGroup [] (mkFunTys [scrut_ty] res_ty')) }
+  | isEmptyMatchGroup matches   -- Allow empty case expressions
+  = return (MatchGroup [] (mkFunTys [scrut_ty] res_ty)) 
 
   | otherwise
   = tcMatches ctxt [scrut_ty] res_ty matches
 
-tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
+tcMatchLambda :: MatchGroup Name -> TcRhoType -> TcM (HsWrapper, MatchGroup TcId)
 tcMatchLambda match res_ty 
-  = subFunTys doc n_pats res_ty Nothing	$ \ pat_tys rhs_ty ->
+  = matchFunTys doc n_pats res_ty  $ \ pat_tys rhs_ty ->
     tcMatches match_ctxt pat_tys rhs_ty match
   where
     n_pats = matchGroupArity match
@@ -123,7 +123,7 @@ tcMatchLambda match res_ty
 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 
 \begin{code}
-tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
+tcGRHSsPat :: GRHSs Name -> TcRhoType -> TcM (GRHSs TcId)
 -- Used for pattern bindings
 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
   where
@@ -132,6 +132,23 @@ tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
 \end{code}
 
 
+\begin{code}
+matchFunTys
+  :: SDoc	-- See Note [Herald for matchExpecteFunTys] in TcUnify
+  -> Arity
+  -> TcRhoType
+  -> ([TcSigmaType] -> TcRhoType -> TcM a)
+  -> TcM (HsWrapper, a)
+
+-- Written in CPS style for historical reasons; 
+-- could probably be un-CPSd, like matchExpectedTyConApp
+
+matchFunTys herald arity res_ty thing_inside
+  = do	{ (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty
+	; res <- thing_inside pat_tys res_ty
+        ; return (coiToHsWrapper (mkSymCoI coi), res) }
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection{tcMatch}
@@ -140,8 +157,8 @@ tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
 
 \begin{code}
 tcMatches :: TcMatchCtxt
-	  -> [BoxySigmaType] 		-- Expected pattern types
-	  -> BoxyRhoType		-- Expected result-type of the Match.
+	  -> [TcSigmaType] 	-- Expected pattern types
+	  -> TcRhoType		-- Expected result-type of the Match.
 	  -> MatchGroup Name
 	  -> TcM (MatchGroup TcId)
 
@@ -149,7 +166,7 @@ data TcMatchCtxt 	-- c.f. TcStmtCtxt, also in this module
   = MC { mc_what :: HsMatchContext Name,	-- What kind of thing this is
     	 mc_body :: LHsExpr Name 		-- Type checker for a body of
                                                 -- an alternative
-		 -> BoxyRhoType
+		 -> TcRhoType
 		 -> TcM (LHsExpr TcId) }	
 
 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
@@ -159,8 +176,8 @@ tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
 
 -------------
 tcMatch :: TcMatchCtxt
-	-> [BoxySigmaType]	-- Expected pattern types
-	-> BoxyRhoType	 	-- Expected result-type of the Match.
+	-> [TcSigmaType]	-- Expected pattern types
+	-> TcRhoType	 	-- Expected result-type of the Match.
 	-> LMatch Name
 	-> TcM (LMatch TcId)
 
@@ -170,7 +187,7 @@ tcMatch ctxt pat_tys rhs_ty match
     tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
       = add_match_ctxt match $
         do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $
-    			        tc_grhss ctxt maybe_rhs_sig grhss
+    			        tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
 	   ; return (Match pats' Nothing grhss') }
 
     tc_grhss ctxt Nothing grhss rhs_ty 
@@ -188,7 +205,7 @@ tcMatch ctxt pat_tys rhs_ty match
 	    m_ctxt     -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
 
 -------------
-tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType
+tcGRHSs :: TcMatchCtxt -> GRHSs Name -> TcRhoType
 	-> TcM (GRHSs TcId)
 
 -- Notice that we pass in the full res_ty, so that we get
@@ -204,7 +221,7 @@ tcGRHSs ctxt (GRHSs grhss binds) res_ty
 	; return (GRHSs grhss' binds') }
 
 -------------
-tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId)
+tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId)
 
 tcGRHS ctxt res_ty (GRHS guards rhs)
   = do  { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
@@ -225,10 +242,10 @@ tcGRHS ctxt res_ty (GRHS guards rhs)
 tcDoStmts :: HsStmtContext Name 
 	  -> [LStmt Name]
 	  -> LHsExpr Name
-	  -> BoxyRhoType
+	  -> TcRhoType
 	  -> TcM (HsExpr TcId)		-- Returns a HsDo
 tcDoStmts ListComp stmts body res_ty
-  = do	{ (elt_ty, coi) <- boxySplitListTy res_ty
+  = do	{ (coi, elt_ty) <- matchExpectedListTy res_ty
 	; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts 
 				     elt_ty $
 			     tcBody body
@@ -236,7 +253,7 @@ tcDoStmts ListComp stmts body res_ty
                      (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
 
 tcDoStmts PArrComp stmts body res_ty
-  = do	{ (elt_ty, coi) <- boxySplitPArrTy res_ty
+  = do	{ (coi, elt_ty) <- matchExpectedPArrTy res_ty
 	; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts 
 				     elt_ty $
 			     tcBody body
@@ -249,26 +266,24 @@ tcDoStmts DoExpr stmts body res_ty
 	; return (HsDo DoExpr stmts' body' res_ty) }
 
 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
-  = do	{ ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty
- 	; let res_ty' = mkAppTy m_ty elt_ty	-- The boxySplit consumes res_ty
-	      tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
+  = do	{ (coi, (m_ty, elt_ty)) <- matchExpectedAppTy res_ty
+ 	; let res_ty' = mkAppTy m_ty elt_ty	-- The matchExpected consumes res_ty
+	      tc_rhs rhs = tcInfer $ \ pat_ty ->
 			   tcMonoExpr rhs (mkAppTy m_ty pat_ty)
 
-	; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts 
-				     res_ty' $
+	; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $
 			     tcBody body
 
 	; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
-	; insts <- mapM (newMethodFromName DoOrigin m_ty) names
-	; return $ 
-            mkHsWrapCoI coi 
-              (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
+	; insts <- mapM (\name -> newMethodFromName DoOrigin name m_ty) names
+	; return $ mkHsWrapCoI coi $ 
+          HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty' }
 
 tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 
-tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
+tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
 tcBody body res_ty
-  = do	{ traceTc (text "tcBody" <+> ppr res_ty)
+  = do	{ traceTc "tcBody" (ppr res_ty)
 	; body' <- tcMonoExpr body res_ty
 	; return body' 
         } 
@@ -285,15 +300,15 @@ tcBody body res_ty
 type TcStmtChecker
   =  forall thing. HsStmtContext Name
         	-> Stmt Name
-		-> BoxyRhoType			-- Result type for comprehension
-	      	-> (BoxyRhoType -> TcM thing)	-- Checker for what follows the stmt
+		-> TcRhoType			-- Result type for comprehension
+	      	-> (TcRhoType -> TcM thing)	-- Checker for what follows the stmt
               	-> TcM (Stmt TcId, thing)
 
 tcStmts :: HsStmtContext Name
 	-> TcStmtChecker	-- NB: higher-rank type
         -> [LStmt Name]
-	-> BoxyRhoType
-	-> (BoxyRhoType -> TcM thing)
+	-> TcRhoType
+	-> (TcRhoType -> TcM thing)
         -> TcM ([LStmt TcId], thing)
 
 -- Note the higher-rank type.  stmt_chk is applied at different
@@ -330,7 +345,8 @@ tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside
 
 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
   = do	{ (rhs', rhs_ty) <- tcInferRhoNC rhs	-- Stmt has a context already
-	; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty thing_inside
+	; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty $
+                            thing_inside res_ty
 	; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 tcGuardStmt _ stmt _ _
@@ -345,9 +361,10 @@ tcLcStmt :: TyCon	-- The list/Parray type constructor ([] or PArray)
 
 -- A generator, pat <- rhs
 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
- = do	{ (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
-			    tcMonoExpr rhs (mkTyConApp m_tc [ty])
-	; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
+ = do	{ pat_ty <- newFlexiTyVarTy liftedTypeKind
+        ; rhs'   <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
+	; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $
+                            thing_inside res_ty
 	; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 -- A boolean guard
@@ -361,7 +378,7 @@ tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside
 --		     | ... ; let h v = ... ]
 --
 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
--- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
+-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
 -- Similarly if we had an existential pattern match:
 --
 --	data T = forall a. Show a => C a
@@ -477,12 +494,10 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
                 -- (see Note [Treat rebindable syntax first], but that breaks 
 		-- the rigidity info for GADTs.  When we move to the new story
                 -- for GADTs, we can move this after tcSyntaxOp
-          (rhs', rhs_ty) <- tcInferRhoNC rhs
-
-	; ((bind_op', new_res_ty), pat_ty) <- 
-	     withBox liftedTypeKind $ \ pat_ty ->
-	     withBox liftedTypeKind $ \ new_res_ty ->
-	     tcSyntaxOp DoOrigin bind_op 
+          rhs_ty     <- newFlexiTyVarTy liftedTypeKind
+        ; pat_ty     <- newFlexiTyVarTy liftedTypeKind
+        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+	; bind_op'   <- tcSyntaxOp DoOrigin bind_op 
 			     (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
 
 		-- If (but only if) the pattern can fail, 
@@ -491,15 +506,9 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
 		      then return noSyntaxExpr
 		      else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty)
 
-		-- We should typecheck the RHS *before* the pattern,
-                -- because of GADTs. 
-		-- 	do { pat <- rhs; <rest> }
-		-- is rather like
-		--	case rhs of { pat -> <rest> }
-		-- We do inference on rhs, so that information about its type 
-                -- can be refined when type-checking the pattern. 
-
-	; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty thing_inside
+        ; rhs' <- tcMonoExprNC rhs rhs_ty
+	; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty $
+                           thing_inside new_res_ty
 
 	; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
 
@@ -508,10 +517,9 @@ tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside
   = do	{   	-- Deal with rebindable syntax; 
                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty
 		-- See also Note [Treat rebindable syntax first]
-	  ((then_op', rhs_ty), new_res_ty) <-
-		withBox liftedTypeKind $ \ new_res_ty ->
-		withBox liftedTypeKind $ \ rhs_ty ->
-		tcSyntaxOp DoOrigin then_op 
+          rhs_ty     <- newFlexiTyVarTy liftedTypeKind
+        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+	; then_op' <- tcSyntaxOp DoOrigin then_op 
 			   (mkFunTys [rhs_ty, new_res_ty] res_ty)
 
         ; rhs' <- tcMonoExprNC rhs rhs_ty
@@ -528,41 +536,35 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
 	      tup_ty  = mkBoxedTupleTy tup_elt_tys
 
         ; tcExtendIdEnv tup_ids $ do
-        { ((stmts', (ret_op', tup_rets)), stmts_ty)
-                <- withBox liftedTypeKind $ \ stmts_ty ->
-                   tcStmts ctxt tcDoStmt stmts stmts_ty   $ \ inner_res_ty ->
-                   do { tup_rets <- zipWithM tc_ret tup_names tup_elt_tys
+        { stmts_ty <- newFlexiTyVarTy liftedTypeKind
+        ; (stmts', (ret_op', tup_rets))
+                <- tcStmts ctxt tcDoStmt stmts stmts_ty   $ \ inner_res_ty ->
+                   do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
+                             -- Unify the types of the "final" Ids (which may 
+                             -- be polymorphic) with those of "knot-tied" Ids
 		      ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
                       ; return (ret_op', tup_rets) }
 
-	; (mfix_op', mfix_res_ty) <- withBox liftedTypeKind $ \ mfix_res_ty ->
-                                     tcSyntaxOp DoOrigin mfix_op
-                                        (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
+	; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
+        ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
+                                 (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
 
-	; (bind_op', new_res_ty) <- withBox liftedTypeKind $ \ new_res_ty ->
-				    tcSyntaxOp DoOrigin bind_op 
-			                (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
+	; new_res_ty <- newFlexiTyVarTy liftedTypeKind
+        ; bind_op' <- tcSyntaxOp DoOrigin bind_op 
+			         (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
 
-        ; (thing,lie) <- getLIE (thing_inside new_res_ty)
-        ; lie_binds <- bindInstsOfLocalFuns lie tup_ids
+        ; thing <- thing_inside new_res_ty
+--         ; lie_binds <- bindLocalMethods lie tup_ids
   
         ; let rec_ids = takeList rec_names tup_ids
 	; later_ids <- tcLookupLocalIds later_names
-	; traceTc (text "tcdo" <+> vcat [ppr rec_ids <+> ppr (map idType rec_ids),
-                                         ppr later_ids <+> ppr (map idType later_ids)])
+	; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
+                                 ppr later_ids <+> ppr (map idType later_ids)]
         ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
                           , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' 
                           , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
-                          , recS_rec_rets = tup_rets, recS_dicts = lie_binds }, thing)
+                          , recS_rec_rets = tup_rets, recS_dicts = emptyTcEvBinds }, thing)
         }}
-  where 
-    -- Unify the types of the "final" Ids with those of "knot-tied" Ids
-    tc_ret rec_name mono_ty
-        = do { poly_id <- tcLookupId rec_name
-                -- poly_id may have a polymorphic type
-                -- but mono_ty is just a monomorphic type variable
-             ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
-             ; return (mkHsWrap co_fn (HsVar poly_id)) }
 
 tcDoStmt _ stmt _ _
   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
@@ -589,7 +591,8 @@ tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType))	-- RHS inference
 	  -> TcStmtChecker
 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside
   = do	{ (rhs', pat_ty) <- tc_rhs rhs
-	; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside
+	; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $
+                            thing_inside res_ty
 	; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
 tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside
@@ -604,31 +607,25 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing
     	{ (stmts', (later_ids, rec_rets))
 		<- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty	$ \ _res_ty' ->
 			-- ToDo: res_ty not really right
-		   do { rec_rets <- zipWithM tc_ret recNames rec_tys
+		   do { rec_rets <- zipWithM tcCheckId recNames rec_tys
 		      ; later_ids <- tcLookupLocalIds laterNames
 		      ; return (later_ids, rec_rets) }
 
-	; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
+	; thing <- tcExtendIdEnv later_ids (thing_inside res_ty)
 		-- NB:	The rec_ids for the recursive things 
 		-- 	already scope over this part. This binding may shadow
 		--	some of them with polymorphic things with the same Name
 		--	(see note [RecStmt] in HsExpr)
-	; lie_binds <- bindInstsOfLocalFuns lie later_ids
+
+-- Need the bindLocalMethods if we re-add Method constraints
+--	; lie_binds <- bindLocalMethods lie later_ids
+	; let lie_binds = emptyTcEvBinds
   
 	; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets lie_binds, thing)
 	}}
-  where 
-    -- Unify the types of the "final" Ids with those of "knot-tied" Ids
-    tc_ret rec_name mono_ty
-	= do { poly_id <- tcLookupId rec_name
-		-- poly_id may have a polymorphic type
-		-- but mono_ty is just a monomorphic type variable
-	     ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty
-	     ; return (mkHsWrap co_fn (HsVar poly_id)) }
 
 tcMDoStmt _ _ stmt _ _
   = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
-
 \end{code}
 
 
diff --git a/compiler/typecheck/TcMatches.lhs-boot b/compiler/typecheck/TcMatches.lhs-boot
index e50949f..8d0fba2 100644
--- a/compiler/typecheck/TcMatches.lhs-boot
+++ b/compiler/typecheck/TcMatches.lhs-boot
@@ -2,15 +2,15 @@
 module TcMatches where
 import HsSyn	( GRHSs, MatchGroup, HsWrapper )
 import Name	( Name )
-import TcType	( BoxyRhoType )
+import TcType	( TcRhoType )
 import TcRnTypes( TcM, TcId )
 
 tcGRHSsPat    :: GRHSs Name
-	      -> BoxyRhoType
+	      -> TcRhoType
 	      -> TcM (GRHSs TcId)
 
 tcMatchesFun :: Name -> Bool
 	     -> MatchGroup Name
-	     -> BoxyRhoType
+	     -> TcRhoType
 	     -> TcM (HsWrapper, MatchGroup TcId)
 \end{code}
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 022796e..78ad69a 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -6,8 +6,9 @@
 TcPat: Typechecking patterns
 
 \begin{code}
-module TcPat ( tcLetPat, tcPat, tcPats, tcOverloadedLit,
-	       addDataConStupidTheta, badFieldCon, polyPatSig ) where
+module TcPat ( tcLetPat, TcSigFun, TcSigInfo(..)
+             , tcPat, tcPats, newLetBndr
+	     , addDataConStupidTheta, badFieldCon, polyPatSig ) where
 
 #include "HsVersions.h"
 
@@ -19,14 +20,10 @@ import TcRnMonad
 import Inst
 import Id
 import Var
-import CoreFVs
 import Name
-import TcSimplify
 import TcEnv
 import TcMType
 import TcType
-import VarEnv
-import VarSet
 import TcUnify
 import TcHsType
 import TysWiredIn
@@ -34,6 +31,7 @@ import Coercion
 import StaticFlags
 import TyCon
 import DataCon
+import VarSet	( emptyVarSet )
 import PrelNames
 import BasicTypes hiding (SuccessFlag(..))
 import DynFlags
@@ -53,27 +51,23 @@ import Control.Monad
 %************************************************************************
 
 \begin{code}
-tcLetPat :: (Name -> Maybe TcRhoType)
-      	 -> LPat Name -> BoxySigmaType 
+tcLetPat :: (Name -> Maybe TcSigInfo)
+         -> Bool     -- True <=> monomorphic
+      	 -> LPat Name -> TcSigmaType 
      	 -> TcM a
       	 -> TcM (LPat TcId, a)
-tcLetPat sig_fn pat pat_ty thing_inside
-  = do	{ let init_state = PS { pat_ctxt = LetPat sig_fn,
-				pat_eqs  = False }
-	; (pat', ex_tvs, res) <- tc_lpat pat pat_ty init_state 
-                                   (\ _ -> thing_inside)
-
-	-- Don't know how to deal with pattern-bound existentials yet
-	; checkTc (null ex_tvs) (existentialExplode pat)
-
-	; return (pat', res) }
+tcLetPat sig_fn is_mono pat pat_ty thing_inside
+  = tc_lpat pat pat_ty penv thing_inside 
+  where
+    penv = PE { pe_res_tvs = emptyVarSet, pe_lazy = True
+              , pe_ctxt = LetPat sig_fn is_mono }
 
 -----------------
 tcPats :: HsMatchContext Name
        -> [LPat Name]		 -- Patterns,
-       -> [BoxySigmaType]	 --   and their types
-       -> BoxyRhoType 		 -- Result type,
-       -> (BoxyRhoType -> TcM a) --   and the checker for the body
+       -> [TcSigmaType]	         --   and their types
+       -> TcRhoType 		 -- Result type,
+       -> TcM a                  --   and the checker for the body
        -> TcM ([LPat TcId], a)
 
 -- This is the externally-callable wrapper function
@@ -87,85 +81,115 @@ tcPats :: HsMatchContext Name
 --   3. Check the body
 --   4. Check that no existentials escape
 
-tcPats ctxt pats tys res_ty thing_inside
-  = tc_lam_pats (APat ctxt) (zipEqual "tcLamPats" pats tys)
-	        res_ty thing_inside
+tcPats ctxt pats pat_tys res_ty thing_inside
+  = tc_lpats penv pats pat_tys thing_inside
+  where
+    penv = PE { pe_res_tvs = tyVarsOfTypes (res_ty : pat_tys)
+              , pe_lazy = False
+              , pe_ctxt = LamPat ctxt }
 
 tcPat :: HsMatchContext Name
-      -> LPat Name -> BoxySigmaType 
-      -> BoxyRhoType             -- Result type
-      -> (BoxyRhoType -> TcM a)  -- Checker for body, given
-                                 -- its result type
+      -> LPat Name -> TcSigmaType 
+      -> TcRhoType             -- Result type
+      -> TcM a                 -- Checker for body, given
+                               -- its result type
       -> TcM (LPat TcId, a)
-tcPat ctxt = tc_lam_pat (APat ctxt)
-
-tc_lam_pat :: PatCtxt -> LPat Name -> BoxySigmaType -> BoxyRhoType
-           -> (BoxyRhoType -> TcM a) -> TcM (LPat TcId, a)
-tc_lam_pat ctxt pat pat_ty res_ty thing_inside
-  = do	{ ([pat'],thing) <- tc_lam_pats ctxt [(pat, pat_ty)] res_ty thing_inside
-	; return (pat', thing) }
+tcPat ctxt pat pat_ty res_ty thing_inside
+  = tc_lpat pat pat_ty penv thing_inside
+  where
+    penv = PE { pe_res_tvs = tyVarsOfTypes [res_ty, pat_ty]
+              , pe_lazy = False
+              , pe_ctxt = LamPat ctxt }
+   
 
 -----------------
-tc_lam_pats :: PatCtxt
-	    -> [(LPat Name,BoxySigmaType)]
-       	    -> BoxyRhoType            -- Result type
-       	    -> (BoxyRhoType -> TcM a) -- Checker for body, given its result type
-       	    -> TcM ([LPat TcId], a)
-tc_lam_pats ctxt pat_ty_prs res_ty thing_inside 
-  =  do	{ let init_state = PS { pat_ctxt = ctxt, pat_eqs = False }
+data PatEnv
+  = PE { pe_res_tvs :: TcTyVarSet	
+	           -- For existential escape check; see Note [Existential check]
+	      	   -- Nothing <=> inside a "~"
+		   -- Just tvs <=> unification tvs free in the result
+		   -- 	           (which should be made untouchable in
+		   --		    any existentials we encounter in the pattern)
+
+       , pe_lazy :: Bool	-- True <=> lazy context, so no existentials allowed
+       , pe_ctxt :: PatCtxt   	-- Context in which the whole pattern appears
+    }
+
+data PatCtxt
+  = LamPat   -- Used for lambdas, case etc
+       (HsMatchContext Name) 
+
+  | LetPat   -- Used only for let(rec) bindings
+    	     -- See Note [Let binders]
+       TcSigFun   -- Tells type sig if any
+       Bool  	  -- True <=> no generalisation of this let
+       					
+makeLazy :: PatEnv -> PatEnv
+makeLazy penv = penv { pe_lazy = True }
+
+patSigCtxt :: PatEnv -> UserTypeCtxt
+patSigCtxt (PE { pe_ctxt = LetPat {} }) = BindPatSigCtxt
+patSigCtxt (PE { pe_ctxt = LamPat {} }) = LamPatSigCtxt
+
+---------------
+type TcSigFun = Name -> Maybe TcSigInfo
+
+data TcSigInfo
+  = TcSigInfo {
+        sig_id     :: TcId,         --  *Polymorphic* binder for this value...
+
+        sig_scoped :: [Name],	    -- Scoped type variables
+		-- 1-1 correspondence with a prefix of sig_tvs
+		-- However, may be fewer than sig_tvs; 
+		-- see Note [More instantiated than scoped]
+        sig_tvs    :: [TcTyVar],    -- Instantiated type variables
+                                    -- See Note [Instantiate sig]
+
+        sig_theta  :: TcThetaType,  -- Instantiated theta
+
+        sig_tau    :: TcSigmaType,  -- Instantiated tau
+		      		    -- See Note [sig_tau may be polymorphic]
+
+        sig_loc    :: SrcSpan       -- The location of the signature
+    }
+
+instance Outputable TcSigInfo where
+    ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau})
+        = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrow theta <+> ppr tau
+\end{code}
 
-	; (pats', ex_tvs, res) <- do { traceTc (text "tc_lam_pats" <+> (ppr pat_ty_prs $$ ppr res_ty)) 
-				  ; tcMultiple tc_lpat_pr pat_ty_prs init_state $ \ pstate' ->
-				    if (pat_eqs pstate' && (not $ isRigidTy res_ty))
-				     then nonRigidResult ctxt res_ty
-	     			     else thing_inside res_ty }
+Note [sig_tau may be polymorphic]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note that "sig_tau" might actually be a polymorphic type,
+if the original function had a signature like
+   forall a. Eq a => forall b. Ord b => ....
+But that's ok: tcMatchesFun (called by tcRhs) can deal with that
+It happens, too!  See Note [Polymorphic methods] in TcClassDcl.
 
-	; let tys = map snd pat_ty_prs
-	; tcCheckExistentialPat pats' ex_tvs tys res_ty
+Note [Let binders]
+~~~~~~~~~~~~~~~~~~
+eg   x :: Int
+     y :: Bool
+     (x,y) = e
 
-	; return (pats', res) }
+...more notes to add here..
 
 
------------------
-tcCheckExistentialPat :: [LPat TcId]		-- Patterns (just for error message)
-		      -> [TcTyVar]		-- Existentially quantified tyvars bound by pattern
-		      -> [BoxySigmaType]	-- Types of the patterns
-		      -> BoxyRhoType		-- Type of the body of the match
-		      				-- Tyvars in either of these must not escape
-		      -> TcM ()
--- NB: we *must* pass "pats_tys" not just "body_ty" to tcCheckExistentialPat
--- For example, we must reject this program:
---	data C = forall a. C (a -> Int) 
--- 	f (C g) x = g x
--- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int).
-
-tcCheckExistentialPat _ [] _ _
-  = return ()	-- Short cut for case when there are no existentials
-
-tcCheckExistentialPat pats ex_tvs pat_tys body_ty
-  = addErrCtxtM (sigPatCtxt pats ex_tvs pat_tys body_ty)	$
-    checkSigTyVarsWrt (tcTyVarsOfTypes (body_ty:pat_tys)) ex_tvs
-
-data PatState = PS {
-	pat_ctxt :: PatCtxt,
-	pat_eqs  :: Bool        -- <=> there are any equational constraints 
-				-- Used at the end to say whether the result
-				-- type must be rigid
-  }
-
-data PatCtxt 
-  = APat (HsMatchContext Name)
-  | LetPat (Name -> Maybe TcRhoType)	-- Used for let(rec) bindings
-
-notProcPat :: PatCtxt -> Bool
-notProcPat (APat ProcExpr) = False
-notProcPat _	  	   = True
-
-patSigCtxt :: PatState -> UserTypeCtxt
-patSigCtxt (PS { pat_ctxt = LetPat _ }) = BindPatSigCtxt
-patSigCtxt _                            = LamPatSigCtxt
-\end{code}
+Note [Existential check]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Lazy patterns can't bind existentials.  They arise in two ways:
+  * Let bindings      let { C a b = e } in b
+  * Twiddle patterns  f ~(C a b) = e
+The pe_res_tvs field of PatEnv says whether we are inside a lazy
+pattern (perhaps deeply)
 
+If we aren't inside a lazy pattern then we can bind existentials,
+but we need to be careful about "extra" tyvars. Consider
+    (\C x -> d) : pat_ty -> res_ty
+When looking for existential escape we must check that the existential
+bound by C don't unify with the free variables of pat_ty, OR res_ty
+(or of course the environment).   Hence we need to keep track of the 
+res_ty free vars.
 
 
 %************************************************************************
@@ -175,73 +199,78 @@ patSigCtxt _                            = LamPatSigCtxt
 %************************************************************************
 
 \begin{code}
-tcPatBndr :: PatState -> Name -> BoxySigmaType -> TcM TcId
-tcPatBndr (PS { pat_ctxt = LetPat lookup_sig }) bndr_name pat_ty
-  | Just mono_ty <- lookup_sig bndr_name
-  = do	{ mono_name <- newLocalName bndr_name
-	; _ <- boxyUnify mono_ty pat_ty
-	; return (Id.mkLocalId mono_name mono_ty) }
-
+tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (CoercionI, TcId)
+-- (coi, xp) = tcPatBndr penv x pat_ty
+-- Then coi : pat_ty ~ typeof(xp)
+--
+tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty
+  | Just sig <- lookup_sig bndr_name
+  = do { bndr_id <- if no_gen then return (sig_id sig)
+                    else do { mono_name <- newLocalName bndr_name
+                            ; return (Id.mkLocalId mono_name (sig_tau sig)) }
+       ; coi <- unifyPatType (idType bndr_id) pat_ty
+       ; return (coi, bndr_id) }
+      
   | otherwise
-  = do	{ pat_ty' <- unBoxPatBndrType pat_ty bndr_name
-	; mono_name <- newLocalName bndr_name
-	; return (Id.mkLocalId mono_name pat_ty') }
-
-tcPatBndr (PS { pat_ctxt = _lam_or_proc }) bndr_name pat_ty
-  = do	{ pat_ty' <- unBoxPatBndrType pat_ty bndr_name
-		-- We have an undecorated binder, so we do rule ABS1,
-		-- by unboxing the boxy type, forcing any un-filled-in
-		-- boxes to become monotypes
-		-- NB that pat_ty' can still be a polytype:
-		-- 	data T = MkT (forall a. a->a)
-		-- 	f t = case t of { MkT g -> ... }
-		-- Here, the 'g' must get type (forall a. a->a) from the
-		-- MkT context
-	; return (Id.mkLocalId bndr_name pat_ty') }
+  = do { bndr_id <- newLetBndr no_gen bndr_name pat_ty
+       ; return (IdCo pat_ty, bndr_id) }
+
+tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty
+  = do { bndr <- mkLocalBinder bndr_name pat_ty
+       ; return (IdCo pat_ty, bndr) }
+
+newLetBndr :: Bool -> Name -> TcType -> TcM TcId
+-- In the polymorphic case (no_gen = False), generate a "monomorphic version" 
+--    of the Id; the original name will be bound to the polymorphic version
+--    by the AbsBinds
+-- In the monomorphic case there is no AbsBinds, and we use the original
+--    name directly
+newLetBndr no_gen name ty
+  | no_gen    = mkLocalBinder name ty
+  | otherwise = do { mono_name <- newLocalName name
+                   ; mkLocalBinder mono_name ty }
 
+-----------------
+mkLocalBinder :: Name -> TcType -> TcM TcId
+mkLocalBinder name ty
+  = do { checkUnboxedTuple ty $ 
+            ptext (sLit "The variable") <+> quotes (ppr name)
+       ; return (Id.mkLocalId name ty) }
+
+checkUnboxedTuple :: TcType -> SDoc -> TcM ()
+-- Check for an unboxed tuple type
+--      f = (# True, False #)
+-- Zonk first just in case it's hidden inside a meta type variable
+-- (This shows up as a (more obscure) kind error 
+--  in the 'otherwise' case of tcMonoBinds.)
+checkUnboxedTuple ty what
+  = do { zonked_ty <- zonkTcTypeCarefully ty
+       ; checkTc (not (isUnboxedTupleType zonked_ty))
+                 (unboxedTupleErr what zonked_ty) }
 
 -------------------
-bindInstsOfPatId :: TcId -> TcM a -> TcM (a, LHsBinds TcId)
+{- Only needed if we re-add Method constraints 
+bindInstsOfPatId :: TcId -> TcM a -> TcM (a, TcEvBinds)
 bindInstsOfPatId id thing_inside
   | not (isOverloadedTy (idType id))
-  = do { res <- thing_inside; return (res, emptyLHsBinds) }
+  = do { res <- thing_inside; return (res, emptyTcEvBinds) }
   | otherwise
-  = do	{ (res, lie) <- getLIE thing_inside
-	; binds <- bindInstsOfLocalFuns lie [id]
+  = do	{ (res, lie) <- getConstraints thing_inside
+	; binds <- bindLocalMethods lie [id]
 	; return (res, binds) }
-
--------------------
-unBoxPatBndrType :: BoxyType -> Name -> TcM TcType
-unBoxPatBndrType  ty name = unBoxArgType ty (ptext (sLit "The variable") <+> quotes (ppr name))
-
-unBoxWildCardType :: BoxyType -> TcM TcType
-unBoxWildCardType ty      = unBoxArgType ty (ptext (sLit "A wild-card pattern"))
-
-unBoxViewPatType :: BoxyType -> Pat Name -> TcM TcType
-unBoxViewPatType  ty pat  = unBoxArgType ty (ptext (sLit "The view pattern") <+> ppr pat)
-
-unBoxArgType :: BoxyType -> SDoc -> TcM TcType
--- In addition to calling unbox, unBoxArgType ensures that the type is of ArgTypeKind; 
--- that is, it can't be an unboxed tuple.  For example, 
---	case (f x) of r -> ...
--- should fail if 'f' returns an unboxed tuple.
-unBoxArgType ty pp_this
-  = do	{ ty' <- unBox ty	-- Returns a zonked type
-
-	-- Neither conditional is strictly necesssary (the unify alone will do)
-	-- but they improve error messages, and allocate fewer tyvars
-	; if isUnboxedTupleType ty' then
-		failWithTc msg
-	  else if isSubArgTypeKind (typeKind ty') then
-		return ty'
-	  else do 	-- OpenTypeKind, so constrain it
-	{ ty2 <- newFlexiTyVarTy argTypeKind
-	; _ <- unifyType ty' ty2
-	; return ty' }}
-  where
-    msg = pp_this <+> ptext (sLit "cannot be bound to an unboxed tuple")
+-}
 \end{code}
 
+Note [Polymorphism and pattern bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When is_mono holds we are not generalising
+But the signature can still be polymoprhic!
+     data T = MkT (forall a. a->a)
+     x :: forall a. a->a
+     MkT x = <rhs>
+So the no_gen flag decides whether the pattern-bound variables should
+have exactly the type in the type signature (when not generalising) or
+the instantiated version (when generalising)
 
 %************************************************************************
 %*									*
@@ -258,135 +287,119 @@ pattern.
 
 This does not work so well for the ErrCtxt carried by the monad: we don't
 want the error-context for the pattern to scope over the RHS. 
-Hence the getErrCtxt/setErrCtxt stuff in tc_lpats.
+Hence the getErrCtxt/setErrCtxt stuff in tcMultiple
 
 \begin{code}
 --------------------
 type Checker inp out =  forall r.
 			  inp
-		       -> PatState
-		       -> (PatState -> TcM r)
-		       -> TcM (out, [TcTyVar], r)
+		       -> PatEnv
+		       -> TcM r
+		       -> TcM (out, r)
 
 tcMultiple :: Checker inp out -> Checker [inp] [out]
-tcMultiple tc_pat args pstate thing_inside
+tcMultiple tc_pat args penv thing_inside
   = do	{ err_ctxt <- getErrCtxt
-	; let loop pstate []
-		= do { res <- thing_inside pstate
-		     ; return ([], [], res) }
+	; let loop _ []
+		= do { res <- thing_inside
+		     ; return ([], res) }
 
-	      loop pstate (arg:args)
-		= do { (p', p_tvs, (ps', ps_tvs, res)) 
-				<- tc_pat arg pstate $ \ pstate' ->
+	      loop penv (arg:args)
+		= do { (p', (ps', res)) 
+				<- tc_pat arg penv $ 
 				   setErrCtxt err_ctxt $
-				   loop pstate' args
+				   loop penv args
 		-- setErrCtxt: restore context before doing the next pattern
 		-- See note [Nesting] above
 				
-		     ; return (p':ps', p_tvs ++ ps_tvs, res) }
+		     ; return (p':ps', res) }
 
-	; loop pstate args }
+	; loop penv args }
 
 --------------------
-tc_lpat_pr :: (LPat Name, BoxySigmaType)
-	   -> PatState
-	   -> (PatState -> TcM a)
-	   -> TcM (LPat TcId, [TcTyVar], a)
-tc_lpat_pr (pat, ty) = tc_lpat pat ty
-
 tc_lpat :: LPat Name 
-	-> BoxySigmaType
-	-> PatState
-	-> (PatState -> TcM a)
-	-> TcM (LPat TcId, [TcTyVar], a)
-tc_lpat (L span pat) pat_ty pstate thing_inside
+	-> TcSigmaType
+	-> PatEnv
+	-> TcM a
+	-> TcM (LPat TcId, a)
+tc_lpat (L span pat) pat_ty penv thing_inside
   = setSrcSpan span		  $
     maybeAddErrCtxt (patCtxt pat) $
-    do	{ (pat', tvs, res) <- tc_pat pstate pat pat_ty thing_inside
-	; return (L span pat', tvs, res) }
+    do	{ (pat', res) <- tc_pat penv pat pat_ty thing_inside
+	; return (L span pat', res) }
+
+tc_lpats :: PatEnv
+	 -> [LPat Name] -> [TcSigmaType]
+       	 -> TcM a	
+       	 -> TcM ([LPat TcId], a)
+tc_lpats penv pats tys thing_inside 
+  =  tcMultiple (\(p,t) -> tc_lpat p t) 
+                (zipEqual "tc_lpats" pats tys)
+                penv thing_inside 
 
 --------------------
-tc_pat	:: PatState
+tc_pat	:: PatEnv
         -> Pat Name 
-        -> BoxySigmaType	-- Fully refined result type
-        -> (PatState -> TcM a)	-- Thing inside
+        -> TcSigmaType	-- Fully refined result type
+        -> TcM a		-- Thing inside
         -> TcM (Pat TcId, 	-- Translated pattern
-                [TcTyVar], 	-- Existential binders
                 a)		-- Result of thing inside
 
-tc_pat pstate (VarPat name) pat_ty thing_inside
-  = do	{ id <- tcPatBndr pstate name pat_ty
+tc_pat penv (VarPat name) pat_ty thing_inside
+  = do	{ (coi, id) <- tcPatBndr penv name pat_ty
+    	; res <- tcExtendIdEnv1 name id thing_inside
+        ; return (mkHsWrapPatCoI coi (VarPat id) pat_ty, res) }
+
+{- Need this if we re-add Method constraints 
 	; (res, binds) <- bindInstsOfPatId id $
 			  tcExtendIdEnv1 name id $
 			  (traceTc (text "binding" <+> ppr name <+> ppr (idType id))
-			   >> thing_inside pstate)
-	; let pat' | isEmptyLHsBinds binds = VarPat id
-		   | otherwise		   = VarPatOut id binds
-	; return (pat', [], res) }
-
-tc_pat pstate (ParPat pat) pat_ty thing_inside
-  = do	{ (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside
-	; return (ParPat pat', tvs, res) }
-
-tc_pat pstate (BangPat pat) pat_ty thing_inside
-  = do	{ (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside
-	; return (BangPat pat', tvs, res) }
-
--- There's a wrinkle with irrefutable patterns, namely that we
--- must not propagate type refinement from them.  For example
---	data T a where { T1 :: Int -> T Int; ... }
---	f :: T a -> Int -> a
---	f ~(T1 i) y = y
--- It's obviously not sound to refine a to Int in the right
--- hand side, because the arugment might not match T1 at all!
---
--- Nor should a lazy pattern bind any existential type variables
--- because they won't be in scope when we do the desugaring
---
--- Note [Hopping the LIE in lazy patterns]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- In a lazy pattern, we must *not* discharge constraints from the RHS
--- from dictionaries bound in the pattern.  E.g.
---	f ~(C x) = 3
--- We can't discharge the Num constraint from dictionaries bound by
--- the pattern C!  
---
--- So we have to make the constraints from thing_inside "hop around" 
--- the pattern.  Hence the getLLE and extendLIEs later.
+			   >> thing_inside)
+	; let pat' | isEmptyTcEvBinds binds = VarPat id
+		   | otherwise		    = VarPatOut id binds
+	; return (mkHsWrapPatCoI coi pat' pat_ty, res) }
+-}
+
+tc_pat penv (ParPat pat) pat_ty thing_inside
+  = do	{ (pat', res) <- tc_lpat pat pat_ty penv thing_inside
+	; return (ParPat pat', res) }
+
+tc_pat penv (BangPat pat) pat_ty thing_inside
+  = do	{ (pat', res) <- tc_lpat pat pat_ty penv thing_inside
+	; return (BangPat pat', res) }
 
-tc_pat pstate lpat@(LazyPat pat) pat_ty thing_inside
-  = do	{ (pat', pat_tvs, (res,lie)) 
-		<- tc_lpat pat pat_ty pstate $ \ _ ->
-		   getLIE (thing_inside pstate)
-		-- Ignore refined pstate', revert to pstate
-	; extendLIEs lie
-	-- getLIE/extendLIEs: see Note [Hopping the LIE in lazy patterns]
+tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside
+  = do	{ (pat', (res, pat_ct)) 
+		<- tc_lpat pat pat_ty (makeLazy penv) $ 
+		   getConstraints thing_inside
+		-- Ignore refined penv', revert to penv
 
-	-- Check no existentials
-	; unless (null pat_tvs) $ lazyPatErr lpat pat_tvs
+	; emitConstraints pat_ct
+	-- getConstraints/extendConstraintss: see Note [Hopping the LIE in lazy patterns]
 
 	-- Check there are no unlifted types under the lazy pattern
 	; when (any (isUnLiftedType . idType) $ collectPatBinders pat') $
                lazyUnliftedPatErr lpat
 
-	-- Check that the pattern has a lifted type
-	; pat_tv <- newBoxyTyVar liftedTypeKind
-	; _ <- boxyUnify pat_ty (mkTyVarTy pat_tv)
+	-- Check that the expected pattern type is itself lifted
+	; pat_ty' <- newFlexiTyVarTy liftedTypeKind
+	; _ <- unifyType pat_ty pat_ty'
 
-	; return (LazyPat pat', [], res) }
+	; return (LazyPat pat', res) }
 
 tc_pat _ p@(QuasiQuotePat _) _ _
   = pprPanic "Should never see QuasiQuotePat in type checker" (ppr p)
 
-tc_pat pstate (WildPat _) pat_ty thing_inside
-  = do	{ pat_ty' <- unBoxWildCardType pat_ty	-- Make sure it's filled in with monotypes
-	; res <- thing_inside pstate
-	; return (WildPat pat_ty', [], res) }
+tc_pat _ (WildPat _) pat_ty thing_inside
+  = do	{ checkUnboxedTuple pat_ty $
+               ptext (sLit "A wild-card pattern")
+        ; res <- thing_inside 
+	; return (WildPat pat_ty, res) }
 
-tc_pat pstate (AsPat (L nm_loc name) pat) pat_ty thing_inside
-  = do	{ bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
-	; (pat', tvs, res) <- tcExtendIdEnv1 name bndr_id $
-			      tc_lpat pat (idType bndr_id) pstate thing_inside
+tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
+  = do	{ (coi, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
+	; (pat', res) <- tcExtendIdEnv1 name bndr_id $
+			 tc_lpat pat (idType bndr_id) penv thing_inside
 	    -- NB: if we do inference on:
 	    --		\ (y@(x::forall a. a->a)) = e
 	    -- we'll fail.  The as-pattern infers a monotype for 'y', which then
@@ -394,79 +407,65 @@ tc_pat pstate (AsPat (L nm_loc name) pat) pat_ty thing_inside
 	    -- perhaps be fixed, but only with a bit more work.
 	    --
 	    -- If you fix it, don't forget the bindInstsOfPatIds!
-	; return (AsPat (L nm_loc bndr_id) pat', tvs, res) }
+	; return (mkHsWrapPatCoI coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) }
 
-tc_pat pstate (orig@(ViewPat expr pat _)) overall_pat_ty thing_inside 
-  = do	{ -- morally, expr must have type
-         -- `forall a1...aN. OPT' -> B` 
+tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside 
+  = do	{ checkUnboxedTuple overall_pat_ty $
+               ptext (sLit "The view pattern") <+> ppr vpat
+
+	 -- Morally, expr must have type `forall a1...aN. OPT' -> B` 
          -- where overall_pat_ty is an instance of OPT'.
          -- Here, we infer a rho type for it,
          -- which replaces the leading foralls and constraints
          -- with fresh unification variables.
-         (expr',expr'_inferred) <- tcInferRho expr
+        ; (expr',expr'_inferred) <- tcInferRho expr
+
          -- next, we check that expr is coercible to `overall_pat_ty -> pat_ty`
-       ; let expr'_expected = \ pat_ty -> (mkFunTy overall_pat_ty pat_ty)
-         -- tcSubExp: expected first, offered second
-         -- returns coercion
-         -- 
          -- NOTE: this forces pat_ty to be a monotype (because we use a unification 
          -- variable to find it).  this means that in an example like
          -- (view -> f)    where view :: _ -> forall b. b
          -- we will only be able to use view at one instantation in the
          -- rest of the view
-	; (expr_coerc, pat_ty) <- tcInfer $ \ pat_ty -> 
-		tcSubExp ViewPatOrigin (expr'_expected pat_ty) expr'_inferred
+	; (expr_coi, pat_ty) <- tcInfer $ \ pat_ty -> 
+		unifyPatType expr'_inferred (mkFunTy overall_pat_ty pat_ty)
 
          -- pattern must have pat_ty
-       ; (pat', tvs, res) <- tc_lpat pat pat_ty pstate thing_inside
-         -- this should get zonked later on, but we unBox it here
-         -- so that we do the same checks as above
-	; annotation_ty <- unBoxViewPatType overall_pat_ty orig        
-	; return (ViewPat (mkLHsWrap expr_coerc expr') pat' annotation_ty, tvs, res) }
+        ; (pat', res) <- tc_lpat pat pat_ty penv thing_inside
+
+	; return (ViewPat (mkLHsWrapCoI expr_coi expr') pat' overall_pat_ty, res) }
 
 -- Type signatures in patterns
 -- See Note [Pattern coercions] below
-tc_pat pstate (SigPatIn pat sig_ty) pat_ty thing_inside
-  = do	{ (inner_ty, tv_binds, coi) <- tcPatSig (patSigCtxt pstate) sig_ty 
-                                                                    pat_ty
-        ; unless (isIdentityCoI coi) $ 
-            failWithTc (badSigPat pat_ty)
-	; (pat', tvs, res) <- tcExtendTyVarEnv2 tv_binds $
-			      tc_lpat pat inner_ty pstate thing_inside
-        ; return (SigPatOut pat' inner_ty, tvs, res) }
-
--- Use this when we add pattern coercions back in
---	  return (mkCoPatCoI (mkSymCoI coi) (SigPatOut pat' inner_ty) pat_ty
---                 , tvs, res) }
+tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside
+  = do	{ (inner_ty, tv_binds, wrap) <- tcPatSig (patSigCtxt penv) sig_ty pat_ty
+	; (pat', res) <- tcExtendTyVarEnv2 tv_binds $
+			 tc_lpat pat inner_ty penv thing_inside
+
+        ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) }
 
 tc_pat _ pat@(TypePat _) _ _
   = failWithTc (badTypePat pat)
 
 ------------------------
 -- Lists, tuples, arrays
-tc_pat pstate (ListPat pats _) pat_ty thing_inside
-  = do	{ (elt_ty, coi) <- boxySplitListTy pat_ty
-        ; let scoi = mkSymCoI coi
-	; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
-					 	pats pstate thing_inside
- 	; return (mkCoPatCoI scoi (ListPat pats' elt_ty) pat_ty, pats_tvs, res) 
+tc_pat penv (ListPat pats _) pat_ty thing_inside
+  = do	{ (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy pat_ty
+        ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty)
+				     pats penv thing_inside
+ 	; return (mkHsWrapPat coi (ListPat pats' elt_ty) pat_ty, res) 
         }
 
-tc_pat pstate (PArrPat pats _) pat_ty thing_inside
-  = do	{ (elt_ty, coi) <- boxySplitPArrTy pat_ty
-        ; let scoi = mkSymCoI coi
-	; (pats', pats_tvs, res) <- tcMultiple (\p -> tc_lpat p elt_ty)
-						pats pstate thing_inside 
-	; when (null pats) (zapToMonotype pat_ty >> return ())  -- c.f. ExplicitPArr in TcExpr
-	; return (mkCoPatCoI scoi (PArrPat pats' elt_ty) pat_ty, pats_tvs, res)
+tc_pat penv (PArrPat pats _) pat_ty thing_inside
+  = do	{ (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy pat_ty
+	; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty)
+				     pats penv thing_inside 
+	; return (mkHsWrapPat coi (PArrPat pats' elt_ty) pat_ty, res)
         }
 
-tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
+tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside
   = do	{ let tc = tupleTyCon boxity (length pats)
-        ; (arg_tys, coi) <- boxySplitTyConApp tc pat_ty
-        ; let scoi = mkSymCoI coi
-	; (pats', pats_tvs, res) <- tcMultiple tc_lpat_pr (pats `zip` arg_tys)
-					       pstate thing_inside
+        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc) pat_ty
+	; (pats', res) <- tc_lpats penv pats arg_tys thing_inside
 
 	-- Under flag control turn a pattern (x,y,z) into ~(x,y,z)
 	-- so that we can experiment with lazy tuple-matching.
@@ -481,34 +480,29 @@ tc_pat pstate (TuplePat pats boxity _) pat_ty thing_inside
 	        | otherwise		    = unmangled_result
 
  	; ASSERT( length arg_tys == length pats )      -- Syntactically enforced
-	  return (mkCoPatCoI scoi possibly_mangled_result pat_ty, pats_tvs, res)
+	  return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
         }
 
 ------------------------
 -- Data constructors
-tc_pat pstate (ConPatIn (L con_span con_name) arg_pats) pat_ty thing_inside
-  = do	{ data_con <- tcLookupDataCon con_name
-	; let tycon = dataConTyCon data_con
-	; tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside }
+tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside
+  = tcConPat penv con pat_ty arg_pats thing_inside
 
 ------------------------
 -- Literal patterns
-tc_pat pstate (LitPat simple_lit) pat_ty thing_inside
+tc_pat _ (LitPat simple_lit) pat_ty thing_inside
   = do	{ let lit_ty = hsLitType simple_lit
-	; coi <- boxyUnify lit_ty pat_ty
-			-- coi is of kind: lit_ty ~ pat_ty
-	; res <- thing_inside pstate
-			-- pattern coercions have to
-			-- be of kind: pat_ty ~ lit_ty
-			-- hence, sym coi
-	; return (mkCoPatCoI (mkSymCoI coi) (LitPat simple_lit) pat_ty, 
-                   [], res) }
+	; coi <- unifyPatType lit_ty pat_ty
+		-- coi is of kind: pat_ty ~ lit_ty
+	; res <- thing_inside 
+	; return ( mkHsWrapPatCoI coi (LitPat simple_lit) pat_ty 
+                 , res) }
 
 ------------------------
 -- Overloaded patterns: n, and n+k
-tc_pat pstate (NPat over_lit mb_neg eq) pat_ty thing_inside
+tc_pat _ (NPat over_lit mb_neg eq) pat_ty thing_inside
   = do	{ let orig = LiteralOrigin over_lit
-	; lit'    <- tcOverloadedLit orig over_lit pat_ty
+	; lit'    <- newOverloadedLit orig over_lit pat_ty
 	; eq'     <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy)
 	; mb_neg' <- case mb_neg of
 			Nothing  -> return Nothing	-- Positive literal
@@ -516,30 +510,63 @@ tc_pat pstate (NPat over_lit mb_neg eq) pat_ty thing_inside
 					-- The 'negate' is re-mappable syntax
  			    do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty)
 			       ; return (Just neg') }
-	; res <- thing_inside pstate
-	; return (NPat lit' mb_neg' eq', [], res) }
+	; res <- thing_inside 
+	; return (NPat lit' mb_neg' eq', res) }
 
-tc_pat pstate (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
-  = do	{ bndr_id <- setSrcSpan nm_loc (tcPatBndr pstate name pat_ty)
+tc_pat penv (NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
+  = do	{ (coi, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
  	; let pat_ty' = idType bndr_id
 	      orig    = LiteralOrigin lit
-	; lit' <- tcOverloadedLit orig lit pat_ty'
+	; lit' <- newOverloadedLit orig lit pat_ty'
 
 	-- The '>=' and '-' parts are re-mappable syntax
 	; ge'    <- tcSyntaxOp orig ge    (mkFunTys [pat_ty', pat_ty'] boolTy)
 	; minus' <- tcSyntaxOp orig minus (mkFunTys [pat_ty', pat_ty'] pat_ty')
+        ; let pat' = NPlusKPat (L nm_loc bndr_id) lit' ge' minus'
 
 	-- The Report says that n+k patterns must be in Integral
 	-- We may not want this when using re-mappable syntax, though (ToDo?)
 	; icls <- tcLookupClass integralClassName
 	; instStupidTheta orig [mkClassPred icls [pat_ty']]	
     
-	; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
-	; return (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
+	; res <- tcExtendIdEnv1 name bndr_id thing_inside
+	; return (mkHsWrapPatCoI coi pat' pat_ty, res) }
 
 tc_pat _ _other_pat _ _ = panic "tc_pat" 	-- ConPatOut, SigPatOut, VarPatOut
+
+----------------
+unifyPatType :: TcType -> TcType -> TcM CoercionI
+-- In patterns we want a coercion from the
+-- context type (expected) to the actual pattern type
+-- But we don't want to reverse the args to unifyType because
+-- that controls the actual/expected stuff in error messages
+unifyPatType actual_ty expected_ty
+  = do { coi <- unifyType actual_ty expected_ty
+       ; return (mkSymCoI coi) }
 \end{code}
 
+Note [Hopping the LIE in lazy patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a lazy pattern, we must *not* discharge constraints from the RHS
+from dictionaries bound in the pattern.  E.g.
+	f ~(C x) = 3
+We can't discharge the Num constraint from dictionaries bound by
+the pattern C!  
+
+So we have to make the constraints from thing_inside "hop around" 
+the pattern.  Hence the getConstraints and emitConstraints.
+
+The same thing ensures that equality constraints in a lazy match
+are not made available in the RHS of the match. For example
+	data T a where { T1 :: Int -> T Int; ... }
+	f :: T a -> Int -> a
+	f ~(T1 i) y = y
+It's obviously not sound to refine a to Int in the right
+hand side, because the arugment might not match T1 at all!
+
+Finally, a lazy pattern should not bind any existential type variables
+because they won't be in scope when we do the desugaring
+
 
 %************************************************************************
 %*									*
@@ -606,75 +633,61 @@ to express the local scope of GADT refinements.
 -- MkT :: forall a b c. (a~[b]) => b -> c -> T a
 -- 	 with scrutinee of type (T ty)
 
-tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon 
-	 -> BoxySigmaType	-- Type of the pattern
-	 -> HsConPatDetails Name -> (PatState -> TcM a)
-	 -> TcM (Pat TcId, [TcTyVar], a)
-tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
-  = do	{ let (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _)
+tcConPat :: PatEnv -> Located Name 
+	 -> TcRhoType  	       	-- Type of the pattern
+	 -> HsConPatDetails Name -> TcM a
+	 -> TcM (Pat TcId, a)
+tcConPat penv (L con_span con_name) pat_ty arg_pats thing_inside
+  = do	{ data_con <- tcLookupDataCon con_name
+	; let tycon = dataConTyCon data_con
+         	  -- For data families this is the representation tycon
+	      (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _)
                 = dataConFullSig data_con
-	      skol_info  = PatSkol data_con
-	      origin     = SigOrigin skol_info
-	      full_theta = eq_theta ++ dict_theta
 
 	  -- Instantiate the constructor type variables [a->ty]
-	  -- This may involve doing a family-instance coercion, and building a
-	  -- wrapper 
-	; (ctxt_res_tys, coi, unwrap_ty) <- boxySplitTyConAppWithFamily tycon 
-                                                                        pat_ty
-        ; let sym_coi = mkSymCoI coi  -- boxy split coercion oriented wrongly
-	      pat_ty' = mkTyConApp tycon ctxt_res_tys
-                                      -- pat_ty' /= pat_ty iff coi /= IdCo
-              
-              wrap_res_pat res_pat = mkCoPatCoI sym_coi uwScrut pat_ty
-                where
-                  uwScrut = unwrapFamInstScrutinee tycon ctxt_res_tys
-                                                   unwrap_ty res_pat
+	  -- This may involve doing a family-instance coercion, 
+	  -- and building a wrapper 
+	; (wrap, ctxt_res_tys) <- matchExpectedPatTy (matchExpectedConTy tycon) pat_ty
 
 	  -- Add the stupid theta
 	; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys
 
+	; checkExistentials ex_tvs penv 
+        ; let skol_info = case pe_ctxt penv of
+                            LamPat mc -> PatSkol data_con mc
+                            LetPat {} -> UnkSkol -- Doesn't matter
 	; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs	
                      -- Get location from monad, not from ex_tvs
 
-	; let tenv     = zipTopTvSubst (univ_tvs ++ ex_tvs)
+        ; let pat_ty' = mkTyConApp tycon ctxt_res_tys
+	      -- pat_ty' is type of the actual constructor application
+              -- pat_ty' /= pat_ty iff coi /= IdCo
+              
+	      tenv     = zipTopTvSubst (univ_tvs     ++ ex_tvs)
 				       (ctxt_res_tys ++ mkTyVarTys ex_tvs')
 	      arg_tys' = substTys tenv arg_tys
+	      full_theta = eq_theta ++ dict_theta
 
 	; if null ex_tvs && null eq_spec && null full_theta
 	  then do { -- The common case; no class bindings etc 
                     -- (see Note [Arrows and patterns])
-		    (arg_pats', inner_tvs, res) <- tcConArgs data_con arg_tys' 
-						    arg_pats pstate thing_inside
+		    (arg_pats', res) <- tcConArgs data_con arg_tys' 
+						  arg_pats penv thing_inside
 		  ; let res_pat = ConPatOut { pat_con = L con_span data_con, 
 			            	      pat_tvs = [], pat_dicts = [], 
-                                              pat_binds = emptyLHsBinds,
+                                              pat_binds = emptyTcEvBinds,
 					      pat_args = arg_pats', 
                                               pat_ty = pat_ty' }
 
-		    ; return (wrap_res_pat res_pat, inner_tvs, res) }
-
-	  else do   -- The general case, with existential, and local equality 
-                    -- constraints
-	{ checkTc (notProcPat (pat_ctxt pstate))
-		  (existentialProcPat data_con)
-		  -- See Note [Arrows and patterns]
-
-          -- Need to test for rigidity if *any* constraints in theta as class
-          -- constraints may have superclass equality constraints.  However,
-          -- we don't want to check for rigidity if we got here only because
-          -- ex_tvs was non-null.
---        ; unless (null theta') $
-          -- FIXME: AT THE MOMENT WE CHEAT!  We only perform the rigidity test
-          --   if we explicitly or implicitly (by a GADT def) have equality 
-          --   constraints.
-        ; let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
+		  ; return (mkHsWrapPat wrap res_pat pat_ty, res) }
+
+	  else do   -- The general case, with existential, 
+                    -- and local equality constraints
+	{ let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec]
 	      theta'   = substTheta tenv (eq_preds ++ full_theta)
                            -- order is *important* as we generate the list of
                            -- dictionary binders from theta'
 	      no_equalities = not (any isEqPred theta')
-	      pstate' | no_equalities = pstate
-		      | otherwise     = pstate { pat_eqs = True }
 
         ; gadts_on <- doptM Opt_GADTs
 	; checkTc (no_equalities || gadts_on)
@@ -682,107 +695,140 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 		  -- Trac #2905 decided that a *pattern-match* of a GADT
 		  -- should require the GADT language flag
 
-	; unless no_equalities $ checkTc (isRigidTy pat_ty) $
-                                 nonRigidMatch (pat_ctxt pstate) data_con
-
-	; ((arg_pats', inner_tvs, res), lie_req) <- getLIE $
-		tcConArgs data_con arg_tys' arg_pats pstate' thing_inside
+	; given <- newEvVars theta'
+        ; let free_tvs = pe_res_tvs penv
+		-- Since we have done checkExistentials,
+		-- pe_res_tvs can only be Just at this point
+		--
+		-- Nor do we need pat_ty, because we've put all the
+		-- unification variables in right at the start when
+		-- initialising the PatEnv; and the pattern itself
+		-- only adds skolems.
+
+        ; (ev_binds, (arg_pats', res))
+	     <- checkConstraints skol_info free_tvs ex_tvs' given $
+                tcConArgs data_con arg_tys' arg_pats penv thing_inside
+
+        ; let res_pat = ConPatOut { pat_con   = L con_span data_con, 
+			            pat_tvs   = ex_tvs',
+			            pat_dicts = given,
+			            pat_binds = ev_binds,
+			            pat_args  = arg_pats', 
+                                    pat_ty    = pat_ty' }
+	; return (mkHsWrapPat wrap res_pat pat_ty, res)
+	} }
 
-	; loc <- getInstLoc origin
-	; dicts <- newDictBndrs loc theta'
-	; dict_binds <- tcSimplifyCheckPat loc ex_tvs' dicts lie_req
+----------------------------
+matchExpectedPatTy :: (TcRhoType -> TcM (CoercionI, a))
+                    -> TcRhoType -> TcM (HsWrapper, a) 
+-- See Note [Matching polytyped patterns]
+-- Returns a wrapper : pat_ty ~ inner_ty
+matchExpectedPatTy inner_match pat_ty
+  | null tvs && null theta
+  = do { (coi, res) <- inner_match pat_ty
+       ; return (coiToHsWrapper (mkSymCoI coi), res) }
+       	 -- The Sym is because the inner_match returns a coercion
+	 -- that is the other way round to matchExpectedPatTy
 
-        ; let res_pat = ConPatOut { pat_con = L con_span data_con, 
-			            pat_tvs = ex_tvs',
-			            pat_dicts = map instToVar dicts, 
-			            pat_binds = dict_binds,
-			            pat_args = arg_pats', pat_ty = pat_ty' }
-	; return (wrap_res_pat res_pat, ex_tvs' ++ inner_tvs, res)
-	} }
+  | otherwise
+  = do { (_, tys, subst) <- tcInstTyVars tvs
+       ; wrap1 <- instCall PatOrigin tys (substTheta subst theta)
+       ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (substTy subst tau)
+       ; return (wrap2 <.> wrap1 , arg_tys) }
   where
-    -- Split against the family tycon if the pattern constructor 
-    -- belongs to a family instance tycon.
-    boxySplitTyConAppWithFamily tycon pat_ty =
-      traceTc traceMsg >>
-      case tyConFamInst_maybe tycon of
-        Nothing                   -> 
-          do { (scrutinee_arg_tys, coi1) <- boxySplitTyConApp tycon pat_ty
-             ; return (scrutinee_arg_tys, coi1, pat_ty)
-             }
-	Just (fam_tycon, instTys) -> 
-	  do { (scrutinee_arg_tys, coi1) <- boxySplitTyConApp fam_tycon pat_ty
-	     ; (_, freshTvs, subst) <- tcInstTyVars (tyConTyVars tycon)
-             ; let instTys' = substTys subst instTys
-	     ; cois <- boxyUnifyList instTys' scrutinee_arg_tys
-             ; let coi = if isIdentityCoI coi1
-                         then  -- pat_ty was splittable
-                               -- => boxyUnifyList had real work to do
-                           mkTyConAppCoI fam_tycon instTys' cois
-                         else  -- pat_ty was not splittable
-                               -- => scrutinee_arg_tys are fresh tvs and
-                               --    boxyUnifyList just instantiated those
-                           coi1
-	     ; return (freshTvs, coi, mkTyConApp fam_tycon instTys')
-                                      -- this is /= pat_ty 
-                                      -- iff cois is non-trivial
-	     }
-      where
-        traceMsg = sep [ text "tcConPat:boxySplitTyConAppWithFamily:" <+>
-		         ppr tycon <+> ppr pat_ty
-		       , text "  family instance:" <+> 
-			 ppr (tyConFamInst_maybe tycon)
-                       ]
-
-    -- Wraps the pattern (which must be a ConPatOut pattern) in a coercion
-    -- pattern if the tycon is an instance of a family.
-    --
-    unwrapFamInstScrutinee :: TyCon -> [Type] -> Type -> Pat Id -> Pat Id
-    unwrapFamInstScrutinee tycon args unwrap_ty pat
-      | Just co_con <- tyConFamilyCoercion_maybe tycon 
---      , not (isNewTyCon tycon)       -- newtypes are explicitly unwrapped by
-				     -- the desugarer
-          -- NB: We can use CoPat directly, rather than mkCoPat, as we know the
-          --	 coercion is not the identity; mkCoPat is inconvenient as it
-          --	 wants a located pattern.
-      = CoPat (WpCast $ mkTyConApp co_con args)       -- co fam ty to repr ty
-	      (pat {pat_ty = mkTyConApp tycon args})    -- representation type
-	      unwrap_ty					-- family inst type
-      | otherwise
-      = pat
+    (tvs, theta, tau) = tcSplitSigmaTy pat_ty
+
+----------------------------
+matchExpectedConTy :: TyCon  	 -- The TyCon that this data 
+		    		 -- constructor actually returns
+		   -> TcRhoType  -- The type of the pattern
+		   -> TcM (CoercionI, [TcSigmaType])
+-- See Note [Matching constructor patterns]
+-- Returns a coercion : T ty1 ... tyn ~ pat_ty
+-- This is the same way round as matchExpectedListTy etc
+-- but the other way round to matchExpectedPatTy
+matchExpectedConTy data_tc pat_ty
+  | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
+    	 -- Comments refer to Note [Matching constructor patterns]
+     	 -- co_tc :: forall a. T [a] ~ T7 a
+  = do { (_, tys, subst) <- tcInstTyVars (tyConTyVars data_tc)
+       	     -- tys = [ty1,ty2]
+
+       ; coi1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty
+       	     -- coi1 : T (ty1,ty2) ~ pat_ty
+
+       ; let coi2 = ACo (mkTyConApp co_tc tys)
+       	     -- coi2 : T (ty1,ty2) ~ T7 ty1 ty2
+
+       ; return (mkTransCoI (mkSymCoI coi2) coi1, tys) }
+
+  | otherwise
+  = matchExpectedTyConApp data_tc pat_ty
+       	     -- coi : T tys ~ pat_ty
+\end{code}
+
+Noate [
+Note [Matching constructor patterns]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose (coi, tys) = matchExpectedConType data_tc pat_ty
+
+ * In the simple case, pat_ty = tc tys
+
+ * If pat_ty is a polytype, we want to instantiate it
+   This is like part of a subsumption check.  Eg
+      f :: (forall a. [a]) -> blah
+      f [] = blah
+
+ * In a type family case, suppose we have
+          data family T a
+          data instance T (p,q) = A p | B q
+       Then we'll have internally generated
+              data T7 p q = A p | B q
+              axiom coT7 p q :: T (p,q) ~ T7 p q
+ 
+       So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that
+           coi = coi2 . coi1 : T7 t ~ pat_ty
+           coi1 : T (ty1,ty2) ~ pat_ty
+           coi2 : T7 ty1 ty2 ~ T (ty1,ty2)
+
+   For families we do all this matching here, not in the unifier,
+   because we never want a whisper of the data_tycon to appear in
+   error messages; it's a purely internal thing
 
+\begin{code}
 tcConArgs :: DataCon -> [TcSigmaType]
 	  -> Checker (HsConPatDetails Name) (HsConPatDetails Id)
 
-tcConArgs data_con arg_tys (PrefixCon arg_pats) pstate thing_inside
+tcConArgs data_con arg_tys (PrefixCon arg_pats) penv thing_inside
   = do	{ checkTc (con_arity == no_of_args)	-- Check correct arity
 		  (arityErr "Constructor" data_con con_arity no_of_args)
 	; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys
-	; (arg_pats', tvs, res) <- tcMultiple tcConArg pats_w_tys
-					      pstate thing_inside 
-	; return (PrefixCon arg_pats', tvs, res) }
+	; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys
+					      penv thing_inside 
+	; return (PrefixCon arg_pats', res) }
   where
     con_arity  = dataConSourceArity data_con
     no_of_args = length arg_pats
 
-tcConArgs data_con arg_tys (InfixCon p1 p2) pstate thing_inside
+tcConArgs data_con arg_tys (InfixCon p1 p2) penv thing_inside
   = do	{ checkTc (con_arity == 2)	-- Check correct arity
 	 	  (arityErr "Constructor" data_con con_arity 2)
 	; let [arg_ty1,arg_ty2] = arg_tys	-- This can't fail after the arity check
-	; ([p1',p2'], tvs, res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]
-					      pstate thing_inside
-	; return (InfixCon p1' p2', tvs, res) }
+	; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]
+					      penv thing_inside
+	; return (InfixCon p1' p2', res) }
   where
     con_arity  = dataConSourceArity data_con
 
-tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) pstate thing_inside
-  = do	{ (rpats', tvs, res) <- tcMultiple tc_field rpats pstate thing_inside
-	; return (RecCon (HsRecFields rpats' dd), tvs, res) }
+tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
+  = do	{ (rpats', res) <- tcMultiple tc_field rpats penv thing_inside
+	; return (RecCon (HsRecFields rpats' dd), res) }
   where
     tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
-    tc_field (HsRecField field_lbl pat pun) pstate thing_inside
+    tc_field (HsRecField field_lbl pat pun) penv thing_inside
       = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
-	   ; (pat', tvs, res) <- tcConArg (pat, pat_ty) pstate thing_inside
-	   ; return (HsRecField sel_id pat' pun, tvs, res) }
+	   ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
+	   ; return (HsRecField sel_id pat' pun, res) }
 
     find_field_ty :: FieldLabel -> TcM (Id, TcType)
     find_field_ty field_lbl
@@ -812,9 +858,9 @@ tcConArgs data_con arg_tys (RecCon (HsRecFields rpats dd)) pstate thing_inside
 	-- dataConFieldLabels will be empty (and each field in the pattern
 	-- will generate an error below).
 
-tcConArg :: Checker (LPat Name, BoxySigmaType) (LPat Id)
-tcConArg (arg_pat, arg_ty) pstate thing_inside
-  = tc_lpat arg_pat arg_ty pstate thing_inside
+tcConArg :: Checker (LPat Name, TcSigmaType) (LPat Id)
+tcConArg (arg_pat, arg_ty) penv thing_inside
+  = tc_lpat arg_pat arg_ty penv thing_inside
 \end{code}
 
 \begin{code}
@@ -837,8 +883,8 @@ addDataConStupidTheta data_con inst_tys
 
 Note [Arrows and patterns]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~
-(Oct 07) Arrow noation has the odd property that it involves "holes in the scope". 
-For example:
+(Oct 07) Arrow noation has the odd property that it involves 
+"holes in the scope". For example:
   expr :: Arrow a => a () Int
   expr = proc (y,z) -> do
           x <- term -< y
@@ -859,57 +905,6 @@ constraints. Hence the 'fast path' in tcConPat; but it's also a good
 plan for ordinary vanilla patterns to bypass the constraint
 simplification step.
 
-
-%************************************************************************
-%*									*
-		Overloaded literals
-%*									*
-%************************************************************************
-
-In tcOverloadedLit we convert directly to an Int or Integer if we
-know that's what we want.  This may save some time, by not
-temporarily generating overloaded literals, but it won't catch all
-cases (the rest are caught in lookupInst).
-
-\begin{code}
-tcOverloadedLit :: InstOrigin
-		 -> HsOverLit Name
-		 -> BoxyRhoType
-		 -> TcM (HsOverLit TcId)
-tcOverloadedLit orig lit@(OverLit { ol_val = val, ol_rebindable = rebindable
-				  , ol_witness = meth_name }) res_ty
-  | rebindable
-	-- Do not generate a LitInst for rebindable syntax.  
-	-- Reason: If we do, tcSimplify will call lookupInst, which
-	--	   will call tcSyntaxName, which does unification, 
-	--	   which tcSimplify doesn't like
-	-- ToDo: noLoc sadness
-  = do	{ hs_lit <- mkOverLit val
-	; let lit_ty = hsLitType hs_lit
-	; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
-	 	-- Overloaded literals must have liftedTypeKind, because
-	 	-- we're instantiating an overloaded function here,
-	 	-- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
-		-- However this'll be picked up by tcSyntaxOp if necessary
-	; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
-	; return (lit { ol_witness = witness, ol_type = res_ty }) }
-
-  | Just expr <- shortCutLit val res_ty 
-  = return (lit { ol_witness = expr, ol_type = res_ty })
-
-  | otherwise
-  = do 	{ loc <- getInstLoc orig
-	; res_tau <- zapToMonotype res_ty
-	; new_uniq <- newUnique
-	; let	lit_nm   = mkSystemVarName new_uniq (fsLit "lit")
-		lit_inst = LitInst {tci_name = lit_nm, tci_lit = lit, 
-				    tci_ty = res_tau, tci_loc = loc}
-		witness = HsVar (instToId lit_inst)
-	; extendLIE lit_inst
-	; return (lit { ol_witness = witness, ol_type = res_ty }) }
-\end{code}
-
-
 %************************************************************************
 %*									*
 		Note [Pattern coercions]
@@ -977,23 +972,8 @@ Meanwhile, the strategy is:
 %*									*
 %************************************************************************
 
-\begin{code}
-patCtxt :: Pat Name -> Maybe Message	-- Not all patterns are worth pushing a context
-patCtxt (VarPat _)  = Nothing
-patCtxt (ParPat _)  = Nothing
-patCtxt (AsPat _ _) = Nothing
-patCtxt pat 	    = Just (hang (ptext (sLit "In the pattern:")) 
-			       4 (ppr pat))
-
------------------------------------------------
-
-existentialExplode :: LPat Name -> SDoc
-existentialExplode pat
-  = hang (vcat [text "My brain just exploded.",
-	        text "I can't handle pattern bindings for existential or GADT data constructors.",
-	        text "Instead, use a case-expression, or do-notation, to unpack the constructor.",
-		text "In the binding group for"])
-	4 (ppr pat)
+{-   This was used to improve the error message from 
+     an existential escape. Need to think how to do this.
 
 sigPatCtxt :: [LPat Var] -> [Var] -> [TcType] -> TcType -> TidyEnv
            -> TcM (TidyEnv, SDoc)
@@ -1005,7 +985,7 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
 	      (env3, tidy_body_ty) = tidyOpenType  env2 body_ty'
 	; return (env3,
 		 sep [ptext (sLit "When checking an existential match that binds"),
-		      nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
+		      nest 2 (vcat (zipWith ppr_id show_ids tidy_tys)),
 		      ptext (sLit "The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
 		      ptext (sLit "The body has type:") <+> ppr tidy_body_ty
 		]) }
@@ -1016,6 +996,39 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
 
     ppr_id id ty = ppr id <+> dcolon <+> ppr ty
 	-- Don't zonk the types so we get the separate, un-unified versions
+-}
+
+\begin{code}
+patCtxt :: Pat Name -> Maybe Message	-- Not all patterns are worth pushing a context
+patCtxt (VarPat _)  = Nothing
+patCtxt (ParPat _)  = Nothing
+patCtxt (AsPat _ _) = Nothing
+patCtxt pat 	    = Just (hang (ptext (sLit "In the pattern:")) 
+                         2 (ppr pat))
+
+-----------------------------------------------
+checkExistentials :: [TyVar] -> PatEnv -> TcM ()
+	  -- See Note [Arrows and patterns]
+checkExistentials [] _                                 = return ()
+checkExistentials _ (PE { pe_ctxt = LetPat {}})        = failWithTc existentialLetPat
+checkExistentials _ (PE { pe_ctxt = LamPat ProcExpr }) = failWithTc existentialProcPat
+checkExistentials _ (PE { pe_lazy = True })            = failWithTc existentialLazyPat
+checkExistentials _ _                                  = return ()
+
+existentialLazyPat :: SDoc
+existentialLazyPat
+  = hang (ptext (sLit "An existential or GADT data constructor cannot be used"))
+       2 (ptext (sLit "inside a lazy (~) pattern"))
+
+existentialProcPat :: SDoc
+existentialProcPat 
+  = ptext (sLit "Proc patterns cannot use existential or GADT data constructors")
+
+existentialLetPat :: SDoc
+existentialLetPat
+  = vcat [text "My brain just exploded",
+	  text "I can't handle pattern bindings for existential or GADT data constructors.",
+	  text "Instead, use a case-expression, or do-notation, to unpack the constructor."]
 
 badFieldCon :: DataCon -> Name -> SDoc
 badFieldCon con field
@@ -1027,54 +1040,17 @@ polyPatSig sig_ty
   = hang (ptext (sLit "Illegal polymorphic type signature in pattern:"))
        2 (ppr sig_ty)
 
-badSigPat :: TcType -> SDoc
-badSigPat pat_ty = ptext (sLit "Pattern signature must exactly match:") <+> 
-                   ppr pat_ty
-
 badTypePat :: Pat Name -> SDoc
 badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat
 
-existentialProcPat :: DataCon -> SDoc
-existentialProcPat con
-  = hang (ptext (sLit "Illegal constructor") <+> quotes (ppr con) <+> ptext (sLit "in a 'proc' pattern"))
-       2 (ptext (sLit "Proc patterns cannot use existentials or GADTs"))
-
-lazyPatErr :: Pat name -> [TcTyVar] -> TcM ()
-lazyPatErr _ tvs
-  = failWithTc $
-    hang (ptext (sLit "A lazy (~) pattern cannot match existential or GADT data constructors"))
-       2 (vcat (map pprSkolTvBinding tvs))
-
 lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM ()
 lazyUnliftedPatErr pat
   = failWithTc $
-    hang (ptext (sLit "A lazy (~) pattern cannot contain unlifted types"))
+    hang (ptext (sLit "A lazy (~) pattern cannot contain unlifted types:"))
        2 (ppr pat)
 
-nonRigidMatch :: PatCtxt -> DataCon -> SDoc
-nonRigidMatch ctxt con
-  =  hang (ptext (sLit "GADT pattern match in non-rigid context for") <+> quotes (ppr con))
-	2 (ptext (sLit "Probable solution: add a type signature for") <+> what ctxt)
-  where
-     what (APat (FunRhs f _)) = quotes (ppr f)
-     what (APat CaseAlt)      = ptext (sLit "the scrutinee of the case expression")
-     what (APat LambdaExpr )  = ptext (sLit "the lambda expression")
-     what (APat (StmtCtxt _)) = ptext (sLit "the right hand side of a do/comprehension binding")
-     what _other	      = ptext (sLit "something")
-
-nonRigidResult :: PatCtxt -> Type -> TcM a
-nonRigidResult ctxt res_ty
-  = do	{ env0 <- tcInitTidyEnv
-	; let (env1, res_ty') = tidyOpenType env0 res_ty
-	      msg = hang (ptext (sLit "GADT pattern match with non-rigid result type")
-				<+> quotes (ppr res_ty'))
-		  	 2 (ptext (sLit "Solution: add a type signature for")
-			   	  <+> what ctxt )
-	; failWithTcM (env1, msg) }
-  where
-     what (APat (FunRhs f _)) = quotes (ppr f)
-     what (APat CaseAlt)      = ptext (sLit "the entire case expression")
-     what (APat LambdaExpr)   = ptext (sLit "the lambda exression")
-     what (APat (StmtCtxt _)) = ptext (sLit "the entire do/comprehension expression")
-     what _other              = ptext (sLit "something")
+unboxedTupleErr :: SDoc -> Type -> SDoc
+unboxedTupleErr what ty
+  = hang (what <+> ptext (sLit "cannot have an unboxed tuple type:"))
+       2 (ppr ty)
 \end{code}
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index c4b3517..2200619 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -31,23 +31,23 @@ import TcHsSyn
 import TcExpr
 import TcRnMonad
 import Coercion
-import Inst
 import FamInst
 import InstEnv
 import FamInstEnv
 import TcAnnotations
 import TcBinds
+import TcType	( tidyTopType )
 import TcDefaults
 import TcEnv
 import TcRules
 import TcForeign
 import TcInstDcls
 import TcIface
+import TcMType
 import MkIface
 import IfaceSyn
 import TcSimplify
 import TcTyClsDecls
-import TcUnify	( withBox )
 import LoadIface
 import RnNames
 import RnEnv
@@ -72,12 +72,14 @@ import Outputable
 import DataCon
 import Type
 import Class
-import TcType
+import TcType   ( tyClsNamesOfDFunHead )
+import Inst	( tcGetInstEnvs )
 import Data.List ( sortBy )
 
 #ifdef GHCI
+import TcType   ( isUnitTy, isTauTy )
+import CoreUtils( mkPiTypes )
 import TcHsType
-import TcMType
 import TcMatches
 import RnTypes
 import RnExpr
@@ -362,11 +364,11 @@ tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
 	-- Reason: solely to report unused imports and bindings
 tcRnSrcDecls boot_iface decls
  = do {   	-- Do all the declarations
-	(tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ;
+	(tc_envs, lie) <- getConstraints $ tc_rn_src_decls boot_iface decls ;
 
 	     -- 	Finish simplifying class constraints
 	     -- 
-	     -- tcSimplifyTop deals with constant or ambiguous InstIds.  
+	     -- simplifyTop deals with constant or ambiguous InstIds.  
 	     -- How could there be ambiguous ones?  They can only arise if a
 	     -- top-level decl falls under the monomorphism restriction
 	     -- and no subsequent decl instantiates its type.
@@ -375,33 +377,36 @@ tcRnSrcDecls boot_iface decls
 	     -- thaat checkMain adds
 	     -- 
 	     -- We do it with both global and local env in scope:
-	     --	 * the global env exposes the instances to tcSimplifyTop
-	     --  * the local env exposes the local Ids to tcSimplifyTop, 
+	     --	 * the global env exposes the instances to simplifyTop
+	     --  * the local env exposes the local Ids to simplifyTop, 
 	     --    so that we get better error messages (monomorphism restriction)
-        traceTc (text "Tc8") ;
-	inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
+        traceTc "Tc8" empty ;
+	new_ev_binds <- setEnvs tc_envs (simplifyTop lie) ;
 
 	    -- Backsubstitution.  This must be done last.
-	    -- Even tcSimplifyTop may do some unification.
-        traceTc (text "Tc9") ;
+	    -- Even simplifyTop may do some unification.
+        traceTc "Tc9" empty ;
 	let { (tcg_env, _) = tc_envs
 	    ; TcGblEnv { tcg_type_env = type_env,
-		         tcg_binds = binds,
-		         tcg_rules = rules,
-		         tcg_fords = fords } = tcg_env
-	    ; all_binds = binds `unionBags` inst_binds } ;
+		         tcg_binds    = binds,
+		         tcg_ev_binds = cur_ev_binds,
+		         tcg_rules    = rules,
+		         tcg_fords    = fords } = tcg_env } ;
 
 	failIfErrsM ;	-- Don't zonk if there have been errors
 			-- It's a waste of time; and we may get debug warnings
 			-- about strangely-typed TyCons!
 
-	(bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
+        let { all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
+	(bind_ids, ev_binds', binds', fords', rules') 
+            <- zonkTopDecls all_ev_binds binds rules fords ;
 
 	
 	let { final_type_env = extendTypeEnvWithIds type_env bind_ids
-	    ; tcg_env' = tcg_env { tcg_binds = binds',
-				   tcg_rules = rules', 
-				   tcg_fords = fords' } } ;
+	    ; tcg_env' = tcg_env { tcg_binds    = binds',
+				   tcg_ev_binds = ev_binds',
+				   tcg_rules 	= rules', 
+				   tcg_fords 	= fords' } } ;
 
         setGlobalTypeEnv tcg_env' final_type_env				   
    }
@@ -463,7 +468,7 @@ tcRnHsBootDecls decls
    = do { (first_group, group_tail) <- findSplice decls
 
 		-- Rename the declarations
-	; (tcg_env, HsGroup { 
+        ; (tcg_env, HsGroup { 
 		   hs_tyclds = tycl_decls, 
 		   hs_instds = inst_decls,
 		   hs_derivds = deriv_decls,
@@ -472,7 +477,7 @@ tcRnHsBootDecls decls
 		   hs_ruleds = rule_decls, 
 		   hs_annds  = _,
 		   hs_valds  = val_binds }) <- rnTopSrcDecls first_group
-	; setGblEnv tcg_env $ do {
+	; (gbl_env, lie) <- getConstraints $ setGblEnv tcg_env $ do {
 
 
 		-- Check for illegal declarations
@@ -484,7 +489,7 @@ tcRnHsBootDecls decls
 	; mapM_ (badBootDecl "rule")    rule_decls
 
 		-- Typecheck type/class decls
-	; traceTc (text "Tc2")
+	; traceTc "Tc2" empty
 	; (tcg_env, aux_binds, dm_ids) 
                <- tcTyAndClassDecls emptyModDetails tycl_decls
 	; setGblEnv tcg_env    $ 
@@ -492,18 +497,18 @@ tcRnHsBootDecls decls
 
 		-- Typecheck instance decls
 		-- Family instance declarations are rejected here
-	; traceTc (text "Tc3")
+	; traceTc "Tc3" empty
 	; (tcg_env, inst_infos, _deriv_binds) 
             <- tcInstDecls1 tycl_decls inst_decls deriv_decls
 	; setGblEnv tcg_env	$ do {
 
 		-- Typecheck value declarations
-	; traceTc (text "Tc5") 
+	; traceTc "Tc5" empty 
 	; val_ids <- tcHsBootSigs val_binds
 
 		-- Wrap up
 		-- No simplification or zonking to do
-	; traceTc (text "Tc7a")
+	; traceTc "Tc7a" empty
 	; gbl_env <- getGblEnv 
 	
 		-- Make the final type-env
@@ -521,7 +526,8 @@ tcRnHsBootDecls decls
 	      }
 
 	; setGlobalTypeEnv gbl_env type_env3
-   }}}}
+   }}}
+   ; traceTc "boot" (ppr lie); return gbl_env }
 
 badBootDecl :: String -> Located decl -> TcM ()
 badBootDecl what (L loc _) 
@@ -552,8 +558,8 @@ checkHiBootIface
   = return tcg_env	
 
   | otherwise
-  = do	{ traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts $$ 
-				ppr boot_exports)) ;
+  = do	{ traceTc "checkHiBootIface" $ vcat
+             [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
 
 		-- Check the exports of the boot module, one by one
 	; mapM_ check_export boot_exports
@@ -703,8 +709,8 @@ checkBootTyCon tc1 tc2
     let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
         env = rnBndrs2 env0 tvs1 tvs2
 
-        eqSynRhs (OpenSynTyCon k1 _) (OpenSynTyCon k2 _)
-            = tcEqTypeX env k1 k2
+        eqSynRhs SynFamilyTyCon SynFamilyTyCon
+            = True
         eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
             = tcEqTypeX env t1 t2
         eqSynRhs _ _ = False
@@ -727,7 +733,7 @@ checkBootTyCon tc1 tc2
         env0 = mkRnEnv2 emptyInScopeSet
 
         eqAlgRhs AbstractTyCon _ = True
-        eqAlgRhs OpenTyCon{} OpenTyCon{} = True
+        eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
         eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
             eqListBy eqCon (data_cons tc1) (data_cons tc2)
         eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
@@ -793,7 +799,9 @@ rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 -- Fails if there are any errors
 rnTopSrcDecls group
  = do { -- Rename the source decls
+        traceTc "rn12" empty ;
 	(tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
+        traceTc "rn13" empty ;
 
         -- save the renamed syntax, if we want it
 	let { tcg_env'
@@ -821,7 +829,7 @@ tcTopSrcDecls boot_details
 		   hs_valds  = val_binds })
  = do {		-- Type-check the type and class decls, and all imported decls
 		-- The latter come in via tycl_decls
-        traceTc (text "Tc2") ;
+        traceTc "Tc2" empty ;
 
 	(tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ;
 		-- If there are any errors, tcTyAndClassDecls fails here
@@ -831,18 +839,18 @@ tcTopSrcDecls boot_details
 
 		-- Source-language instances, including derivings,
 		-- and import the supporting declarations
-        traceTc (text "Tc3") ;
+        traceTc "Tc3" empty ;
 	(tcg_env, inst_infos, deriv_binds) 
             <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
 	setGblEnv tcg_env	$ do {
 
 	        -- Foreign import declarations next. 
-        traceTc (text "Tc4") ;
+        traceTc "Tc4" empty ;
 	(fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
 	tcExtendGlobalValEnv fi_ids	$ do {
 
 		-- Default declarations
-        traceTc (text "Tc4a") ;
+        traceTc "Tc4a" empty ;
 	default_tys <- tcDefaults default_decls ;
 	updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 	
@@ -854,19 +862,18 @@ tcTopSrcDecls boot_details
 			 	     discardWarnings (tcTopBinds deriv_binds) ;
 
 		-- Value declarations next
-        traceTc (text "Tc5") ;
+        traceTc "Tc5" empty ;
 	(tc_val_binds, tcl_env) <- setLclTypeEnv tcl_env $
 			 	   tcTopBinds val_binds;
 
         setLclTypeEnv tcl_env $ do {	-- Environment doesn't change now
 
 	     	-- Second pass over class and instance declarations, 
-        traceTc (text "Tc6") ;
+        traceTc "Tc6" empty ;
 	inst_binds <- tcInstDecls2 tycl_decls inst_infos ;
-        showLIE (text "after instDecls2") ;
 
 		-- Foreign exports
-        traceTc (text "Tc7") ;
+        traceTc "Tc7" empty ;
 	(foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
 
                 -- Annotations
@@ -876,7 +883,7 @@ tcTopSrcDecls boot_details
 	rules <- tcRules rule_decls ;
 
 		-- Wrap up
-        traceTc (text "Tc7a") ;
+        traceTc "Tc7a" empty ;
 	tcg_env <- getGblEnv ;
 	let { all_binds = tc_val_binds	 `unionBags`
 			  tc_deriv_binds `unionBags`
@@ -913,7 +920,7 @@ checkMain
 check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv
 check_main dflags tcg_env
  | mod /= main_mod
- = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
+ = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
    return tcg_env
 
  | otherwise
@@ -921,17 +928,17 @@ check_main dflags tcg_env
 		-- Check that 'main' is in scope
 		-- It might be imported from another module!
 	; case mb_main of {
-	     Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
+	     Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
 			   ; complain_no_main	
 			   ; return tcg_env } ;
 	     Just main_name -> do
 
-	{ traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
+	{ traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
 	; let loc = srcLocSpan (getSrcLoc main_name)
 	; ioTyCon <- tcLookupTyCon ioTyConName
-	; (main_expr, res_ty) 
+        ; res_ty <- newFlexiTyVarTy liftedTypeKind
+	; main_expr
 		<- addErrCtxt mainCtxt	  $
-		   withBox liftedTypeKind $ \res_ty -> 
 		   tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
 
 		-- See Note [Root-main Id]
@@ -1042,7 +1049,7 @@ setInteractiveContext hsc_env icxt thing_inside
         -- later ids in ic_tmp_ids must shadow earlier ones with the same
         -- OccName, and tcExtendIdEnv implements this behaviour.
 
-    do	{ traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
+    do	{ traceTc "setIC" (ppr (ic_tmp_ids icxt))
  	; thing_inside }
 \end{code}
 
@@ -1079,7 +1086,7 @@ tcRnStmt hsc_env ictxt rdr_stmt
 	-- cast them all to HValues in the end!
     mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
 
-    traceTc (text "tcs 1") ;
+    traceTc "tcs 1" empty ;
     let { global_ids = map globaliseAndTidyId zonked_ids } ;
         -- Note [Interactively-bound Ids in GHCi]
 
@@ -1256,19 +1263,19 @@ tcGhciStmts stmts
 	 } ;
 
 	-- OK, we're ready to typecheck the stmts
-	traceTc (text "TcRnDriver.tcGhciStmts: tc stmts") ;
-	((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
+	traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
+	((tc_stmts, ids), lie) <- getConstraints $ tc_io_stmts stmts $ \ _ ->
 					   mapM tcLookupId names ;
 					-- Look up the names right in the middle,
 					-- where they will all be in scope
 
 	-- Simplify the context
-	traceTc (text "TcRnDriver.tcGhciStmts: simplify ctxt") ;
-	const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
+	traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
+	const_binds <- checkNoErrs (simplifyInteractive lie) ;
 		-- checkNoErrs ensures that the plan fails if context redn fails
 
-	traceTc (text "TcRnDriver.tcGhciStmts: done") ;
-	return (ids, mkHsDictLet const_binds $
+	traceTc "TcRnDriver.tcGhciStmts: done" empty ;
+	return (ids, mkHsDictLet (EvBinds const_binds) $
 		     noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty))
     }
 \end{code}
@@ -1290,17 +1297,14 @@ tcRnExpr hsc_env ictxt rdr_expr
 
 	-- Now typecheck the expression; 
 	-- it might have a rank-2 type (e.g. :t runST)
-    ((_tc_expr, res_ty), lie)	     <- getLIE (tcInferRho rn_expr) ;
-    ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
-    _ <- tcSimplifyInteractive lie_top ;       -- Ignore the dicionary bindings
+    ((_tc_expr, res_ty), lie)	<- getConstraints (tcInferRho rn_expr) ;
+    ((qtvs, dicts, _), lie_top) <- getConstraints (simplifyInfer False {- No MR for now -}
+                                                      (tyVarsOfType res_ty) lie)  ;
+    _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
 
-    let { all_expr_ty = mkForAllTys qtvs $
-    		        mkFunTys (map (idType . instToId) dict_insts)	$
-    		        res_ty } ;
+    let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
     zonkTcType all_expr_ty
     }
-  where
-    smpl_doc = ptext (sLit "main expression")
 \end{code}
 
 tcRnType just finds the kind of a type
@@ -1623,7 +1627,7 @@ ppr_tydecls tycons
 ppr_rules :: [CoreRule] -> SDoc
 ppr_rules [] = empty
 ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
-		      nest 4 (pprRules rs),
+		      nest 2 (pprRules rs),
 		      ptext (sLit "#-}")]
 
 ppr_gen_tycons :: [TyCon] -> SDoc
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 6d5d6d1..37d4e62 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -72,14 +72,16 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
       	tvs_var      <- newIORef emptyVarSet ;
 	dfuns_var    <- newIORef emptyNameSet ;
 	keep_var     <- newIORef emptyNameSet ;
-    used_rdrnames_var <- newIORef Set.empty ;
+        used_rdr_var <- newIORef Set.empty ;
 	th_var	     <- newIORef False ;
+	lie_var	     <- newIORef emptyBag ;
 	dfun_n_var   <- newIORef emptyOccSet ;
 	type_env_var <- case hsc_type_env_var hsc_env of {
                            Just (_mod, te_var) -> return te_var ;
                            Nothing             -> newIORef emptyNameEnv } ;
       	let {
-	     maybe_rn_syntax empty_val
+             maybe_rn_syntax :: forall a. a -> Maybe a ;
+             maybe_rn_syntax empty_val
 		| keep_rn_syntax = Just empty_val
 		| otherwise	 = Nothing ;
 			
@@ -98,7 +100,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
 		tcg_th_used   = th_var,
 		tcg_exports  = [],
 		tcg_imports  = emptyImportAvails,
-        tcg_used_rdrnames = used_rdrnames_var,
+                tcg_used_rdrnames = used_rdr_var,
 		tcg_dus      = emptyDUs,
 
                 tcg_rn_imports = [],
@@ -106,6 +108,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
 		tcg_rn_decls   = maybe_rn_syntax emptyRnGroup,
 
 		tcg_binds    = emptyLHsBinds,
+		tcg_ev_binds = emptyBag,
 		tcg_warns    = NoWarnings,
 		tcg_anns     = [],
 		tcg_insts    = [],
@@ -127,9 +130,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
 		tcl_arrow_ctxt = NoArrowCtxt,
 		tcl_env        = emptyNameEnv,
 		tcl_tyvars     = tvs_var,
-		tcl_lie	       = panic "initTc:LIE", -- only valid inside getLIE
-		tcl_tybinds    = panic "initTc:tybinds"	
-                                               -- only valid inside a getTyBinds
+		tcl_lie	       = lie_var,
+		tcl_untch      = emptyVarSet
 	     } ;
 	} ;
    
@@ -140,6 +142,13 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
 			  Right res -> return (Just res)
 			  Left _    -> return Nothing } ;
 
+        -- Check for unsolved constraints
+	lie <- readIORef lie_var ;
+        if isEmptyBag lie 
+           then return ()
+           else pprPanic "initTc: unsolved constraints" 
+                         (pprWantedsWithLocs lie) ;
+
 	-- Collect any error messages
 	msgs <- readIORef errs_var ;
 
@@ -344,9 +353,37 @@ instance MonadUnique (IOEnv (Env gbl lcl)) where
 %************************************************************************
 
 \begin{code}
-traceTc, traceRn, traceSplice :: SDoc -> TcRn ()
+newTcRef :: a -> TcRnIf gbl lcl (TcRef a)
+newTcRef = newMutVar 
+
+readTcRef :: TcRef a -> TcRnIf gbl lcl a
+readTcRef = readMutVar
+
+writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
+writeTcRef = writeMutVar
+
+updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
+updTcRef = updMutVar
+\end{code}
+
+%************************************************************************
+%*									*
+		Debugging
+%*									*
+%************************************************************************
+
+\begin{code}
+traceTc :: String -> SDoc -> TcRn () 
+traceTc = traceTcN 1
+
+traceTcN :: Int -> String -> SDoc -> TcRn () 
+traceTcN level herald doc
+  | level <= opt_TraceLevel = traceOptTcRn Opt_D_dump_tc_trace $
+                              hang (text herald) 2 doc
+  | otherwise               = return ()
+
+traceRn, traceSplice :: SDoc -> TcRn ()
 traceRn      = traceOptTcRn Opt_D_dump_rn_trace
-traceTc      = traceOptTcRn Opt_D_dump_tc_trace
 traceSplice  = traceOptTcRn Opt_D_dump_splices
 
 
@@ -360,12 +397,13 @@ traceOptIf flag doc = ifOptM flag $
 		      liftIO (printForUser stderr alwaysQualify doc)
 
 traceOptTcRn :: DynFlag -> SDoc -> TcRn ()
+-- Output the message, with current location if opt_PprStyle_Debug
 traceOptTcRn flag doc = ifOptM flag $ do
-			{ ctxt <- getErrCtxt
-			; loc  <- getSrcSpanM
-			; env0 <- tcInitTidyEnv
-			; err_info <- mkErrInfo env0 ctxt 
-			; let real_doc = mkLocMessage loc (doc $$ err_info)
+			{ loc  <- getSrcSpanM
+			; let real_doc 
+                                | opt_PprStyle_Debug = mkLocMessage loc doc
+                                | otherwise = doc   -- The full location is 
+				  	      	    -- usually way too much
 			; dumpTcRn real_doc }
 
 dumpTcRn :: SDoc -> TcRn ()
@@ -503,8 +541,8 @@ warnIf False _   = return ()
 addMessages :: Messages -> TcRn ()
 addMessages (m_warns, m_errs)
   = do { errs_var <- getErrsVar ;
-	 (warns, errs) <- readMutVar errs_var ;
-  	 writeMutVar errs_var (warns `unionBags` m_warns,
+	 (warns, errs) <- readTcRef errs_var ;
+  	 writeTcRef errs_var (warns `unionBags` m_warns,
 			       errs  `unionBags` m_errs) }
 
 discardWarnings :: TcRn a -> TcRn a
@@ -515,9 +553,9 @@ discardWarnings :: TcRn a -> TcRn a
 discardWarnings thing_inside
   | opt_PprStyle_Debug = thing_inside
   | otherwise
-  = do	{ errs_var <- newMutVar emptyMessages
+  = do	{ errs_var <- newTcRef emptyMessages
 	; result <- setErrsVar errs_var thing_inside
-	; (_warns, errs) <- readMutVar errs_var
+	; (_warns, errs) <- readTcRef errs_var
 	; addMessages (emptyBag, errs)
 	; return result }
 \end{code}
@@ -540,18 +578,18 @@ addReportAt loc msg extra_info
          dflags <- getDOpts ;
 	 let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
 	                            msg extra_info } ;
-	 (warns, errs) <- readMutVar errs_var ;
-  	 writeMutVar errs_var (warns `snocBag` warn, errs) }
+	 (warns, errs) <- readTcRef errs_var ;
+  	 writeTcRef errs_var (warns `snocBag` warn, errs) }
 
 addLongErrAt :: SrcSpan -> Message -> Message -> TcRn ()
 addLongErrAt loc msg extra
-  = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;	
+  = do { traceTc "Adding error:" (mkLocMessage loc (msg $$ extra)) ;	
 	 errs_var <- getErrsVar ;
 	 rdr_env <- getGlobalRdrEnv ;
          dflags <- getDOpts ;
 	 let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
-	 (warns, errs) <- readMutVar errs_var ;
-  	 writeMutVar errs_var (warns, errs `snocBag` err) }
+	 (warns, errs) <- readTcRef errs_var ;
+  	 writeTcRef errs_var (warns, errs `snocBag` err) }
 \end{code}
 
 
@@ -561,10 +599,10 @@ try_m :: TcRn r -> TcRn (Either IOEnvFailure r)
 try_m thing 
   = do { mb_r <- tryM thing ;
 	 case mb_r of 
-	     Left exn -> do { traceTc (exn_msg exn); return mb_r }
+	     Left exn -> do { traceTc "tryTc/recoverM recovering from" $
+                                      text (showException exn)
+                            ; return mb_r }
 	     Right _  -> return mb_r }
-  where
-    exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)
 
 -----------------------
 recoverM :: TcRn r 	-- Recovery action; do this if the main one fails
@@ -598,9 +636,9 @@ tryTc :: TcRn a -> TcRn (Messages, Maybe a)
 -- It also returns all the errors and warnings accumulated by m
 -- It always succeeds (never raises an exception)
 tryTc m 
- = do {	errs_var <- newMutVar emptyMessages ;
+ = do {	errs_var <- newTcRef emptyMessages ;
 	res  <- try_m (setErrsVar errs_var m) ; 
-	msgs <- readMutVar errs_var ;
+	msgs <- readTcRef errs_var ;
 	return (msgs, case res of
 			    Left _  -> Nothing
 			    Right val -> Just val)
@@ -631,10 +669,10 @@ tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
 -- for the thing is propagated only if there are no errors
 -- Hence it's restricted to the type-check monad
 tryTcLIE thing_inside
-  = do  { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ;
+  = do  { ((msgs, mb_res), lie) <- getConstraints (tryTcErrs thing_inside) ;
 	; case mb_res of
 	    Nothing  -> return (msgs, Nothing)
-	    Just val -> do { extendLIEs lie; return (msgs, Just val) }
+	    Just val -> do { emitConstraints lie; return (msgs, Just val) }
 	}
 
 -----------------------
@@ -672,7 +710,7 @@ ifErrsM :: TcRn r -> TcRn r -> TcRn r
 -- otherwise does 'main'
 ifErrsM bale_out normal
  = do { errs_var <- getErrsVar ;
-	msgs <- readMutVar errs_var ;
+	msgs <- readTcRef errs_var ;
 	dflags <- getDOpts ;
 	if errorsFound dflags msgs then
 	   bale_out
@@ -720,15 +758,13 @@ maybeAddErrCtxt Nothing    thing_inside = thing_inside
 popErrCtxt :: TcM a -> TcM a
 popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
 
-getInstLoc :: InstOrigin -> TcM InstLoc
-getInstLoc origin
+getCtLoc :: orig -> TcM (CtLoc orig)
+getCtLoc origin
   = do { loc <- getSrcSpanM ; env <- getLclEnv ;
-	 return (InstLoc origin loc (tcl_ctxt env)) }
+	 return (CtLoc origin loc (tcl_ctxt env)) }
 
-setInstCtxt :: InstLoc -> TcM a -> TcM a
--- Add the SrcSpan and context from the first Inst in the list
--- 	(they all have similar locations)
-setInstCtxt (InstLoc _ src_loc ctxt) thing_inside
+setCtLoc :: CtLoc orig -> TcM a -> TcM a
+setCtLoc (CtLoc _ src_loc ctxt) thing_inside
   = setSrcSpan src_loc (setErrCtxt ctxt thing_inside)
 \end{code}
 
@@ -835,7 +871,7 @@ mkErrInfo env ctxts
    go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
    go _ _   [] = return empty
    go n env ((is_landmark, ctxt) : ctxts)
-     | is_landmark || opt_PprStyle_Debug || n < mAX_CONTEXTS
+     | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug 
      = do { (env', msg) <- ctxt env
 	  ; let n' = if is_landmark then n else n+1
           ; rest <- go n' env' ctxts
@@ -858,52 +894,77 @@ debugTc thing
 
 %************************************************************************
 %*									*
-	     Type constraints (the so-called LIE)
+	     Type constraints
 %*									*
 %************************************************************************
 
 \begin{code}
+newTcEvBinds :: TcM EvBindsVar
+newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
+       		  ; uniq <- newUnique
+       		  ; return (EvBindsVar ref uniq) }
+
+extendTcEvBinds :: TcEvBinds -> EvVar -> EvTerm -> TcM TcEvBinds
+extendTcEvBinds binds@(TcEvBinds binds_var) var rhs 
+  = do { addTcEvBind binds_var var rhs
+       ; return binds }
+extendTcEvBinds (EvBinds bnds) var rhs
+  = return (EvBinds (bnds `snocBag` EvBind var rhs))
+
+addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM ()
+-- Add a binding to the TcEvBinds by side effect
+addTcEvBind (EvBindsVar ev_ref _) var rhs
+  = do { bnds <- readTcRef ev_ref
+       ; writeTcRef ev_ref (extendEvBinds bnds var rhs) }
+
 chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName
 chooseUniqueOccTc fn =
   do { env <- getGblEnv
      ; let dfun_n_var = tcg_dfun_n env
-     ; set <- readMutVar dfun_n_var
+     ; set <- readTcRef dfun_n_var
      ; let occ = fn set
-     ; writeMutVar dfun_n_var (extendOccSet set occ)
-     ; return occ
-     }
+     ; writeTcRef dfun_n_var (extendOccSet set occ)
+     ; return occ }
 
-getLIEVar :: TcM (TcRef LIE)
-getLIEVar = do { env <- getLclEnv; return (tcl_lie env) }
+getConstraintVar :: TcM (TcRef WantedConstraints)
+getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }
 
-setLIEVar :: TcRef LIE -> TcM a -> TcM a
-setLIEVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
+setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a
+setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })
 
-getLIE :: TcM a -> TcM (a, [Inst])
--- (getLIE m) runs m, and returns the type constraints it generates
-getLIE thing_inside
-  = do { lie_var <- newMutVar emptyLIE ;
+emitConstraints :: WantedConstraints -> TcM ()
+emitConstraints ct
+  = do { lie_var <- getConstraintVar ;
+	 updTcRef lie_var (`andWanteds` ct) }
+
+emitConstraint :: WantedConstraint -> TcM ()
+emitConstraint ct
+  = do { lie_var <- getConstraintVar ;
+	 updTcRef lie_var (`extendWanteds` ct) }
+
+getConstraints :: TcM a -> TcM (a, WantedConstraints)
+-- (getConstraints m) runs m, and returns the type constraints it generates
+getConstraints thing_inside
+  = do { lie_var <- newTcRef emptyWanteds ;
 	 res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
 			  thing_inside ;
-	 lie <- readMutVar lie_var ;
-	 return (res, lieToList lie) }
-
-extendLIE :: Inst -> TcM ()
-extendLIE inst
-  = do { lie_var <- getLIEVar ;
-	 lie <- readMutVar lie_var ;
-	 writeMutVar lie_var (inst `consLIE` lie) }
-
-extendLIEs :: [Inst] -> TcM ()
-extendLIEs [] 
-  = return ()
-extendLIEs insts
-  = do { lie_var <- getLIEVar ;
-	 lie <- readMutVar lie_var ;
-	 writeMutVar lie_var (mkLIE insts `plusLIE` lie) }
-\end{code}
+	 lie <- readTcRef lie_var ;
+	 return (res, lie) }
+
+setUntouchables :: TcTyVarSet -> TcM a -> TcM a
+setUntouchables untch_tvs thing_inside
+  = updLclEnv (\ env -> env { tcl_untch = untch_tvs }) thing_inside 
+
+getUntouchables :: TcM TcTyVarSet 
+getUntouchables
+   = do { env <- getLclEnv; return (tcl_untch env) } 
+
+isUntouchable :: TcTyVar -> TcM Bool
+isUntouchable tv = do { env <- getLclEnv; return (tv `elemVarSet` tcl_untch env) }
+
+getLclTypeEnv :: TcM (NameEnv TcTyThing)
+getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }
 
-\begin{code}
 setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a
 -- Set the local type envt, but do *not* disturb other fields,
 -- notably the lie_var
@@ -917,61 +978,23 @@ setLclTypeEnv lcl_env thing_inside
 
 %************************************************************************
 %*									*
-	     Meta type variable bindings
-%*									*
-%************************************************************************
-
-\begin{code}
-getTcTyVarBindsVar :: TcM (TcRef TcTyVarBinds)
-getTcTyVarBindsVar = do { env <- getLclEnv; return (tcl_tybinds env) }
-
-getTcTyVarBinds :: TcM a -> TcM (a, TcTyVarBinds)
-getTcTyVarBinds thing_inside
-  = do { tybinds_var <- newMutVar emptyBag
-       ; res <- updLclEnv (\ env -> env { tcl_tybinds = tybinds_var }) 
-			  thing_inside
-       ; tybinds <- readMutVar tybinds_var
-       ; return (res, tybinds) 
-       }
-
-bindMetaTyVar :: TcTyVar -> TcType -> TcM ()
-bindMetaTyVar tv ty
-  = do { ASSERTM2( do { details <- readMutVar (metaTvRef tv)
-                      ; return (isFlexi details) }, ppr tv )
-       ; tybinds_var <- getTcTyVarBindsVar
-       ; tybinds <- readMutVar tybinds_var
-       ; writeMutVar tybinds_var (tybinds `snocBag` TcTyVarBind tv ty) 
-       }
-
-getTcTyVarBindsRelation :: TcM [(TcTyVar, TcTyVarSet)]
-getTcTyVarBindsRelation
-  = do { tybinds_var <- getTcTyVarBindsVar
-       ; tybinds <- readMutVar tybinds_var
-       ; return $ map freeTvs (bagToList tybinds)
-       }
-  where
-    freeTvs (TcTyVarBind tv ty) = (tv, tyVarsOfType ty)
-\end{code}
-
-%************************************************************************
-%*									*
 	     Template Haskell context
 %*									*
 %************************************************************************
 
 \begin{code}
 recordThUse :: TcM ()
-recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True }
+recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }
 
 keepAliveTc :: Id -> TcM ()  	-- Record the name in the keep-alive set
 keepAliveTc id 
   | isLocalId id = do { env <- getGblEnv; 
-		      ; updMutVar (tcg_keep env) (`addOneToNameSet` idName id) }
+		      ; updTcRef (tcg_keep env) (`addOneToNameSet` idName id) }
   | otherwise = return ()
 
 keepAliveSetTc :: NameSet -> TcM ()  	-- Record the name in the keep-alive set
 keepAliveSetTc ns = do { env <- getGblEnv; 
-		       ; updMutVar (tcg_keep env) (`unionNameSets` ns) }
+		       ; updTcRef (tcg_keep env) (`unionNameSets` ns) }
 
 getStage :: TcM ThStage
 getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }
@@ -1014,7 +1037,7 @@ initIfaceTcRn :: IfG a -> TcRn a
 initIfaceTcRn thing_inside
   = do  { tcg_env <- getGblEnv 
 	; let { if_env = IfGblEnv { if_rec_types = Just (tcg_mod tcg_env, get_type_env) }
-	      ; get_type_env = readMutVar (tcg_type_env_var tcg_env) }
+	      ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
 	; setEnvs (if_env, ()) thing_inside }
 
 initIfaceExtCore :: IfL a -> TcRn a
@@ -1033,7 +1056,7 @@ initIfaceCheck :: HscEnv -> IfG a -> IO a
 -- Initialise the environment with no useful info at all
 initIfaceCheck hsc_env do_this
  = do let rec_types = case hsc_type_env_var hsc_env of
-                         Just (mod,var) -> Just (mod, readMutVar var)
+                         Just (mod,var) -> Just (mod, readTcRef var)
                          Nothing        -> Nothing
           gbl_env = IfGblEnv { if_rec_types = rec_types }
       initTcRnIf 'i' hsc_env gbl_env () do_this
@@ -1043,8 +1066,8 @@ initIfaceTc :: ModIface
 -- Used when type-checking checking an up-to-date interface file
 -- No type envt from the current module, but we do know the module dependencies
 initIfaceTc iface do_this
- = do	{ tc_env_var <- newMutVar emptyTypeEnv
-	; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ;
+ = do	{ tc_env_var <- newTcRef emptyTypeEnv
+	; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readTcRef tc_env_var) } ;
 	      ; if_lenv = mkIfLclEnv mod doc
 	   }
 	; setEnvs (gbl_env, if_lenv) (do_this tc_env_var)
@@ -1110,7 +1133,7 @@ forkM_maybe doc thing_inside
 		    -- happen when compiling interface signatures (see tcInterfaceSigs)
 		      ifOptM Opt_D_dump_if_trace 
 			     (print_errs (hang (text "forkM failed:" <+> doc)
-				             4 (text (show exn))))
+				             2 (text (show exn))))
 
 		    ; traceIf (text "} ending fork (badly)" <+> doc)
 	  	    ; return Nothing }
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 2f54e42..7357669 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -18,7 +18,7 @@ module TcRnTypes(
 	WhereFrom(..), mkModDeps,
 
 	-- Typechecker types
-	TcTyThing(..), pprTcTyThingCategory, RefinementVisibility(..),
+	TcTypeEnv, TcTyThing(..), pprTcTyThingCategory, 
 
 	-- Template Haskell
 	ThStage(..), topStage, topAnnStage, topSpliceStage,
@@ -27,23 +27,35 @@ module TcRnTypes(
 	-- Arrows
 	ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
 
-	-- Insts
-	Inst(..), EqInstCo, InstOrigin(..), InstLoc(..), 
-	pprInstLoc, pprInstArising, instLocSpan, instLocOrigin, setInstLoc,
-	LIE, emptyLIE, unitLIE, plusLIE, consLIE, instLoc, instSpan,
-	plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
+	-- Constraints
+        Untouchables,
+  	WantedConstraints, emptyWanteds, andWanteds, extendWanteds,
+	WantedConstraint(..), WantedEvVar(..), wantedEvVarLoc, 
+        wantedEvVarToVar, wantedEvVarPred, splitWanteds,
+
+	evVarsToWanteds,
+	Implication(..), 
+        CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin,
+	CtOrigin(..), EqOrigin(..), 
+	WantedLoc, GivenLoc,
+
+	SkolemInfo(..),
+
+	-- Pretty printing
+	pprEvVarTheta, pprWantedsWithLocs, pprWantedWithLoc, 
+	pprEvVars, pprEvVarWithType,
+	pprArising, pprArisingAt,
 
 	-- Misc other types
-	TcId, TcIdSet, TcDictBinds, TcTyVarBind(..), TcTyVarBinds
+	TcId, TcIdSet, TcTyVarBind(..), TcTyVarBinds
 	
   ) where
 
 #include "HsVersions.h"
 
-import HsSyn hiding (LIE)
+import HsSyn
 import HscTypes
 import Type
-import Coercion
 import TcType
 import Annotations
 import InstEnv
@@ -62,11 +74,11 @@ import VarSet
 import ErrUtils
 import UniqSupply
 import BasicTypes
-import Util
 import Bag
 import Outputable
 import ListSetOps
 import FastString
+import StaticFlags( opt_ErrorSpans )
 
 import Data.Set (Set)
 \end{code}
@@ -83,9 +95,9 @@ The monad itself has to be defined here, because it is mentioned by ErrCtxt
 
 \begin{code}
 type TcRef a 	 = IORef a
-type TcId    	 = Id 			-- Type may be a TcType
+type TcId    	 = Id 			-- Type may be a TcType  DV: WHAT??????????
 type TcIdSet 	 = IdSet
-type TcDictBinds = DictBinds TcId	-- Bag of dictionary bindings
+
 
 type TcRnIf a b c = IOEnv (Env a b) c
 type IfM lcl a  = TcRnIf IfGblEnv lcl a		-- Iface stuff
@@ -242,6 +254,7 @@ data TcGblEnv
           -- ^ Renamed decls, maybe.  @Nothing@ <=> Don't retain renamed
           -- decls.
 
+        tcg_ev_binds  :: Bag EvBind,	    -- Top-level evidence bindings
 	tcg_binds     :: LHsBinds Id,	    -- Value bindings in this module
 	tcg_warns     :: Warnings,	    -- ...Warnings and deprecations
 	tcg_anns      :: [Annotation],      -- ...Annotations
@@ -358,8 +371,8 @@ data TcLclEnv		-- Changes as we move inside an expression
 		-- We still need the unsullied global name env so that
     		--   we can look up record field names
 
-	tcl_env  :: NameEnv TcTyThing,  -- The local type environment: Ids and
-					-- TyVars defined in this module
+	tcl_env  :: TcTypeEnv,    -- The local type environment: Ids and
+			          -- TyVars defined in this module
 					
 	tcl_tyvars :: TcRef TcTyVarSet,	-- The "global tyvars"
 			-- Namely, the in-scope TyVars bound in tcl_env, 
@@ -367,13 +380,12 @@ data TcLclEnv		-- Changes as we move inside an expression
 			-- in tcl_lenv. 
                         -- Why mutable? see notes with tcGetGlobalTyVars
 
-	tcl_lie   :: TcRef LIE,		-- Place to accumulate type constraints
-
-        tcl_tybinds :: TcRef TcTyVarBinds -- Meta and coercion type variable
-                                          -- bindings accumulated during
-                                          -- constraint solving
+	tcl_lie   :: TcRef WantedConstraints,    -- Place to accumulate type constraints
+	tcl_untch :: Untouchables		 -- Untouchables
     }
 
+type TcTypeEnv = NameEnv TcTyThing
+
 
 {- Note [Given Insts]
    ~~~~~~~~~~~~~~~~~~
@@ -405,7 +417,7 @@ data ThStage	-- See Note [Template Haskell state diagram] in TcSplice
   | Brack  			-- Inside brackets 
       ThStage 			--   Binding level = level(stage) + 1
       (TcRef [PendingSplice])	--   Accumulate pending splices here
-      (TcRef LIE)		--     and type constraints here
+      (TcRef WantedConstraints)	--     and type constraints here
 
 topStage, topAnnStage, topSpliceStage :: ThStage
 topStage       = Comp
@@ -488,41 +500,23 @@ data TcTyThing
   = AGlobal TyThing		-- Used only in the return type of a lookup
 
   | ATcId   {		-- Ids defined in this module; may not be fully zonked
-	tct_id :: TcId,		
-	tct_co :: RefinementVisibility,	-- Previously: Maybe HsWrapper
-					-- Nothing <=>	Do not apply a GADT type refinement
-					--		I am wobbly, or have no free
-					--		type variables
-					-- Just co <=>  Apply any type refinement to me,
-					--		and record it in the coercion
-	tct_type  :: TcType,	-- Type of (coercion applied to id)
+	tct_id    :: TcId,		
 	tct_level :: ThLevel }
 
   | ATyVar  Name TcType		-- The type to which the lexically scoped type vaiable
 				-- is currently refined. We only need the Name
-				-- for error-message purposes
+				-- for error-message purposes; it is the corresponding
+				-- Name in the domain of the envt
 
   | AThing  TcKind 		-- Used temporarily, during kind checking, for the
 				--	tycons and clases in this recursive group
 
-data RefinementVisibility
-  = Unrefineable			-- Do not apply a GADT refinement
-					-- I have no free variables	
-
-  | Rigid HsWrapper			-- Apply any refinement to me
-					-- and record it in the coercion
-
-  | Wobbly				-- Do not apply a GADT refinement
-					-- I am wobbly
-
-  | WobblyInvisible			-- Wobbly type, not available inside current
-					-- GADT refinement
-
 instance Outputable TcTyThing where	-- Debugging only
    ppr (AGlobal g)      = pprTyThing g
    ppr elt@(ATcId {})   = text "Identifier" <> 
-			  ifPprDebug (brackets (ppr (tct_id elt) <> dcolon <> ppr (tct_type elt) <> comma
-				 <+> ppr (tct_level elt) <+> ppr (tct_co elt)))
+			  brackets (ppr (tct_id elt) <> dcolon 
+                                 <> ppr (varType (tct_id elt)) <> comma
+				 <+> ppr (tct_level elt))
    ppr (ATyVar tv _)    = text "Type variable" <+> quotes (ppr tv)
    ppr (AThing k)       = text "AThing" <+> ppr k
 
@@ -531,13 +525,6 @@ pprTcTyThingCategory (AGlobal thing) = pprTyThingCategory thing
 pprTcTyThingCategory (ATyVar {})     = ptext (sLit "Type variable")
 pprTcTyThingCategory (ATcId {})      = ptext (sLit "Local identifier")
 pprTcTyThingCategory (AThing {})     = ptext (sLit "Kinded thing")
-
-instance Outputable RefinementVisibility where
-    ppr Unrefineable	      = ptext (sLit "unrefineable")
-    ppr (Rigid co)	      = ptext (sLit "rigid") <+> ppr co
-    ppr	Wobbly		      = ptext (sLit "wobbly")
-    ppr WobblyInvisible	      = ptext (sLit "wobbly-invisible")
-
 \end{code}
 
 \begin{code}
@@ -678,269 +665,207 @@ instance Outputable WhereFrom where
 
 %************************************************************************
 %*									*
-\subsection[Inst-types]{@Inst@ types}
+		Wanted constraints
+
+     These are forced to be in TcRnTypes because
+     	   TcLclEnv mentions WantedConstraints
+	   WantedConstraint mentions CtLoc
+	   CtLoc mentions ErrCtxt
+	   ErrCtxt mentions TcM
 %*									*
 v%************************************************************************
 
-An @Inst@ is either a dictionary, an instance of an overloaded
-literal, or an instance of an overloaded value.  We call the latter a
-``method'' even though it may not correspond to a class operation.
-For example, we might have an instance of the @double@ function at
-type Int, represented by
-
-	Method 34 doubleId [Int] origin
+\begin{code}
+type Untouchables = TcTyVarSet	-- All MetaTyVars
 
-In addition to the basic Haskell variants of 'Inst's, they can now also
-represent implication constraints 'forall tvs. given => wanted'
-and equality constraints 'co :: ty1 ~ ty2'.
+type WantedConstraints = Bag WantedConstraint
 
-NB: Equalities occur in two flavours:
+data WantedConstraint
+  = WcEvVar  WantedEvVar
+  | WcImplic Implication
+  -- ToDo: add literals, methods
 
-  (1) Dict {tci_pred = EqPred ty1 ty2}
-  (2) EqInst {tci_left = ty1, tci_right = ty2, tci_co = coe}
+-- EvVar defined in module Var.lhs: 
+-- Evidence variables include all *quantifiable* constraints
+--   dictionaries
+--   implicit parameters
+--   coercion variables
 
-The former arises from equalities in contexts, whereas the latter is used
-whenever the type checker introduces an equality (e.g., during deferring
-unification).
+data WantedEvVar   -- The sort of constraint over which one can lambda-abstract
+   = WantedEvVar 
+         EvVar 	     -- The variable itself; make a binding for it please
+         WantedLoc   -- How the constraint arose in the first place
+	 	     -- (used for error messages only)
 
-I am not convinced that this duplication is necessary or useful! -=chak
+type WantedLoc = CtLoc CtOrigin
+type GivenLoc  = CtLoc SkolemInfo
 
-\begin{code}
-data Inst
-  = Dict {
-	tci_name :: Name,
-	tci_pred :: TcPredType,	  -- Class or implicit parameter only
-	tci_loc  :: InstLoc 
-    }
+data Implication
+  = Implic {  
+      ic_env_tvs :: Untouchables, -- Untouchables: unification variables
+                                  -- free in the environment
+      ic_env     :: TcTypeEnv,    -- The type environment
+      		      	      	  -- Used only when generating error messages
+	  -- Generally, ic_env_tvs = tvsof(ic_env)
+	  -- However, we don't zonk ic_env when zonking the Implication
+	  -- Instead we do that when generating a skolem-escape error message
 
-  | ImplicInst {	-- An implication constraint
-			-- forall tvs. given => wanted
-	tci_name   :: Name,
-	tci_tyvars :: [TcTyVar],    -- Quantified type variables
-	tci_given  :: [Inst],	    -- Only Dicts and EqInsts
-				    --   (no Methods, LitInsts, ImplicInsts)
-	tci_wanted :: [Inst],	    -- Only Dicts, EqInst, and ImplicInsts
-				    --   (no Methods or LitInsts)
+      ic_skols  :: TcTyVarSet,   -- Introduced skolems 
+      		   	         -- See Note [Skolems in an implication]
 
-	tci_loc    :: InstLoc
-    }
-	-- NB: the tci_given are not necessarily rigid
+      ic_scoped :: [TcTyVar],    -- List of scoped variables to be unified 
+                                 -- bijectively to a subset of ic_tyvars
+				 -- Note [Scoped pattern variable]
 
-  | Method {
-	tci_id :: TcId,		-- The Id for the Inst
+      ic_given  :: [EvVar],      -- Given evidence variables
+      		   		 --   (order does not matter)
 
-	tci_oid :: TcId,	-- The overloaded function
-		-- This function will be a global, local, or ClassOpId;
-		--   inside instance decls (only) it can also be an InstId!
-		-- The id needn't be completely polymorphic.
-		-- You'll probably find its name (for documentation purposes)
-		--	  inside the InstOrigin
+      ic_wanted :: WantedConstraints,    -- Wanted constraints
 
-	tci_tys :: [TcType],	-- The types to which its polymorphic tyvars
-				--	should be instantiated.
-				-- These types must saturate the Id's foralls.
+      ic_binds  :: EvBindsVar,   -- Points to the place to fill in the
+      		      	    	 -- abstraction and bindings
 
-	tci_theta :: TcThetaType,	
-			-- The (types of the) dictionaries to which the function
-			-- must be applied to get the method
+      ic_loc   :: GivenLoc }
 
-	tci_loc :: InstLoc 
-    }
-	-- INVARIANT 1: in (Method m f tys theta tau loc)
-	--	type of m = type of (f tys dicts(from theta))
-
-	-- INVARIANT 2: type of m must not be of form (Pred -> Tau)
-	--   Reason: two methods are considered equal if the 
-	--   	     base Id matches, and the instantiating types
-	--	     match.  The TcThetaType should then match too.
-	--   This only bites in the call to tcInstClassOp in TcClassDcl.mkMethodBind
-
-  | LitInst {
-	tci_name :: Name,
-	tci_lit  :: HsOverLit Name,	-- The literal from the occurrence site
-			-- INVARIANT: never a rebindable-syntax literal
-			-- Reason: tcSyntaxName does unification, and we
-			--	   don't want to deal with that during tcSimplify,
-			--	   when resolving LitInsts
-
-	tci_ty :: TcType,	-- The type at which the literal is used
-	tci_loc :: InstLoc
-    }
+evVarsToWanteds :: WantedLoc -> [EvVar] -> WantedConstraints
+evVarsToWanteds loc evs = listToBag [WcEvVar (WantedEvVar ev loc) | ev <- evs]
 
-  | EqInst {			  -- delayed unification of the form 
-				  --  	co :: ty1 ~ ty2
-	tci_left  :: TcType,      -- ty1    -- both types are...
-	tci_right :: TcType,      -- ty2    -- ...free of boxes
-	tci_co    :: EqInstCo,  	  -- co
-	tci_loc   :: InstLoc,
-
-	tci_name  :: Name	-- Debugging help only: this makes it easier to
-				-- follow where a constraint is used in a morass
-				-- of trace messages!  Unlike other Insts, it 
-                                -- has no semantic significance whatsoever.
-    }
+wantedEvVarLoc :: WantedEvVar -> WantedLoc 
+wantedEvVarLoc (WantedEvVar _ loc) = loc 
 
-type EqInstCo = Either 	  -- Distinguish between given and wanted coercions
-		  TcTyVar   --  - a wanted equation, with a hole, to be filled
-			    --    with a witness for the equality; for equation
-                            --    arising from deferring unification, 'ty1' is
-                            --    the actual and 'ty2' the expected type
-		  Coercion  --  - a given equation, with a coercion witnessing
-                            --    the equality; a coercion that originates
-                            --    from a signature or a GADT is a CoVar, but
-                            --    after normalisation of coercions, they can
-			    --    be arbitrary Coercions involving constructors 
-                            --    and pseudo-constructors like sym and trans.
-\end{code}
+wantedEvVarToVar :: WantedEvVar -> EvVar 
+wantedEvVarToVar (WantedEvVar ev _) = ev 
 
-@Insts@ are ordered by their class/type info, rather than by their
-unique.  This allows the context-reduction mechanism to use standard finite
-maps to do their stuff.  It's horrible that this code is here, rather
-than with the Avails handling stuff in TcSimplify
+wantedEvVarPred :: WantedEvVar -> PredType 
+wantedEvVarPred (WantedEvVar ev _)  = evVarPred ev 
 
-\begin{code}
-instance Ord Inst where
-   compare = cmpInst
-	-- Used *only* for AvailEnv in TcSimplify
-
-instance Eq Inst where
-  (==) i1 i2 = case i1 `cmpInst` i2 of
-               EQ -> True
-               _  -> False
-
-cmpInst :: Inst -> Inst -> Ordering
-cmpInst d1@(Dict {}) 	d2@(Dict {})	= tci_pred d1 `tcCmpPred` tci_pred d2
-cmpInst (Dict {})       _               = LT
-
-cmpInst (Method {}) 	(Dict {})	= GT
-cmpInst m1@(Method {}) 	m2@(Method {})	= (tci_oid m1 `compare` tci_oid m2) `thenCmp`
-					  (tci_tys m1 `tcCmpTypes` tci_tys m2)
-cmpInst (Method {})     _               = LT
-
-cmpInst (LitInst {})	(Dict {}) 	= GT
-cmpInst (LitInst {})	(Method {})	= GT
-cmpInst l1@(LitInst {})	l2@(LitInst {})	= (tci_lit l1 `compare` tci_lit l2) `thenCmp`
-					  (tci_ty l1 `tcCmpType` tci_ty l2)
-cmpInst (LitInst {})    _               = LT
-
-	-- Implication constraints are compared by *name*
-	-- not by type; that is, we make no attempt to do CSE on them
-cmpInst (ImplicInst {})    (Dict {})	      = GT
-cmpInst (ImplicInst {})    (Method {})	      = GT
-cmpInst (ImplicInst {})    (LitInst {})	      = GT
-cmpInst i1@(ImplicInst {}) i2@(ImplicInst {}) = tci_name i1 `compare` tci_name i2
-cmpInst (ImplicInst {})    _                  = LT
-
-	-- same for Equality constraints
-cmpInst (EqInst {})    (Dict {})       = GT
-cmpInst (EqInst {})    (Method {})     = GT
-cmpInst (EqInst {})    (LitInst {})    = GT
-cmpInst (EqInst {})    (ImplicInst {}) = GT
-cmpInst i1@(EqInst {}) i2@(EqInst {})  = (tci_left  i1 `tcCmpType` tci_left  i2) `thenCmp`
-                                         (tci_right i1 `tcCmpType` tci_right i2)
+splitWanteds :: WantedConstraints -> (Bag WantedEvVar, Bag Implication)
+splitWanteds wanted = partitionBagWith pick wanted
+  where
+    pick (WcEvVar v)  = Left v
+    pick (WcImplic i) = Right i
 \end{code}
 
+Note [Skolems in an implication]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The skolems in an implication are not there to perform a skolem escape
+check.  That happens because all the environment variables are in the
+untouchables, and therefore cannot be unified with anything at all,
+let alone the skolems.
 
-%************************************************************************
-%*									*
-\subsection[Inst-collections]{LIE: a collection of Insts}
-%*									*
-%************************************************************************
-
-\begin{code}
--- FIXME: Rename this. It clashes with (Located (IE ...))
-type LIE = Bag Inst
+Instead, ic_skols is used only when considering floating a constraint
+outside the implication in TcSimplify.floatEqualities or 
+TcSimplify.approximateImplications
 
-isEmptyLIE :: LIE -> Bool
-isEmptyLIE = isEmptyBag
+Note [Scoped pattern variables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+   data T where K :: forall a,b. a -> b -> T
 
-emptyLIE :: LIE
-emptyLIE = emptyBag
+   ...(case x of K (p::c) (q::d) -> ...)...
 
-unitLIE :: Inst -> LIE
-unitLIE inst = unitBag inst
+We create fresh MetaTvs for c,d, and later check that they are
+bound bijectively to the skolems we created for a,b.  So the
+implication constraint looks like
+	    ic_skols  = {a',b'}  -- Skolem tvs created from a,b
+	    ic_scoped = {c',d'}  -- Meta tvs created from c,d
 
-mkLIE :: [Inst] -> LIE
-mkLIE insts = listToBag insts
-
-plusLIE :: LIE -> LIE -> LIE
-plusLIE lie1 lie2 = lie1 `unionBags` lie2
-
-plusLIEs :: [LIE] -> LIE
-plusLIEs lies = unionManyBags lies
-
-lieToList :: LIE -> [Inst]
-lieToList = bagToList
+\begin{code}
+emptyWanteds :: WantedConstraints
+emptyWanteds = emptyBag
 
-listToLIE :: [Inst] -> LIE
-listToLIE = listToBag
+andWanteds :: WantedConstraints -> WantedConstraints -> WantedConstraints
+andWanteds = unionBags
 
-consLIE :: Inst -> LIE -> LIE
-consLIE inst lie  = lie `snocBag` inst
--- Putting the new Inst at the *end* of the bag is a half-hearted attempt
--- to ensure that we tend to report the *leftmost* type-constraint error
--- E.g. 	f :: [a]
---		f = [1,2,3]
--- we'd like to complain about the '1', not the '3'.
---
--- "Half-hearted" because the rest of the type checker makes no great
--- claims for retaining order in the constraint set.  Still, this 
--- seems to improve matters slightly.  Exampes: mdofail001, tcfail015
+extendWanteds :: WantedConstraints -> WantedConstraint -> WantedConstraints
+extendWanteds = snocBag
+\end{code}
+ 
+\begin{code}
+pprEvVars :: [EvVar] -> SDoc	-- Print with their types
+pprEvVars ev_vars = vcat (map pprEvVarWithType ev_vars)
+
+pprEvVarTheta :: [EvVar] -> SDoc
+pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars)
+                              
+pprEvVarWithType :: EvVar -> SDoc
+pprEvVarWithType v = ppr v <+> dcolon <+> pprPred (evVarPred v)
+
+pprWantedsWithLocs :: Bag WantedConstraint -> SDoc
+pprWantedsWithLocs = foldrBag (($$) . pprWantedWithLoc) empty 
+
+pprWantedWithLoc :: WantedConstraint -> SDoc
+pprWantedWithLoc (WcImplic i) = ppr i
+pprWantedWithLoc (WcEvVar v)  = pprWantedEvVarWithLoc v
+
+instance Outputable WantedConstraint where
+  ppr (WcEvVar v)  = ppr v
+  ppr (WcImplic i) = ppr i
+
+-- Adding -ferror-spans makes the output more voluminous
+instance Outputable WantedEvVar where
+  ppr wev | opt_ErrorSpans = pprWantedEvVarWithLoc wev
+          | otherwise      = pprWantedEvVar wev
+
+pprWantedEvVarWithLoc, pprWantedEvVar :: WantedEvVar -> SDoc
+pprWantedEvVarWithLoc (WantedEvVar v loc) = hang (pprEvVarWithType v) 
+                                               2 (pprArisingAt loc) 
+pprWantedEvVar        (WantedEvVar v _)   = pprEvVarWithType v
+
+instance Outputable Implication where
+  ppr (Implic { ic_env_tvs = env_tvs, ic_skols = skols, ic_given = given
+              , ic_wanted = wanted, ic_binds = binds, ic_loc = loc })
+   = ptext (sLit "Implic") <+> braces 
+     (sep [ ptext (sLit "Untouchables = ") <+> ppr env_tvs
+          , ptext (sLit "Skolems = ") <+> ppr skols
+          , ptext (sLit "Given = ") <+> pprEvVars given
+          , ptext (sLit "Wanted = ") <+> ppr wanted
+	  , ptext (sLit "Binds = ") <+> ppr binds
+          , pprSkolInfo (ctLocOrigin loc)
+          , ppr (ctLocSpan loc) ])
 \end{code}
-
 
 %************************************************************************
 %*									*
-\subsection[Inst-origin]{The @InstOrigin@ type}
+            CtLoc, CtOrigin
 %*									*
 %************************************************************************
 
-The @InstOrigin@ type gives information about where a dictionary came from.
-This is important for decent error message reporting because dictionaries
-don't appear in the original source code.  Doubtless this type will evolve...
-
-It appears in TcMonad because there are a couple of error-message-generation
-functions that deal with it.
+The 'CtLoc' and 'CtOrigin' types gives information about where a
+*wanted constraint* came from.  This is important for decent error
+message reporting because dictionaries don't appear in the original
+source code.  Doubtless this type will evolve...
 
 \begin{code}
 -------------------------------------------
-data InstLoc = InstLoc InstOrigin SrcSpan [ErrCtxt]
-
-instLoc :: Inst -> InstLoc
-instLoc inst = tci_loc inst
-
-setInstLoc :: Inst -> InstLoc -> Inst
-setInstLoc inst new_loc = inst { tci_loc = new_loc }
+data CtLoc orig = CtLoc orig SrcSpan [ErrCtxt]
 
-instSpan :: Inst -> SrcSpan
-instSpan wanted = instLocSpan (instLoc wanted)
+ctLocSpan :: CtLoc o -> SrcSpan
+ctLocSpan (CtLoc _ s _) = s
 
-instLocSpan :: InstLoc -> SrcSpan
-instLocSpan (InstLoc _ s _) = s
+ctLocOrigin :: CtLoc o -> o
+ctLocOrigin (CtLoc o _ _) = o
 
-instLocOrigin :: InstLoc -> InstOrigin
-instLocOrigin (InstLoc o _ _) = o
+setCtLocOrigin :: CtLoc o -> o' -> CtLoc o'
+setCtLocOrigin (CtLoc _ s c) o = CtLoc o s c
 
-pprInstArising :: Inst -> SDoc
-pprInstArising loc = ptext (sLit "arising from") <+> pprInstLoc (tci_loc loc)
+pprArising :: CtLoc CtOrigin -> SDoc
+pprArising loc = case ctLocOrigin loc of
+                   TypeEqOrigin -> empty
+                   _ -> text "arising from" <+> ppr (ctLocOrigin loc)
 
-pprInstLoc :: InstLoc -> SDoc
-pprInstLoc (InstLoc orig span _) = sep [ppr orig, text "at" <+> ppr span]
+pprArisingAt :: CtLoc CtOrigin -> SDoc
+pprArisingAt loc = sep [pprArising loc, text "at" <+> ppr (ctLocSpan loc)]
 
 -------------------------------------------
-data InstOrigin
-  = SigOrigin SkolemInfo	-- Pattern, class decl, inst decl etc;
-				-- Places that bind type variables and introduce
-				-- available constraints
+-- CtOrigin gives the origin of *wanted* constraints
+data CtOrigin
+  = OccurrenceOf Name		-- Occurrence of an overloaded identifier
+  | AppOrigin	 		-- An application of some kind
 
-  | IPBindOrigin (IPName Name)	-- Binding site of an implicit parameter
-
-	-------------------------------------------------------
-	-- The rest are all occurrences: Insts that are 'wanted'
-	-------------------------------------------------------
-  | OccurrenceOf Name		-- Occurrence of an overloaded identifier
   | SpecPragOrigin Name		-- Specialisation pragma for identifier
 
+  | TypeEqOrigin
+
   | IPOccOrigin  (IPName Name)	-- Occurrence of an implicit parameter
 
   | LiteralOrigin (HsOverLit Name)	-- Occurrence of a literal
@@ -948,53 +873,55 @@ data InstOrigin
 
   | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc
   | PArrSeqOrigin  (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:]
+  | SectionOrigin
   | TupleOrigin			       -- (..,..)
-
-  | InstSigOrigin	-- A dict occurrence arising from instantiating
-			-- a polymorphic type during a subsumption check
-
   | ExprSigOrigin	-- e :: ty
+  | PatSigOrigin	-- p :: ty
+  | PatOrigin	        -- Instantiating a polytyped pattern at a constructor
   | RecordUpdOrigin
   | ViewPatOrigin
 
-  | InstScOrigin	-- Typechecking superclasses of an instance declaration
-
-  | NoScOrigin          -- A very special hack; see TcSimplify,
-			--   Note [Recursive instances and superclases]
-			   
-
+  | ScOrigin	        -- Typechecking superclasses of an instance declaration
   | DerivOrigin		-- Typechecking deriving
   | StandAloneDerivOrigin -- Typechecking stand-alone deriving
   | DefaultOrigin	-- Typechecking a default decl
   | DoOrigin		-- Arising from a do expression
   | ProcOrigin		-- Arising from a proc expression
-  | ImplicOrigin SDoc	-- An implication constraint
-  | EqOrigin		-- A type equality
   | AnnOrigin           -- An annotation
 
-instance Outputable InstOrigin where
-    ppr (OccurrenceOf name)   = hsep [ptext (sLit "a use of"), quotes (ppr name)]
-    ppr (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)]
-    ppr (IPOccOrigin name)    = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)]
-    ppr (IPBindOrigin name)   = hsep [ptext (sLit "a binding for implicit parameter"), quotes (ppr name)]
-    ppr RecordUpdOrigin       = ptext (sLit "a record update")
-    ppr ExprSigOrigin         = ptext (sLit "an expression type signature")
-    ppr ViewPatOrigin         = ptext (sLit "a view pattern")
-    ppr (LiteralOrigin lit)   = hsep [ptext (sLit "the literal"), quotes (ppr lit)]
-    ppr (ArithSeqOrigin seq)  = hsep [ptext (sLit "the arithmetic sequence"), quotes (ppr seq)]
-    ppr (PArrSeqOrigin seq)   = hsep [ptext (sLit "the parallel array sequence"), quotes (ppr seq)]
-    ppr TupleOrigin	      = ptext (sLit "a tuple")
-    ppr NegateOrigin	      = ptext (sLit "a use of syntactic negation")
-    ppr InstScOrigin	      = ptext (sLit "the superclasses of an instance declaration")
-    ppr NoScOrigin            = ptext (sLit "an instance declaration")
-    ppr DerivOrigin	      = ptext (sLit "the 'deriving' clause of a data type declaration")
-    ppr StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
-    ppr DefaultOrigin	      = ptext (sLit "a 'default' declaration")
-    ppr DoOrigin	      = ptext (sLit "a do statement")
-    ppr ProcOrigin	      = ptext (sLit "a proc expression")
-    ppr (ImplicOrigin doc)    = doc
-    ppr (SigOrigin info)      = pprSkolInfo info
-    ppr EqOrigin	      = ptext (sLit "a type equality")
-    ppr InstSigOrigin         = panic "ppr InstSigOrigin"
-    ppr AnnOrigin             = ptext (sLit "an annotation")
+data EqOrigin 
+  = UnifyOrigin 
+       { uo_actual   :: TcType
+       , uo_expected :: TcType }
+
+instance Outputable CtOrigin where
+  ppr orig = pprO orig
+
+pprO :: CtOrigin -> SDoc
+pprO (OccurrenceOf name)   = hsep [ptext (sLit "a use of"), quotes (ppr name)]
+pprO AppOrigin             = ptext (sLit "an application")
+pprO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)]
+pprO (IPOccOrigin name)    = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)]
+pprO RecordUpdOrigin       = ptext (sLit "a record update")
+pprO ExprSigOrigin         = ptext (sLit "an expression type signature")
+pprO PatSigOrigin          = ptext (sLit "a pattern type signature")
+pprO PatOrigin             = ptext (sLit "a pattern")
+pprO ViewPatOrigin         = ptext (sLit "a view pattern")
+pprO (LiteralOrigin lit)   = hsep [ptext (sLit "the literal"), quotes (ppr lit)]
+pprO (ArithSeqOrigin seq)  = hsep [ptext (sLit "the arithmetic sequence"), quotes (ppr seq)]
+pprO (PArrSeqOrigin seq)   = hsep [ptext (sLit "the parallel array sequence"), quotes (ppr seq)]
+pprO SectionOrigin	   = ptext (sLit "an operator section")
+pprO TupleOrigin	   = ptext (sLit "a tuple")
+pprO NegateOrigin	   = ptext (sLit "a use of syntactic negation")
+pprO ScOrigin	           = ptext (sLit "the superclasses of an instance declaration")
+pprO DerivOrigin	   = ptext (sLit "the 'deriving' clause of a data type declaration")
+pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration")
+pprO DefaultOrigin	   = ptext (sLit "a 'default' declaration")
+pprO DoOrigin	           = ptext (sLit "a do statement")
+pprO ProcOrigin	           = ptext (sLit "a proc expression")
+pprO TypeEqOrigin          = ptext (sLit "an equality")
+pprO AnnOrigin             = ptext (sLit "an annotation")
+
+instance Outputable EqOrigin where
+  ppr (UnifyOrigin t1 t2) = ppr t1 <+> char '~' <+> ppr t2
 \end{code}
diff --git a/compiler/typecheck/TcRules.lhs b/compiler/typecheck/TcRules.lhs
index e489870..83ec995 100644
--- a/compiler/typecheck/TcRules.lhs
+++ b/compiler/typecheck/TcRules.lhs
@@ -16,12 +16,14 @@ import TcType
 import TcHsType
 import TcExpr
 import TcEnv
-import Inst
 import Id
+import Var	( Var )
 import Name
+import VarSet
 import SrcLoc
 import Outputable
 import FastString
+import Data.List( partition )
 \end{code}
 
 Note [Typechecking rules]
@@ -45,37 +47,35 @@ tcRules :: [LRuleDecl Name] -> TcM [LRuleDecl TcId]
 tcRules decls = mapM (wrapLocM tcRule) decls
 
 tcRule :: RuleDecl Name -> TcM (RuleDecl TcId)
-tcRule (HsRule name act vars lhs fv_lhs rhs fv_rhs)
-  = addErrCtxt (ruleCtxt name)			$ do
-    traceTc (ptext (sLit "---- Rule ------") <+> ppr name)
-
-	-- Deal with the tyvars mentioned in signatures
-    (ids, lhs', rhs', lhs_lie, rhs_lie, rule_ty) <-
-      tcRuleBndrs vars $ \ ids -> do
-		-- Now LHS and RHS; see Note [Typechecking rules]
-        ((lhs', rule_ty), lhs_lie) <- getLIE (tcInferRho lhs)
-        (rhs', rhs_lie) <- getLIE (tcMonoExpr rhs rule_ty)
-        return (ids, lhs', rhs', lhs_lie, rhs_lie, rule_ty)
-
-		-- Check that LHS has no overloading at all
-    (lhs_dicts, lhs_binds) <- tcSimplifyRuleLhs lhs_lie
-
-	-- Gather the template variables and tyvars
-    let
-	tpl_ids = map instToId lhs_dicts ++ ids
+tcRule (HsRule name act hs_bndrs lhs fv_lhs rhs fv_rhs)
+  = addErrCtxt (ruleCtxt name)	$
+    do { traceTc "---- Rule ------" (ppr name)
+
+    	-- Note [Typechecking rules]
+       ; vars <- tcRuleBndrs hs_bndrs
+       ; let (id_bndrs, tv_bndrs) = partition isId vars
+       ; (lhs', lhs_lie, rhs', rhs_lie, rule_ty)
+            <- tcExtendTyVarEnv tv_bndrs $
+               tcExtendIdEnv id_bndrs $
+               do { ((lhs', rule_ty), lhs_lie) <- getConstraints (tcInferRho lhs)
+                  ; (rhs', rhs_lie) <- getConstraints (tcMonoExpr rhs rule_ty)
+                  ; return (lhs', lhs_lie, rhs', rhs_lie, rule_ty) }
+
+       ; (lhs_dicts, lhs_ev_binds, rhs_ev_binds) 
+             <- simplifyRule name tv_bndrs lhs_lie rhs_lie
 
 	-- IMPORTANT!  We *quantify* over any dicts that appear in the LHS
 	-- Reason: 
-	--	a) The particular dictionary isn't important, because its value
+	--	(a) The particular dictionary isn't important, because its value
 	--	   depends only on the type
 	--		e.g	gcd Int $fIntegralInt
 	--         Here we'd like to match against (gcd Int any_d) for any 'any_d'
 	--
-	--	b) We'd like to make available the dictionaries bound 
-	--	   on the LHS in the RHS, so quantifying over them is good
-	--	   See the 'lhs_dicts' in tcSimplifyAndCheck for the RHS
+	--	(b) We'd like to make available the dictionaries bound 
+	--	    on the LHS in the RHS, so quantifying over them is good
+	--	    See the 'lhs_dicts' in tcSimplifyAndCheck for the RHS
 
-	-- We initially quantify over any tyvars free in *either* the rule
+	-- We quantify over any tyvars free in *either* the rule
 	--  *or* the bound variables.  The latter is important.  Consider
 	--	ss (x,(y,z)) = (x,z)
 	--	RULE:  forall v. fst (ss v) = fst v
@@ -83,32 +83,29 @@ tcRule (HsRule name act vars lhs fv_lhs rhs fv_rhs)
 	--
 	-- We also need to get the free tyvars of the LHS; but we do that
 	-- during zonking (see TcHsSyn.zonkRule)
-	--
-	forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids)
 
-	-- RHS can be a bit more lenient.  In particular,
-	-- we let constant dictionaries etc float outwards
-	--
-	-- NB: tcSimplifyInferCheck zonks the forall_tvs, and 
-	--     knocks out any that are constrained by the environment
-    loc <- getInstLoc (SigOrigin (RuleSkol name))
-    (forall_tvs1, rhs_binds) <- tcSimplifyInferCheck loc
-                                        forall_tvs
-                                        lhs_dicts rhs_lie
-
-    return (HsRule name act
-		    (map (RuleBndr . noLoc) (forall_tvs1 ++ tpl_ids))	-- yuk
-		    (mkHsDictLet lhs_binds lhs') fv_lhs
-		    (mkHsDictLet rhs_binds rhs') fv_rhs)
-
-tcRuleBndrs :: [RuleBndr Name] -> ([Id] -> TcM a) -> TcM a
-tcRuleBndrs [] thing_inside = thing_inside []
-tcRuleBndrs (RuleBndr var : vars) thing_inside
+       ; let tpl_ids    = lhs_dicts ++ id_bndrs
+             forall_tvs = tyVarsOfTypes (rule_ty : map idType tpl_ids)
+
+	     -- Now figure out what to quantify over
+	     -- c.f. TcSimplify.simplifyInfer
+       ; zonked_forall_tvs <- zonkTcTyVarsAndFV (varSetElems forall_tvs)
+       ; gbl_tvs           <- tcGetGlobalTyVars	     -- Already zonked
+       ; qtvs <- zonkQuantifiedTyVars (varSetElems (zonked_forall_tvs `minusVarSet` gbl_tvs))
+
+       ; return (HsRule name act
+		    (map (RuleBndr . noLoc) (qtvs ++ tpl_ids))	-- yuk
+		    (mkHsDictLet lhs_ev_binds lhs') fv_lhs
+		    (mkHsDictLet rhs_ev_binds rhs') fv_rhs) }
+
+tcRuleBndrs :: [RuleBndr Name] -> TcM [Var]
+tcRuleBndrs [] 
+  = return []
+tcRuleBndrs (RuleBndr var : rule_bndrs)
   = do 	{ ty <- newFlexiTyVarTy openTypeKind
-	; let id = mkLocalId (unLoc var) ty
-	; tcExtendIdEnv [id] $
-	  tcRuleBndrs vars (\ids -> thing_inside (id:ids)) }
-tcRuleBndrs (RuleBndrSig var rn_ty : vars) thing_inside
+        ; vars <- tcRuleBndrs rule_bndrs
+	; return (mkLocalId (unLoc var) ty : vars) }
+tcRuleBndrs (RuleBndrSig var rn_ty : rule_bndrs)
 --  e.g 	x :: a->a
 --  The tyvar 'a' is brought into scope first, just as if you'd written
 --		a::*, x :: a->a
@@ -117,9 +114,11 @@ tcRuleBndrs (RuleBndrSig var rn_ty : vars) thing_inside
 	; let skol_tvs = tcSkolSigTyVars (SigSkol ctxt) tyvars
 	      id_ty = substTyWith tyvars (mkTyVarTys skol_tvs) ty
 	      id = mkLocalId (unLoc var) id_ty
-	; tcExtendTyVarEnv skol_tvs $
-	  tcExtendIdEnv [id] $
-	  tcRuleBndrs vars (\ids -> thing_inside (id:ids)) }
+
+	      -- The type variables scope over subsequent bindings; yuk
+        ; vars <- tcExtendTyVarEnv skol_tvs $ 
+                  tcRuleBndrs rule_bndrs 
+	; return (skol_tvs ++ id : vars) }
 
 ruleCtxt :: FastString -> SDoc
 ruleCtxt name = ptext (sLit "When checking the transformation rule") <+> 
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
new file mode 100644
index 0000000..73a7229
--- /dev/null
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -0,0 +1,799 @@
+\begin{code}
+-- Type definitions for the constraint solver
+module TcSMonad ( 
+
+       -- Canonical constraints
+    CanonicalCts, emptyCCan, andCCan, andCCans, 
+    singleCCan, extendCCans, isEmptyCCan,
+    CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals,
+    mkWantedConstraints, deCanonicaliseWanted, 
+    makeGivens, makeSolved,
+
+    CtFlavor (..), isWanted, isGiven, isDerived, canRewrite, 
+    joinFlavors, mkGivenFlavor,
+
+    TcS, runTcS, failTcS, panicTcS, traceTcS, traceTcS0,  -- Basic functionality 
+    tryTcS, nestImplicTcS, wrapErrTcS, wrapWarnTcS,
+    SimplContext(..), isInteractive, simplEqsOnly, performDefaulting,
+       
+       -- Creation of evidence variables
+
+    newWantedCoVar, newGivOrDerCoVar, newGivOrDerEvVar, 
+    newIPVar, newDictVar, newKindConstraint,
+
+       -- Setting evidence variables 
+    setWantedCoBind, setDerivedCoBind, 
+    setIPBind, setDictBind, setEvBind,
+
+    setWantedTyBind,
+
+    newTcEvBindsTcS,
+ 
+    getInstEnvs, getFamInstEnvs,                -- Getting the environments 
+    getTopEnv, getGblEnv, getTcEvBinds, getUntouchablesTcS,
+    getTcEvBindsBag, getTcSContext,
+
+
+    newFlattenSkolemTy,                         -- Flatten skolems 
+
+    instDFunTypes,                              -- Instantiation
+    instDFunConstraints,                        
+
+    isGoodRecEv,
+
+    isTouchableMetaTyVar,
+
+    getDefaultInfo, getDynFlags,
+
+    matchClass, matchFam, MatchInstResult (..), 
+    checkWellStagedDFun, 
+    warnTcS,
+    pprEq,                                   -- Smaller utils, re-exported from TcM 
+                                             -- TODO (DV): these are only really used in the 
+                                             -- instance matcher in TcSimplify. I am wondering
+                                             -- if the whole instance matcher simply belongs
+                                             -- here 
+
+
+    mkWantedFunDepEqns                       -- Instantiation of 'Equations' from FunDeps
+
+) where 
+
+#include "HsVersions.h"
+
+import HscTypes
+import BasicTypes 
+import Type
+import TcRnTypes
+
+import Inst
+import InstEnv 
+import FamInst 
+import FamInstEnv
+
+import NameSet ( addOneToNameSet ) 
+
+import qualified TcRnMonad as TcM
+import qualified TcMType as TcM
+import qualified TcEnv as TcM 
+       ( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys )
+import TcType
+import Module 
+import DynFlags
+
+import Coercion
+import Class
+import TyCon
+import Name
+import Var
+import Outputable
+import Bag
+import MonadUtils
+import VarSet
+import FastString
+
+import HsBinds               -- for TcEvBinds stuff 
+import Id 
+import FunDeps
+
+import Control.Monad
+import Data.IORef
+\end{code}
+
+
+%************************************************************************
+%*									*
+%*                       Canonical constraints                          *
+%*                                                                      *
+%*   These are the constraints the low-level simplifier works with      *
+%*									*
+%************************************************************************
+
+\begin{code}
+-- Types without any type functions inside.  However, note that xi
+-- types CAN contain unexpanded type synonyms; however, the
+-- (transitive) expansions of those type synonyms will not contain any
+-- type functions.
+type Xi = Type       -- In many comments, "xi" ranges over Xi
+
+type CanonicalCts = Bag CanonicalCt
+ 
+data CanonicalCt
+  -- Atomic canonical constraints 
+  = CDictCan {  -- e.g.  Num xi
+      cc_id     :: EvVar,
+      cc_flavor :: CtFlavor, 
+      cc_class  :: Class, 
+      cc_tyargs :: [Xi]
+    }
+
+  | CIPCan {	-- ?x::tau
+      -- See note [Canonical implicit parameter constraints].
+      cc_id     :: EvVar,
+      cc_flavor :: CtFlavor, 
+      cc_ip_nm  :: IPName Name,
+      cc_ip_ty  :: TcTauType
+    }
+
+  | CTyEqCan {  -- tv ~ xi	(recall xi means function free)
+       -- Invariant: 
+       --   * tv not in tvs(xi)   (occurs check)
+       --   * If tv is a MetaTyVar, then typeKind xi <: typeKind tv 
+       --              a skolem,    then typeKind xi =  typeKind tv 
+      cc_id     :: EvVar, 
+      cc_flavor :: CtFlavor, 
+      cc_tyvar :: TcTyVar, 
+      cc_rhs   :: Xi
+    }
+
+  | CFunEqCan {  -- F xis ~ xi  
+                 -- Invariant: * isSynFamilyTyCon cc_fun 
+                 --            * cc_rhs is not a touchable unification variable 
+                 --                   See Note [No touchables as FunEq RHS]
+                 --            * typeKind (TyConApp cc_fun cc_tyargs) == typeKind cc_rhs
+      cc_id     :: EvVar,
+      cc_flavor :: CtFlavor, 
+      cc_fun    :: TyCon,	-- A type function
+      cc_tyargs :: [Xi],	-- Either under-saturated or exactly saturated
+      cc_rhs    :: Xi      	--    *never* over-saturated (because if so
+      		      		--    we should have decomposed)
+                   
+    }
+
+makeGivens :: CanonicalCts -> CanonicalCts
+makeGivens = mapBag (\ct -> ct { cc_flavor = mkGivenFlavor (cc_flavor ct) UnkSkol })
+	   -- The UnkSkol doesn't matter because these givens are
+	   -- not contradictory (else we'd have rejected them already)
+
+makeSolved :: CanonicalCt -> CanonicalCt
+-- Record that a constraint is now solved
+-- 	  Wanted         -> Derived
+--	  Given, Derived -> no-op
+makeSolved ct 
+  | Wanted loc <- cc_flavor ct = ct { cc_flavor = Derived loc }
+  | otherwise                  = ct
+
+mkWantedConstraints :: CanonicalCts -> Bag Implication -> WantedConstraints
+mkWantedConstraints flats implics 
+  = mapBag (WcEvVar . deCanonicaliseWanted) flats `unionBags` mapBag WcImplic implics
+
+deCanonicaliseWanted :: CanonicalCt -> WantedEvVar
+deCanonicaliseWanted ct 
+  = WARN( not (isWanted $ cc_flavor ct), ppr ct ) 
+    let Wanted loc = cc_flavor ct 
+    in WantedEvVar (cc_id ct) loc
+
+tyVarsOfCanonical :: CanonicalCt -> TcTyVarSet
+tyVarsOfCanonical (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })    = extendVarSet (tyVarsOfType xi) tv
+tyVarsOfCanonical (CFunEqCan { cc_tyargs = tys, cc_rhs = xi }) = tyVarsOfTypes (xi:tys)
+tyVarsOfCanonical (CDictCan { cc_tyargs = tys }) 	       = tyVarsOfTypes tys
+tyVarsOfCanonical (CIPCan { cc_ip_ty = ty })     	       = tyVarsOfType ty
+
+tyVarsOfCanonicals :: CanonicalCts -> TcTyVarSet
+tyVarsOfCanonicals = foldrBag (unionVarSet . tyVarsOfCanonical) emptyVarSet
+
+instance Outputable CanonicalCt where
+  ppr (CDictCan d fl cls tys)     
+      = ppr fl <+> ppr d  <+> dcolon <+> pprClassPred cls tys
+  ppr (CIPCan ip fl ip_nm ty)     
+      = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty)
+  ppr (CTyEqCan co fl tv ty)      
+      = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyVarTy tv, ty)
+  ppr (CFunEqCan co fl tc tys ty) 
+      = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyConApp tc tys, ty)
+\end{code}
+
+
+Note [No touchables as FunEq RHS]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that (F xis ~ beta), where beta is an touchable unification
+variable, is not canonical.  Why?  
+  * If (F xis ~ beta) was the only wanted constraint, we'd 
+    definitely want to spontaneously-unify it
+
+  * But suppose we had an earlier wanted (beta ~ Int), and 
+    have already spontaneously unified it.  Then we have an
+    identity given (id : beta ~ Int) in the inert set.  
+
+  * But (F xis ~ beta) does not react with that given (because we
+    don't subsitute on the RHS of a function equality).  So there's a
+    serious danger that we'd spontaneously unify it a second time.
+
+Hence the invariant.
+
+Note [Canonical implicit parameter constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The type in a canonical implicit parameter constraint doesn't need to
+be a xi (type-function-free type) since we can defer the flattening
+until checking this type for equality with another type.  If we
+encounter two IP constraints with the same name, they MUST have the
+same type, and at that point we can generate a flattened equality
+constraint between the types.  (On the other hand, the types in two
+class constraints for the same class MAY be equal, so they need to be
+flattened in the first place to facilitate comparing them.)
+
+\begin{code}
+singleCCan :: CanonicalCt -> CanonicalCts 
+singleCCan = unitBag 
+
+andCCan :: CanonicalCts -> CanonicalCts -> CanonicalCts 
+andCCan = unionBags
+
+extendCCans :: CanonicalCts -> CanonicalCt -> CanonicalCts 
+extendCCans = snocBag 
+
+andCCans :: [CanonicalCts] -> CanonicalCts 
+andCCans = unionManyBags
+
+emptyCCan :: CanonicalCts 
+emptyCCan = emptyBag
+
+isEmptyCCan :: CanonicalCts -> Bool
+isEmptyCCan = isEmptyBag
+\end{code}
+
+%************************************************************************
+%*									*
+                    CtFlavor
+         The "flavor" of a canonical constraint
+%*									*
+%************************************************************************
+
+\begin{code}
+data CtFlavor 
+  = Given   GivenLoc  -- We have evidence for this constraint in TcEvBinds
+  | Derived WantedLoc -- We have evidence for this constraint in TcEvBinds;
+                      --   *however* this evidence can contain wanteds, so 
+                      --   it's valid only provisionally to the solution of
+                      --   these wanteds 
+  | Wanted WantedLoc  -- We have no evidence bindings for this constraint. 
+
+instance Outputable CtFlavor where 
+  ppr (Given _)   = ptext (sLit "[Given]")
+  ppr (Wanted _)  = ptext (sLit "[Wanted]")
+  ppr (Derived _) = ptext (sLit "[Derived]") 
+
+isWanted :: CtFlavor -> Bool 
+isWanted (Wanted {}) = True
+isWanted _           = False
+
+isGiven :: CtFlavor -> Bool 
+isGiven (Given {}) = True 
+isGiven _          = False 
+
+isDerived :: CtFlavor -> Bool 
+isDerived ctid =  not $ isGiven ctid || isWanted ctid 
+
+canRewrite :: CtFlavor -> CtFlavor -> Bool 
+-- canRewrite ctid1 ctid2 
+-- The constraint ctid1 can be used to rewrite ctid2 
+canRewrite (Given {})   _            = True 
+canRewrite (Derived {}) (Wanted {})  = True 
+canRewrite (Derived {}) (Derived {}) = True 
+canRewrite (Wanted {})  (Wanted {})  = True
+canRewrite _ _ = False
+
+joinFlavors :: CtFlavor -> CtFlavor -> CtFlavor 
+joinFlavors (Wanted loc) _  = Wanted loc 
+joinFlavors _ (Wanted loc)  = Wanted loc 
+joinFlavors (Derived loc) _ = Derived loc 
+joinFlavors _ (Derived loc) = Derived loc 
+joinFlavors (Given loc) _   = Given loc
+
+mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor
+mkGivenFlavor (Wanted  loc) sk = Given (setCtLocOrigin loc sk)
+mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk)
+mkGivenFlavor (Given   loc) sk = Given (setCtLocOrigin loc sk)
+\end{code}
+
+
+%************************************************************************
+%*									*
+%*		The TcS solver monad                                    *
+%*									*
+%************************************************************************
+
+Note [The TcS monad]
+~~~~~~~~~~~~~~~~~~~~
+The TcS monad is a weak form of the main Tc monad
+
+All you can do is
+    * fail
+    * allocate new variables
+    * fill in evidence variables
+
+Filling in a dictionary evidence variable means to create a binding
+for it, so TcS carries a mutable location where the binding can be
+added.  This is initialised from the innermost implication constraint.
+
+\begin{code}
+data TcSEnv
+  = TcSEnv { 
+      tcs_ev_binds :: EvBindsVar,
+          -- Evidence bindings
+
+      tcs_ty_binds :: IORef (Bag (TcTyVar, TcType)),
+          -- Global type bindings
+
+      tcs_context :: SimplContext
+    }
+
+data SimplContext
+  = SimplInfer		-- Inferring type of a let-bound thing
+  | SimplRuleLhs	-- Inferring type of a RULE lhs
+  | SimplInteractive	-- Inferring type at GHCi prompt
+  | SimplCheck		-- Checking a type signature or RULE rhs
+
+instance Outputable SimplContext where
+  ppr SimplInfer       = ptext (sLit "SimplInfer")
+  ppr SimplRuleLhs     = ptext (sLit "SimplRuleLhs")
+  ppr SimplInteractive = ptext (sLit "SimplInteractive")
+  ppr SimplCheck       = ptext (sLit "SimplCheck")
+
+isInteractive :: SimplContext -> Bool
+isInteractive SimplInteractive = True
+isInteractive _                = False
+
+simplEqsOnly :: SimplContext -> Bool
+-- Simplify equalities only, not dictionaries
+-- This is used for the LHS of rules; ee
+-- Note [Simplifying RULE lhs constraints] in TcSimplify
+simplEqsOnly SimplRuleLhs = True
+simplEqsOnly _            = False
+
+performDefaulting :: SimplContext -> Bool
+performDefaulting SimplInfer   	   = False
+performDefaulting SimplRuleLhs 	   = False
+performDefaulting SimplInteractive = True
+performDefaulting SimplCheck       = True
+
+---------------
+newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } 
+
+instance Functor TcS where
+  fmap f m = TcS $ fmap f . unTcS m
+
+instance Monad TcS where 
+  return x  = TcS (\_ -> return x) 
+  fail err  = TcS (\_ -> fail err) 
+  m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)
+
+-- Basic functionality 
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+wrapTcS :: TcM a -> TcS a 
+-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,
+-- and TcS is supposed to have limited functionality
+wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds
+
+wrapErrTcS :: TcM a -> TcS a 
+-- The thing wrapped should just fail
+-- There's no static check; it's up to the user
+-- Having a variant for each error message is too painful
+wrapErrTcS = wrapTcS
+
+wrapWarnTcS :: TcM a -> TcS a 
+-- The thing wrapped should just add a warning, or no-op
+-- There's no static check; it's up to the user
+wrapWarnTcS = wrapTcS
+
+failTcS, panicTcS :: SDoc -> TcS a
+failTcS      = wrapTcS . TcM.failWith
+panicTcS doc = pprPanic "TcCanonical" doc
+
+traceTcS :: String -> SDoc -> TcS ()
+traceTcS herald doc = TcS $ \_env -> TcM.traceTc herald doc
+
+traceTcS0 :: String -> SDoc -> TcS ()
+traceTcS0 herald doc = TcS $ \_env -> TcM.traceTcN 0 herald doc
+
+runTcS :: SimplContext
+       -> TcTyVarSet 	       -- Untouchables
+       -> TcS a		       -- What to run
+       -> TcM (a, Bag EvBind)
+runTcS context untouch tcs 
+  = do { ty_binds_var <- TcM.newTcRef emptyBag
+       ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds
+       ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
+                          , tcs_ty_binds = ty_binds_var
+                          , tcs_context = context }
+
+	     -- Run the computation
+       ; res <- TcM.setUntouchables untouch (unTcS tcs env)
+
+	     -- Perform the type unifications required
+       ; ty_binds <- TcM.readTcRef ty_binds_var
+       ; mapBagM_ do_unification ty_binds
+
+             -- And return
+       ; ev_binds <- TcM.readTcRef evb_ref
+       ; return (res, evBindMapBinds ev_binds) }
+  where
+    do_unification (tv,ty) = TcM.writeMetaTyVar tv ty
+       
+nestImplicTcS :: EvBindsVar -> TcTyVarSet -> TcS a -> TcS a 
+nestImplicTcS ref untouch tcs 
+  = TcS $ \ TcSEnv { tcs_ty_binds = ty_binds, tcs_context = ctxt } -> 
+    let 
+       nest_env = TcSEnv { tcs_ev_binds = ref
+                         , tcs_ty_binds = ty_binds
+                         , tcs_context = ctxtUnderImplic ctxt }
+    in 
+    TcM.setUntouchables untouch (unTcS tcs nest_env) 
+
+ctxtUnderImplic :: SimplContext -> SimplContext
+-- See Note [Simplifying RULE lhs constraints] in TcSimplify
+ctxtUnderImplic SimplRuleLhs = SimplCheck
+ctxtUnderImplic ctxt         = ctxt
+
+tryTcS :: TcTyVarSet -> TcS a -> TcS a 
+-- Like runTcS, but from within the TcS monad 
+-- Ignore all the evidence generated, and do not affect caller's evidence!
+tryTcS untch tcs 
+  = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyBag
+                    ; ev_binds_var <- TcM.newTcEvBinds
+                    ; let env1 = env { tcs_ev_binds = ev_binds_var
+                                     , tcs_ty_binds = ty_binds_var }
+                    ; TcM.setUntouchables untch (unTcS tcs env1) })
+
+-- Update TcEvBinds 
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+getDynFlags :: TcS DynFlags
+getDynFlags = wrapTcS TcM.getDOpts
+
+getTcSContext :: TcS SimplContext
+getTcSContext = TcS (return . tcs_context)
+
+getTcEvBinds :: TcS EvBindsVar
+getTcEvBinds = TcS (return . tcs_ev_binds) 
+
+getTcSTyBinds :: TcS (IORef (Bag (TcTyVar, TcType)))
+getTcSTyBinds = TcS (return . tcs_ty_binds)
+
+getTcEvBindsBag :: TcS EvBindMap
+getTcEvBindsBag
+  = do { EvBindsVar ev_ref _ <- getTcEvBinds 
+       ; wrapTcS $ TcM.readTcRef ev_ref }
+
+setWantedCoBind :: CoVar -> Coercion -> TcS () 
+setWantedCoBind cv co 
+  = setEvBind cv (EvCoercion co)
+     -- Was: wrapTcS $ TcM.writeWantedCoVar cv co 
+
+setDerivedCoBind :: CoVar -> Coercion -> TcS () 
+setDerivedCoBind cv co 
+  = setEvBind cv (EvCoercion co)
+
+setWantedTyBind :: TcTyVar -> TcType -> TcS () 
+-- Add a type binding
+setWantedTyBind tv ty 
+  = do { ref <- getTcSTyBinds
+       ; wrapTcS $ 
+         do { ty_binds <- TcM.readTcRef ref
+            ; TcM.writeTcRef ref (ty_binds `snocBag` (tv,ty)) } }
+
+setIPBind :: EvVar -> EvTerm -> TcS () 
+setIPBind = setEvBind 
+
+setDictBind :: EvVar -> EvTerm -> TcS () 
+setDictBind = setEvBind 
+
+setEvBind :: EvVar -> EvTerm -> TcS () 
+-- Internal
+setEvBind ev rhs 
+  = do { tc_evbinds <- getTcEvBinds 
+       ; wrapTcS (TcM.addTcEvBind tc_evbinds ev rhs) }
+
+newTcEvBindsTcS :: TcS EvBindsVar
+newTcEvBindsTcS = wrapTcS (TcM.newTcEvBinds)
+
+warnTcS :: CtLoc orig -> Bool -> SDoc -> TcS ()
+warnTcS loc warn_if doc 
+  | warn_if   = wrapTcS $ TcM.setCtLoc loc $ TcM.addWarnTc doc
+  | otherwise = return ()
+
+getDefaultInfo ::  TcS (SimplContext, [Type], (Bool, Bool))
+getDefaultInfo 
+  = do { ctxt <- getTcSContext
+       ; (tys, flags) <- wrapTcS (TcM.tcGetDefaultTys (isInteractive ctxt))
+       ; return (ctxt, tys, flags) }
+
+-- Just get some environments needed for instance looking up and matching
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+getInstEnvs :: TcS (InstEnv, InstEnv) 
+getInstEnvs = wrapTcS $ Inst.tcGetInstEnvs 
+
+getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv) 
+getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs
+
+getTopEnv :: TcS HscEnv 
+getTopEnv = wrapTcS $ TcM.getTopEnv 
+
+getGblEnv :: TcS TcGblEnv 
+getGblEnv = wrapTcS $ TcM.getGblEnv 
+
+getUntouchablesTcS :: TcS TcTyVarSet 
+getUntouchablesTcS = wrapTcS $ TcM.getUntouchables
+
+-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+checkWellStagedDFun :: PredType -> DFunId -> WantedLoc -> TcS () 
+checkWellStagedDFun pred dfun_id loc 
+  = wrapTcS $ TcM.setCtLoc loc $ 
+    do { use_stage <- TcM.getStage
+       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }
+  where
+    pp_thing = ptext (sLit "instance for") <+> quotes (ppr pred)
+    bind_lvl = TcM.topIdLvl dfun_id
+
+pprEq :: TcType -> TcType -> SDoc
+pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2)
+
+isTouchableMetaTyVar :: TcTyVar -> TcS Bool
+-- is touchable variable!
+isTouchableMetaTyVar v 
+  | isMetaTyVar v = wrapTcS $ do { untch <- TcM.isUntouchable v; 
+                                 ; return (not untch) }
+  | otherwise     = return False
+
+
+-- Flatten skolems
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+newFlattenSkolemTy :: TcType -> TcS TcType
+newFlattenSkolemTy ty = mkTyVarTy <$> newFlattenSkolemTyVar ty
+  where newFlattenSkolemTyVar :: TcType -> TcS TcTyVar
+        newFlattenSkolemTyVar ty
+            = wrapTcS $ do { uniq <- TcM.newUnique
+                           ; let name = mkSysTvName uniq (fsLit "f")
+                           ; return $ mkTcTyVar name (typeKind ty) (FlatSkol ty)
+                           }
+
+-- Instantiations 
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+instDFunTypes :: [Either TyVar TcType] -> TcS [TcType] 
+instDFunTypes mb_inst_tys = 
+  let inst_tv :: Either TyVar TcType -> TcS Type
+      inst_tv (Left tv)  = wrapTcS $ TcM.tcInstTyVar tv >>= return . mkTyVarTy
+      inst_tv (Right ty) = return ty 
+  in mapM inst_tv mb_inst_tys
+
+
+instDFunConstraints :: TcThetaType -> TcS [EvVar] 
+instDFunConstraints preds = wrapTcS $ TcM.newWantedEvVars preds 
+
+
+-- Superclasses and recursive dictionaries 
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+newGivOrDerEvVar :: TcPredType -> EvTerm -> TcS EvVar 
+newGivOrDerEvVar pty evtrm 
+  = do { ev <- wrapTcS $ TcM.newEvVar pty 
+       ; setEvBind ev evtrm 
+       ; return ev }
+
+newGivOrDerCoVar :: TcType -> TcType -> Coercion -> TcS EvVar 
+-- Note we create immutable variables for given or derived, since we
+-- must bind them to TcEvBinds (because their evidence may involve 
+-- superclasses). However we should be able to override existing
+-- 'derived' evidence, even in TcEvBinds 
+newGivOrDerCoVar ty1 ty2 co 
+  = do { cv <- newCoVar ty1 ty2
+       ; setEvBind cv (EvCoercion co) 
+       ; return cv } 
+
+newWantedCoVar :: TcType -> TcType -> TcS EvVar 
+newWantedCoVar ty1 ty2 =  wrapTcS $ TcM.newWantedCoVar ty1 ty2 
+
+newKindConstraint :: TcType -> Kind -> TcS (CoVar, TcType)
+newKindConstraint ty kind =  wrapTcS $ TcM.newKindConstraint ty kind
+
+newCoVar :: TcType -> TcType -> TcS EvVar 
+newCoVar ty1 ty2 = wrapTcS $ TcM.newCoVar ty1 ty2 
+
+newIPVar :: IPName Name -> TcType -> TcS EvVar 
+newIPVar nm ty = wrapTcS $ TcM.newIP nm ty 
+
+newDictVar :: Class -> [TcType] -> TcS EvVar 
+newDictVar cl tys = wrapTcS $ TcM.newDict cl tys 
+\end{code} 
+
+
+\begin{code} 
+isGoodRecEv :: EvVar -> WantedEvVar -> TcS Bool 
+-- In a call (isGoodRecEv ev wv), we are considering solving wv 
+-- using some term that involves ev, such as:
+-- by setting		wv = ev
+-- or                   wv = EvCast x |> ev
+-- etc. 
+-- But that would be Very Bad if the evidence for 'ev' mentions 'wv',
+-- in an "unguarded" way. So isGoodRecEv looks at the evidence ev 
+-- recursively through the evidence binds, to see if uses of 'wv' are guarded.
+--
+-- Guarded means: more instance calls than superclass selections. We
+-- compute this by chasing the evidence, adding +1 for every instance
+-- call (constructor) and -1 for every superclass selection (destructor).
+--
+-- See Note [Superclasses and recursive dictionaries] in TcInteract
+isGoodRecEv ev_var (WantedEvVar wv _)
+  = do { tc_evbinds <- getTcEvBindsBag 
+       ; mb <- chase_ev_var tc_evbinds wv 0 [] ev_var 
+       ; return $ case mb of 
+                    Nothing -> True 
+                    Just min_guardedness -> min_guardedness > 0
+       }
+
+  where chase_ev_var :: EvBindMap   -- Evidence binds 
+                 -> EvVar           -- Target variable whose gravity we want to return
+                 -> Int             -- Current gravity 
+                 -> [EvVar]         -- Visited nodes
+                 -> EvVar           -- Current node 
+                 -> TcS (Maybe Int)
+        chase_ev_var assocs trg curr_grav visited orig
+            | trg == orig         = return $ Just curr_grav
+            | orig `elem` visited = return $ Nothing 
+            | Just (EvBind _ ev_trm) <- lookupEvBind assocs orig
+            = chase_ev assocs trg curr_grav (orig:visited) ev_trm
+
+{-  No longer needed: evidence is in the EvBinds
+            | isTcTyVar orig && isMetaTyVar orig 
+            = do { meta_details <- wrapTcS $ TcM.readWantedCoVar orig
+                 ; case meta_details of 
+                     Flexi -> return Nothing 
+                     Indirect tyco -> chase_ev assocs trg curr_grav 
+                                             (orig:visited) (EvCoercion tyco)
+                           }
+-}
+            | otherwise = return Nothing 
+
+        chase_ev assocs trg curr_grav visited (EvId v) 
+            = chase_ev_var assocs trg curr_grav visited v
+        chase_ev assocs trg curr_grav visited (EvSuperClass d_id _) 
+            = chase_ev_var assocs trg (curr_grav-1) visited d_id
+        chase_ev assocs trg curr_grav visited (EvCast v co)
+            = do { m1 <- chase_ev_var assocs trg curr_grav visited v
+                 ; m2 <- chase_co assocs trg curr_grav visited co
+                 ; return (comb_chase_res Nothing [m1,m2]) } 
+
+        chase_ev assocs trg curr_grav visited (EvCoercion co)
+            = chase_co assocs trg curr_grav visited co
+        chase_ev assocs trg curr_grav visited (EvDFunApp _ _ ev_vars) 
+            = do { chase_results <- mapM (chase_ev_var assocs trg (curr_grav+1) visited) ev_vars
+                 ; return (comb_chase_res Nothing chase_results) } 
+
+        chase_co assocs trg curr_grav visited co 
+            = -- Look for all the coercion variables in the coercion 
+              -- chase them, and combine the results. This is OK since the
+              -- coercion will not contain any superclass terms -- anything 
+              -- that involves dictionaries will be bound in assocs. 
+              let co_vars       = foldVarSet (\v vrs -> if isCoVar v then (v:vrs) else vrs) []
+                                             (tyVarsOfType co)
+              in do { chase_results <- mapM (chase_ev_var assocs trg curr_grav visited) co_vars
+                    ; return (comb_chase_res Nothing chase_results) } 
+
+        comb_chase_res f []                   = f 
+        comb_chase_res f (Nothing:rest)       = comb_chase_res f rest 
+        comb_chase_res Nothing (Just n:rest)  = comb_chase_res (Just n) rest
+        comb_chase_res (Just m) (Just n:rest) = comb_chase_res (Just (min n m)) rest 
+
+
+-- Matching and looking up classes and family instances
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+data MatchInstResult mi
+  = MatchInstNo         -- No matching instance 
+  | MatchInstSingle mi  -- Single matching instance
+  | MatchInstMany       -- Multiple matching instances
+
+
+matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Either TyVar TcType])) 
+-- Look up a class constraint in the instance environment
+matchClass clas tys
+  = do	{ let pred = mkClassPred clas tys 
+        ; instEnvs <- getInstEnvs
+	; case lookupInstEnv instEnvs clas tys of {
+            ([], unifs)               -- Nothing matches  
+                -> do { traceTcS "matchClass not matching"
+                                 (vcat [ text "dict" <+> ppr pred, 
+                                         text "unifs" <+> ppr unifs ]) 
+                      ; return MatchInstNo  
+                      } ;  
+	    ([(ispec, inst_tys)], []) -- A single match 
+		-> do	{ let dfun_id = is_dfun ispec
+			; traceTcS "matchClass success"
+				   (vcat [text "dict" <+> ppr pred, 
+				          text "witness" <+> ppr dfun_id
+					   <+> ppr (idType dfun_id) ])
+				  -- Record that this dfun is needed
+			; record_dfun_usage dfun_id
+			; return $ MatchInstSingle (dfun_id, inst_tys) 
+                        } ;
+     	    (matches, unifs)          -- More than one matches 
+		-> do	{ traceTcS "matchClass multiple matches, deferring choice"
+			           (vcat [text "dict" <+> ppr pred,
+				   	  text "matches" <+> ppr matches,
+				   	  text "unifs" <+> ppr unifs])
+                        ; return MatchInstMany 
+		        }
+	}
+        }
+  where record_dfun_usage :: Id -> TcS () 
+        record_dfun_usage dfun_id 
+          = do { hsc_env <- getTopEnv 
+               ; let  dfun_name = idName dfun_id
+        	      dfun_mod  = ASSERT( isExternalName dfun_name ) 
+        	         	  nameModule dfun_name
+               ; if isInternalName dfun_name ||    -- Internal name => defined in this module
+        	    modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
+        	 then return () -- internal, or in another package
+        	 else do updInstUses dfun_id 
+               }
+
+        updInstUses :: Id -> TcS () 
+        updInstUses dfun_id 
+            = do { tcg_env <- getGblEnv 
+                 ; wrapTcS $ TcM.updMutVar (tcg_inst_uses tcg_env) 
+                                            (`addOneToNameSet` idName dfun_id) 
+                 }
+
+matchFam :: TyCon 
+         -> [Type] 
+         -> TcS (MatchInstResult (TyCon, [Type]))
+matchFam tycon args
+  = do { mb <- wrapTcS $ TcM.tcLookupFamInst tycon args
+       ; case mb of 
+           Nothing  -> return MatchInstNo 
+           Just res -> return $ MatchInstSingle res
+       -- DV: We never return MatchInstMany, since tcLookupFamInst never returns 
+       -- multiple matches. Check. 
+       }
+
+
+-- Functional dependencies, instantiation of equations
+-------------------------------------------------------
+
+mkWantedFunDepEqns :: WantedLoc -> [(Equation, (PredType, SDoc), (PredType, SDoc))]
+                   -> TcS [WantedEvVar] 
+mkWantedFunDepEqns _   [] = return []
+mkWantedFunDepEqns loc eqns
+  = do { traceTcS "Improve:" (vcat (map pprEquationDoc eqns))
+       ; wevvars <- mapM to_work_item eqns
+       ; return $ concat wevvars }
+  where
+    to_work_item :: (Equation, (PredType,SDoc), (PredType,SDoc)) -> TcS [WantedEvVar]
+    to_work_item ((qtvs, pairs), _, _)
+      = do { (_, _, tenv) <- wrapTcS $ TcM.tcInstTyVars (varSetElems qtvs)
+           ; mapM (do_one tenv) pairs }
+
+    do_one tenv (ty1, ty2) = do { let sty1 = substTy tenv ty1 
+                                      sty2 = substTy tenv ty2 
+                                ; ev <- newWantedCoVar sty1 sty2
+                                ; return (WantedEvVar ev loc) }
+
+pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc
+pprEquationDoc (eqn, (p1, _), (p2, _)) 
+  = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
+\end{code}
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index e3f2955..546d96e 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -1,381 +1,343 @@
-%
-% (c) The University of Glasgow 2006
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-%
-
-TcSimplify
-
 \begin{code}
-module TcSimplify (
-	tcSimplifyInfer, tcSimplifyInferCheck,
-	tcSimplifyCheck, tcSimplifyRestricted,
-	tcSimplifyRuleLhs, tcSimplifyIPs, 
-	tcSimplifySuperClasses,
-	tcSimplifyTop, tcSimplifyInteractive,
-	tcSimplifyBracket, tcSimplifyCheckPat,
-
-	tcSimplifyDeriv, tcSimplifyDefault,
-	bindInstsOfLocalFuns, 
-	
-        misMatchMsg
-    ) where
+module TcSimplify( 
+       simplifyInfer, simplifySuperClass,
+       simplifyDefault, simplifyDeriv, simplifyBracket,
+       simplifyRule, simplifyTop, simplifyInteractive
+  ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} TcUnify( unifyType )
-import HsSyn
-
+import HsSyn	       
 import TcRnMonad
-import TcHsSyn	( hsLPatType )
-import Inst
-import TcEnv
-import InstEnv
-import TcType
+import TcErrors
+import TcCanonical
 import TcMType
-import TcIface
-import TcTyFuns
-import DsUtils	-- Big-tuple functions
+import TcType 
+import TcSMonad 
+import TcInteract
+import Inst
 import Var
-import Id
-import Name
-import NameSet
-import Class
-import FunDeps
-import PrelInfo
-import PrelNames
-import TysWiredIn
-import ErrUtils
-import BasicTypes
 import VarSet
-import VarEnv
-import FiniteMap
+import Name
+import NameEnv	( emptyNameEnv )
 import Bag
-import Outputable
 import ListSetOps
 import Util
-import SrcLoc
-import DynFlags
+import PrelInfo
+import PrelNames
+import Class		( classKey )
+import BasicTypes	( RuleName )
+import Data.List	( partition )
+import Outputable
 import FastString
-
-import Control.Monad
-import Data.List
 \end{code}
 
 
-%************************************************************************
-%*									*
-\subsection{NOTES}
-%*									*
-%************************************************************************
-
-	--------------------------------------
-	Notes on functional dependencies (a bug)
-	--------------------------------------
-
-Consider this:
-
-	class C a b | a -> b
-	class D a b | a -> b
-
-	instance D a b => C a b	-- Undecidable 
-				-- (Not sure if it's crucial to this eg)
-	f :: C a b => a -> Bool
-	f _ = True
-	
-	g :: C a b => a -> Bool
-	g = f
-
-Here f typechecks, but g does not!!  Reason: before doing improvement,
-we reduce the (C a b1) constraint from the call of f to (D a b1).
-
-Here is a more complicated example:
-
-@
-  > class Foo a b | a->b
-  >
-  > class Bar a b | a->b
-  >
-  > data Obj = Obj
-  >
-  > instance Bar Obj Obj
-  >
-  > instance (Bar a b) => Foo a b
-  >
-  > foo:: (Foo a b) => a -> String
-  > foo _ = "works"
-  >
-  > runFoo:: (forall a b. (Foo a b) => a -> w) -> w
-  > runFoo f = f Obj
-
-  *Test> runFoo foo
-
-  <interactive>:1:
-      Could not deduce (Bar a b) from the context (Foo a b)
-        arising from use of `foo' at <interactive>:1
-      Probable fix:
-          Add (Bar a b) to the expected type of an expression
-      In the first argument of `runFoo', namely `foo'
-      In the definition of `it': it = runFoo foo
-
-  Why all of the sudden does GHC need the constraint Bar a b? The
-  function foo didn't ask for that...
-@
-
-The trouble is that to type (runFoo foo), GHC has to solve the problem:
-
-	Given constraint	Foo a b
-	Solve constraint	Foo a b'
-
-Notice that b and b' aren't the same.  To solve this, just do
-improvement and then they are the same.  But GHC currently does
-	simplify constraints
-	apply improvement
-	and loop
-
-That is usually fine, but it isn't here, because it sees that Foo a b is
-not the same as Foo a b', and so instead applies the instance decl for
-instance Bar a b => Foo a b.  And that's where the Bar constraint comes
-from.
-
-The Right Thing is to improve whenever the constraint set changes at
-all.  Not hard in principle, but it'll take a bit of fiddling to do.  
-
-Note [Choosing which variables to quantify]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we are about to do a generalisation step.  We have in our hand
-
-	G	the environment
-	T	the type of the RHS
-	C	the constraints from that RHS
-
-The game is to figure out
-
-	Q	the set of type variables over which to quantify
-	Ct	the constraints we will *not* quantify over
-	Cq	the constraints we will quantify over
-
-So we're going to infer the type
-
-	forall Q. Cq => T
-
-and float the constraints Ct further outwards.
-
-Here are the things that *must* be true:
-
- (A)	Q intersect fv(G) = EMPTY			limits how big Q can be
- (B)	Q superset fv(Cq union T) \ oclose(fv(G),C)	limits how small Q can be
-
- (A) says we can't quantify over a variable that's free in the environment. 
- (B) says we must quantify over all the truly free variables in T, else 
-     we won't get a sufficiently general type.  
-
-We do not *need* to quantify over any variable that is fixed by the
-free vars of the environment G.
-
-	BETWEEN THESE TWO BOUNDS, ANY Q WILL DO!
-
-Example:	class H x y | x->y where ...
-
-	fv(G) = {a}	C = {H a b, H c d}
-			T = c -> b
-
-	(A)  Q intersect {a} is empty
-	(B)  Q superset {a,b,c,d} \ oclose({a}, C) = {a,b,c,d} \ {a,b} = {c,d}
-
-	So Q can be {c,d}, {b,c,d}
-
-In particular, it's perfectly OK to quantify over more type variables
-than strictly necessary; there is no need to quantify over 'b', since
-it is determined by 'a' which is free in the envt, but it's perfectly
-OK to do so.  However we must not quantify over 'a' itself.
-
-Other things being equal, however, we'd like to quantify over as few
-variables as possible: smaller types, fewer type applications, more
-constraints can get into Ct instead of Cq.  Here's a good way to
-choose Q:
-
-	Q = grow( fv(T), C ) \ oclose( fv(G), C )
-
-That is, quantify over all variable that that MIGHT be fixed by the
-call site (which influences T), but which aren't DEFINITELY fixed by
-G.  This choice definitely quantifies over enough type variables,
-albeit perhaps too many.
-
-Why grow( fv(T), C ) rather than fv(T)?  Consider
-
-	class H x y | x->y where ...
-
-	T = c->c
-	C = (H c d)
-
-  If we used fv(T) = {c} we'd get the type
-
-	forall c. H c d => c -> b
-
-  And then if the fn was called at several different c's, each of
-  which fixed d differently, we'd get a unification error, because
-  d isn't quantified.  Solution: quantify d.  So we must quantify
-  everything that might be influenced by c.
-
-Why not oclose( fv(T), C )?  Because we might not be able to see
-all the functional dependencies yet:
+*********************************************************************************
+*                                                                               * 
+*                           External interface                                  *
+*                                                                               *
+*********************************************************************************
 
-	class H x y | x->y where ...
-	instance H x y => Eq (T x y) where ...
-
-	T = c->c
-	C = (Eq (T c d))
-
-Now oclose(fv(T),C) = {c}, because the functional dependency isn't
-apparent yet, and that's wrong.  We must really quantify over d too.
-
-There really isn't any point in quantifying over any more than
-grow( fv(T), C ), because the call sites can't possibly influence
-any other type variables.
-
-
-
--------------------------------------
-	Note [Ambiguity]
--------------------------------------
-
-It's very hard to be certain when a type is ambiguous.  Consider
-
-	class K x
-	class H x y | x -> y
-	instance H x y => K (x,y)
-
-Is this type ambiguous?
-	forall a b. (K (a,b), Eq b) => a -> a
-
-Looks like it!  But if we simplify (K (a,b)) we get (H a b) and
-now we see that a fixes b.  So we can't tell about ambiguity for sure
-without doing a full simplification.  And even that isn't possible if
-the context has some free vars that may get unified.  Urgle!
-
-Here's another example: is this ambiguous?
-	forall a b. Eq (T b) => a -> a
-Not if there's an insance decl (with no context)
-	instance Eq (T b) where ...
-
-You may say of this example that we should use the instance decl right
-away, but you can't always do that:
-
-	class J a b where ...
-	instance J Int b where ...
-
-	f :: forall a b. J a b => a -> a
-
-(Notice: no functional dependency in J's class decl.)
-Here f's type is perfectly fine, provided f is only called at Int.
-It's premature to complain when meeting f's signature, or even
-when inferring a type for f.
-
-
-
-However, we don't *need* to report ambiguity right away.  It'll always
-show up at the call site.... and eventually at main, which needs special
-treatment.  Nevertheless, reporting ambiguity promptly is an excellent thing.
-
-So here's the plan.  We WARN about probable ambiguity if
-
-	fv(Cq) is not a subset of  oclose(fv(T) union fv(G), C)
-
-(all tested before quantification).
-That is, all the type variables in Cq must be fixed by the the variables
-in the environment, or by the variables in the type.
-
-Notice that we union before calling oclose.  Here's an example:
-
-	class J a b c | a b -> c
-	fv(G) = {a}
-
-Is this ambiguous?
-	forall b c. (J a b c) => b -> b
-
-Only if we union {a} from G with {b} from T before using oclose,
-do we see that c is fixed.
-
-It's a bit vague exactly which C we should use for this oclose call.  If we
-don't fix enough variables we might complain when we shouldn't (see
-the above nasty example).  Nothing will be perfect.  That's why we can
-only issue a warning.
-
-
-Can we ever be *certain* about ambiguity?  Yes: if there's a constraint
-
-	c in C such that fv(c) intersect (fv(G) union fv(T)) = EMPTY
-
-then c is a "bubble"; there's no way it can ever improve, and it's
-certainly ambiguous.  UNLESS it is a constant (sigh).  And what about
-the nasty example?
-
-	class K x
-	class H x y | x -> y
-	instance H x y => K (x,y)
-
-Is this type ambiguous?
-	forall a b. (K (a,b), Eq b) => a -> a
-
-Urk.  The (Eq b) looks "definitely ambiguous" but it isn't.  What we are after
-is a "bubble" that's a set of constraints
-
-	Cq = Ca union Cq'  st  fv(Ca) intersect (fv(Cq') union fv(T) union fv(G)) = EMPTY
-
-Hence another idea.  To decide Q start with fv(T) and grow it
-by transitive closure in Cq (no functional dependencies involved).
-Now partition Cq using Q, leaving the definitely-ambiguous and probably-ok.
-The definitely-ambiguous can then float out, and get smashed at top level
-(which squashes out the constants, like Eq (T a) above)
+\begin{code}
+simplifyTop :: WantedConstraints -> TcM (Bag EvBind)
+-- Simplify top-level constraints
+-- Usually these will be implications, when there is
+--   nothing to quanitfy we don't wrap in a degenerate implication,
+--   so we do that here instead
+simplifyTop wanteds 
+  = simplifyCheck SimplCheck wanteds
+
+------------------
+simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)
+simplifyInteractive wanteds 
+  = simplifyCheck SimplInteractive wanteds
+
+------------------
+simplifyDefault :: ThetaType	-- Wanted; has no type variables in it
+                -> TcM ()	-- Succeeds iff the constraint is soluble
+simplifyDefault theta
+  = do { loc <- getCtLoc DefaultOrigin
+       ; wanted <- newWantedEvVars theta
+       ; let wanted_bag = listToBag [WcEvVar (WantedEvVar w loc) | w <- wanted]
+       ; _ignored_ev_binds <- simplifyCheck SimplCheck wanted_bag
+       ; return () }
+\end{code}
 
+simplifyBracket is used when simplifying the constraints arising from
+a Template Haskell bracket [| ... |].  We want to check that there aren't
+any constraints that can't be satisfied (e.g. Show Foo, where Foo has no
+Show instance), but we aren't otherwise interested in the results.
+Nor do we care about ambiguous dictionaries etc.  We will type check
+this bracket again at its usage site.
 
-	--------------------------------------
-		Notes on principal types
-	--------------------------------------
+\begin{code}
+simplifyBracket :: WantedConstraints -> TcM ()
+simplifyBracket wanteds
+  = do	{ zonked_wanteds <- mapBagM zonkWanted wanteds 
+        ; _ <- simplifyAsMuchAsPossible SimplInfer zonked_wanteds
+	; return () }
+\end{code}
 
-    class C a where
-      op :: a -> a
 
-    f x = let g y = op (y::Int) in True
+*********************************************************************************
+*                                                                                 * 
+*                            Deriving
+*                                                                                 *
+***********************************************************************************
 
-Here the principal type of f is (forall a. a->a)
-but we'll produce the non-principal type
-    f :: forall a. C Int => a -> a
+\begin{code}
+simplifyDeriv :: CtOrigin
+		-> [TyVar]	
+		-> ThetaType		-- Wanted
+	        -> TcM ThetaType	-- Needed
+-- Given  instance (wanted) => C inst_ty 
+-- Simplify 'wanted' as much as possibles
+simplifyDeriv orig tvs theta 
+  = do { tvs_skols <- tcInstSkolTyVars InstSkol tvs -- Skolemize 
+       	 	   -- One reason is that the constraint solving machinery
+		   -- expects *TcTyVars* not TyVars.  Another is that
+		   -- when looking up instances we don't want overlap
+		   -- of type variables
+
+       ; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols
+             
+       ; loc    <- getCtLoc orig
+       ; wanted <- newWantedEvVars (substTheta skol_subst theta)
+       ; let wanted_bag = listToBag [WcEvVar (WantedEvVar w loc) | w <- wanted]
+
+       ; traceTc "simlifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted)
+       ; (unsolved, _binds) <- simplifyAsMuchAsPossible SimplInfer wanted_bag
+
+       ; let (good, bad) = partition validDerivPred $
+                           foldrBag ((:) . wantedEvVarPred) [] unsolved
+		-- See Note [Exotic derived instance contexts]
+             subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs 
+
+       ; reportUnsolvedDeriv bad loc
+       ; return $ substTheta subst_skol good }
+\end{code}
 
+Note [Exotic derived instance contexts]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In a 'derived' instance declaration, we *infer* the context.  It's a
+bit unclear what rules we should apply for this; the Haskell report is
+silent.  Obviously, constraints like (Eq a) are fine, but what about
+	data T f a = MkT (f a) deriving( Eq )
+where we'd get an Eq (f a) constraint.  That's probably fine too.
 
-	--------------------------------------
-	The need for forall's in constraints
-	--------------------------------------
+One could go further: consider
+	data T a b c = MkT (Foo a b c) deriving( Eq )
+	instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
 
-[Exchange on Haskell Cafe 5/6 Dec 2000]
+Notice that this instance (just) satisfies the Paterson termination 
+conditions.  Then we *could* derive an instance decl like this:
 
-  class C t where op :: t -> Bool
-  instance C [t] where op x = True
+	instance (C Int a, Eq b, Eq c) => Eq (T a b c) 
+even though there is no instance for (C Int a), because there just
+*might* be an instance for, say, (C Int Bool) at a site where we
+need the equality instance for T's.  
 
-  p y = (let f :: c -> Bool; f x = op (y >> return x) in f, y ++ [])
-  q y = (y ++ [], let f :: c -> Bool; f x = op (y >> return x) in f)
+However, this seems pretty exotic, and it's quite tricky to allow
+this, and yet give sensible error messages in the (much more common)
+case where we really want that instance decl for C.
 
-The definitions of p and q differ only in the order of the components in
-the pair on their right-hand sides.  And yet:
+So for now we simply require that the derived instance context
+should have only type-variable constraints.
 
-  ghc and "Typing Haskell in Haskell" reject p, but accept q;
-  Hugs rejects q, but accepts p;
-  hbc rejects both p and q;
-  nhc98 ... (Malcolm, can you fill in the blank for us!).
+Here is another example:
+	data Fix f = In (f (Fix f)) deriving( Eq )
+Here, if we are prepared to allow -XUndecidableInstances we
+could derive the instance
+	instance Eq (f (Fix f)) => Eq (Fix f)
+but this is so delicate that I don't think it should happen inside
+'deriving'. If you want this, write it yourself!
+
+NB: if you want to lift this condition, make sure you still meet the
+termination conditions!  If not, the deriving mechanism generates
+larger and larger constraints.  Example:
+  data Succ a = S a
+  data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
+
+Note the lack of a Show instance for Succ.  First we'll generate
+  instance (Show (Succ a), Show a) => Show (Seq a)
+and then
+  instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
+and so on.  Instead we want to complain of no instance for (Show (Succ a)).
+
+The bottom line
+~~~~~~~~~~~~~~~
+Allow constraints which consist only of type variables, with no repeats.
+
+*********************************************************************************
+*                                                                                 * 
+*                            Inference
+*                                                                                 *
+***********************************************************************************
 
-The type signature for f forces context reduction to take place, and
-the results of this depend on whether or not the type of y is known,
-which in turn depends on which component of the pair the type checker
-analyzes first.  
+\begin{code}
+simplifyInfer :: Bool		    -- Apply monomorphism restriction
+              -> TcTyVarSet         -- These type variables are free in the
+                                    -- types to be generalised
+              -> WantedConstraints
+              -> TcM ([TcTyVar],    -- Quantify over these type variables
+                      [EvVar],      -- ... and these constraints
+                      TcEvBinds)    -- ... binding these evidence variables
+simplifyInfer apply_mr tau_tvs wanted
+  | isEmptyBag wanted	  -- Trivial case is quite common
+  = do { zonked_tau_tvs <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
+       ; gbl_tvs        <- tcGetGlobalTyVars	     -- Already zonked
+       ; qtvs <- zonkQuantifiedTyVars (varSetElems (zonked_tau_tvs `minusVarSet` gbl_tvs))
+       ; return (qtvs, [], emptyTcEvBinds) }
 
-Solution: if y::m a, float out the constraints
-	Monad m, forall c. C (m c)
-When m is later unified with [], we can solve both constraints.
+  | otherwise
+  = do { zonked_wanted <- mapBagM zonkWanted wanted 
+       ; traceTc "simplifyInfer {"  $ vcat
+             [ ptext (sLit "apply_mr =") <+> ppr apply_mr
+             , ptext (sLit "wanted =") <+> ppr zonked_wanted
+             , ptext (sLit "tau_tvs =") <+> ppr tau_tvs
+             ]
+
+       ; (simple_wanted, tc_binds) 
+              <- simplifyAsMuchAsPossible SimplInfer zonked_wanted
+
+       ; gbl_tvs <- tcGetGlobalTyVars
+       ; zonked_tau_tvs <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
+       ; zonked_simples <- mapBagM zonkWantedEvVar simple_wanted
+       ; let qtvs = findQuantifiedTyVars apply_mr zonked_simples zonked_tau_tvs gbl_tvs
+             (bound, free) | apply_mr  = (emptyBag, zonked_simples)
+                           | otherwise = partitionBag (quantifyMe qtvs) zonked_simples
+
+       ; traceTc "end simplifyInfer }" $
+              vcat [ ptext (sLit "apply_mr =") <+> ppr apply_mr
+                   , text "wanted = " <+> ppr zonked_wanted
+                   , text "qtvs =   " <+> ppr qtvs
+                   , text "free =   " <+> ppr free
+                   , text "bound =  " <+> ppr bound ]
+
+       -- Turn the quantified meta-type variables into real type variables 
+       ; emitConstraints (mapBag WcEvVar free)
+       ; qtvs_to_return <- zonkQuantifiedTyVars (varSetElems qtvs) 
+       ; let bound_evvars = bagToList $ mapBag wantedEvVarToVar bound
+       ; return (qtvs_to_return, bound_evvars, EvBinds tc_binds) }
+
+------------------------
+simplifyAsMuchAsPossible :: SimplContext -> WantedConstraints
+                         -> TcM (Bag WantedEvVar, Bag EvBind) 
+-- We use this function when inferring the type of a function
+-- The wanted constraints are already zonked
+simplifyAsMuchAsPossible ctxt wanteds
+  = do { let untch = emptyVarSet
+	     	 -- We allow ourselves to unify environment 
+		 -- variables; hence *no untouchables*
+
+       ; ((unsolved_flats, unsolved_implics), ev_binds) 
+           <- runTcS ctxt untch $
+              simplifyApproxLoop 0 wanteds
+
+	      -- Report any errors
+       ; mapBagM_ reportUnsolvedImplication unsolved_implics
+
+       ; let final_wanted_evvars = mapBag deCanonicaliseWanted unsolved_flats
+       ; return (final_wanted_evvars, ev_binds) }
 
+  where 
+    simplifyApproxLoop :: Int -> WantedConstraints
+                       -> TcS (CanonicalCts, Bag Implication)
+    simplifyApproxLoop n wanteds
+     | n > 10 
+     = pprPanic "simplifyApproxLoop loops!" (ppr n <+> text "iterations") 
+     | otherwise 
+     = do { traceTcS "simplifyApproxLoop" (vcat 
+               [ ptext (sLit "Wanted = ") <+> ppr wanteds ])
+          ; (unsolved_flats, unsolved_implics) <- solveWanteds emptyInert wanteds
+
+	  ; let (extra_flats, thiner_unsolved_implics) 
+                    = approximateImplications unsolved_implics
+                unsolved 
+                    = mkWantedConstraints unsolved_flats thiner_unsolved_implics
+
+          ;-- If no new work was produced then we are done with simplifyApproxLoop
+            if isEmptyBag extra_flats
+            then do { traceTcS "simplifyApproxLoopRes" (vcat 
+              		      [ ptext (sLit "Wanted = ") <+> ppr wanteds
+                              , ptext (sLit "Result = ") <+> ppr unsolved_flats ])
+                    ; return (unsolved_flats, unsolved_implics) }
+
+            else -- Produced new flat work wanteds, go round the loop
+                simplifyApproxLoop (n+1) (extra_flats `unionBags` unsolved)
+          }     
+
+approximateImplications :: Bag Implication -> (WantedConstraints, Bag Implication) 
+-- (wc1, impls2) <- approximateImplications impls 
+-- splits 'impls' into two parts
+--    wc1:    a bag of constraints that do not mention any skolems 
+--    impls2: a bag of *thiner* implication constraints
+approximateImplications impls 
+  = splitBag (do_implic emptyVarSet) impls
+  where 
+    ------------------
+    do_wanted :: TcTyVarSet -> WantedConstraint
+              -> (WantedConstraints, WantedConstraints) 
+    do_wanted skols (WcImplic impl) 
+        = let (fl_w, mb_impl) = do_implic skols impl 
+          in (fl_w, mapBag WcImplic mb_impl)
+    do_wanted skols wc@(WcEvVar wev) 
+      | tyVarsOfWantedEvVar wev `disjointVarSet` skols = (unitBag wc, emptyBag) 
+      | otherwise                                      = (emptyBag, unitBag wc) 
+     
+    ------------------
+    do_implic :: TcTyVarSet -> Implication
+              -> (WantedConstraints, Bag Implication)
+    do_implic skols impl@(Implic { ic_skols = skols', ic_wanted = wanted })
+     = (floatable_wanted, if isEmptyBag rest_wanted then emptyBag
+                          else unitBag impl{ ic_wanted = rest_wanted } ) 
+     where
+        (floatable_wanted, rest_wanted) 
+            = splitBag (do_wanted (skols `unionVarSet` skols')) wanted
+
+    ------------------
+    splitBag :: (a -> (WantedConstraints, Bag a))
+             -> Bag a -> (WantedConstraints, Bag a)
+    splitBag f bag = foldrBag do_one (emptyBag,emptyBag) bag
+       where
+         do_one x (b1,b2) 
+           = (wcs `unionBags` b1, imps `unionBags` b2)
+	   where
+              (wcs, imps) = f x 
+\end{code}
 
-	--------------------------------------
-		Notes on implicit parameters
-	--------------------------------------
+\begin{code}
+findQuantifiedTyVars :: Bool		-- Apply the MR
+                     -> Bag WantedEvVar	-- Simplified constraints from RHS
+                     -> TyVarSet	-- Free in tau-type of definition
+                     -> TyVarSet	-- Free in the envt
+		     -> TyVarSet	-- Quantify over these
+
+findQuantifiedTyVars apply_mr wanteds tau_tvs gbl_tvs
+  | isEmptyBag wanteds = init_tvs
+  | apply_mr           = init_tvs `minusVarSet` constrained_tvs
+  | otherwise          = fixVarSet mk_next init_tvs
+  where
+    init_tvs    = tau_tvs `minusVarSet` gbl_tvs
+    mk_next tvs = foldrBag grow_one tvs wanteds
+
+    grow_one wev tvs = tvs `unionVarSet` (extra_tvs `minusVarSet` gbl_tvs)
+       where
+         extra_tvs = growPredTyVars (wantedEvVarPred wev) tvs
+
+    constrained_tvs = tyVarsOfWantedEvVars wanteds
+
+--------------------
+quantifyMe :: TyVarSet      -- Quantifying over these
+	   -> WantedEvVar
+	   -> Bool	    -- True <=> quantify over this wanted
+quantifyMe qtvs wev
+  | isIPPred pred = True  -- Note [Inheriting implicit parameters]
+  | otherwise	  = tyVarsOfPred pred `intersectsVarSet` qtvs
+  where
+    pred = wantedEvVarPred wev
+\end{code}
 
 Note [Inheriting implicit parameters]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -403,2571 +365,535 @@ BOTTOM LINE: when *inferring types* you *must* quantify
 over implicit parameters. See the predicate isFreeWhenInferring.
 
 
-Note [Implicit parameters and ambiguity] 
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Only a *class* predicate can give rise to ambiguity
-An *implicit parameter* cannot.  For example:
-	foo :: (?x :: [a]) => Int
-	foo = length ?x
-is fine.  The call site will suppply a particular 'x'
-
-Furthermore, the type variables fixed by an implicit parameter
-propagate to the others.  E.g.
-	foo :: (Show a, ?x::[a]) => Int
-	foo = show (?x++?x)
-The type of foo looks ambiguous.  But it isn't, because at a call site
-we might have
-	let ?x = 5::Int in foo
-and all is well.  In effect, implicit parameters are, well, parameters,
-so we can take their type variables into account as part of the
-"tau-tvs" stuff.  This is done in the function 'FunDeps.grow'.
-
-
-Question 2: type signatures
-~~~~~~~~~~~~~~~~~~~~~~~~~~~
-BUT WATCH OUT: When you supply a type signature, we can't force you
-to quantify over implicit parameters.  For example:
-
-	(?x + 1) :: Int
-
-This is perfectly reasonable.  We do not want to insist on
-
-	(?x + 1) :: (?x::Int => Int)
-
-That would be silly.  Here, the definition site *is* the occurrence site,
-so the above strictures don't apply.  Hence the difference between
-tcSimplifyCheck (which *does* allow implicit paramters to be inherited)
-and tcSimplifyCheckBind (which does not).
-
-What about when you supply a type signature for a binding?
-Is it legal to give the following explicit, user type 
-signature to f, thus:
-
-	f :: Int -> Int
-	f x = (x::Int) + ?y
-
-At first sight this seems reasonable, but it has the nasty property
-that adding a type signature changes the dynamic semantics.
-Consider this:
-
-	(let f x = (x::Int) + ?y
- 	 in (f 3, f 3 with ?y=5))  with ?y = 6
-
-		returns (3+6, 3+5)
-vs
-	(let f :: Int -> Int
-	     f x = x + ?y
-	 in (f 3, f 3 with ?y=5))  with ?y = 6
-
-		returns (3+6, 3+6)
-
-Indeed, simply inlining f (at the Haskell source level) would change the
-dynamic semantics.
-
-Nevertheless, as Launchbury says (email Oct 01) we can't really give the
-semantics for a Haskell program without knowing its typing, so if you 
-change the typing you may change the semantics.
-
-To make things consistent in all cases where we are *checking* against
-a supplied signature (as opposed to inferring a type), we adopt the
-rule: 
-
-	a signature does not need to quantify over implicit params.
-
-[This represents a (rather marginal) change of policy since GHC 5.02,
-which *required* an explicit signature to quantify over all implicit
-params for the reasons mentioned above.]
-
-But that raises a new question.  Consider 
-
-	Given (signature)	?x::Int
-	Wanted (inferred)	?x::Int, ?y::Bool
-
-Clearly we want to discharge the ?x and float the ?y out.  But
-what is the criterion that distinguishes them?  Clearly it isn't
-what free type variables they have.  The Right Thing seems to be
-to float a constraint that
-	neither mentions any of the quantified type variables
-	nor any of the quantified implicit parameters
-
-See the predicate isFreeWhenChecking.
-
-
-Question 3: monomorphism
-~~~~~~~~~~~~~~~~~~~~~~~~
-There's a nasty corner case when the monomorphism restriction bites:
-
-	z = (x::Int) + ?y
-
-The argument above suggests that we *must* generalise
-over the ?y parameter, to get
-	z :: (?y::Int) => Int,
-but the monomorphism restriction says that we *must not*, giving
-	z :: Int.
-Why does the momomorphism restriction say this?  Because if you have
-
-	let z = x + ?y in z+z
-
-you might not expect the addition to be done twice --- but it will if
-we follow the argument of Question 2 and generalise over ?y.
-
-
-Question 4: top level
-~~~~~~~~~~~~~~~~~~~~~
-At the top level, monomorhism makes no sense at all.
-
-    module Main where
-	main = let ?x = 5 in print foo
-
-	foo = woggle 3
-
-	woggle :: (?x :: Int) => Int -> Int
-	woggle y = ?x + y
-
-We definitely don't want (foo :: Int) with a top-level implicit parameter
-(?x::Int) becuase there is no way to bind it.  
-
-
-Possible choices
-~~~~~~~~~~~~~~~~
-(A) Always generalise over implicit parameters
-    Bindings that fall under the monomorphism restriction can't
-	be generalised
-
-    Consequences:
-	* Inlining remains valid
-	* No unexpected loss of sharing
-	* But simple bindings like
-		z = ?y + 1
-	  will be rejected, unless you add an explicit type signature
-	  (to avoid the monomorphism restriction)
-		z :: (?y::Int) => Int
-		z = ?y + 1
-	  This seems unacceptable
-
-(B) Monomorphism restriction "wins"
-    Bindings that fall under the monomorphism restriction can't
-	be generalised
-    Always generalise over implicit parameters *except* for bindings
-	that fall under the monomorphism restriction
-
-    Consequences
-	* Inlining isn't valid in general
-	* No unexpected loss of sharing
-	* Simple bindings like
-		z = ?y + 1
-	  accepted (get value of ?y from binding site)
-
-(C) Always generalise over implicit parameters
-    Bindings that fall under the monomorphism restriction can't
-	be generalised, EXCEPT for implicit parameters
-    Consequences
-	* Inlining remains valid
-	* Unexpected loss of sharing (from the extra generalisation)
-	* Simple bindings like
-		z = ?y + 1
-	  accepted (get value of ?y from occurrence sites)
-
-
-Discussion
-~~~~~~~~~~
-None of these choices seems very satisfactory.  But at least we should
-decide which we want to do.
-
-It's really not clear what is the Right Thing To Do.  If you see
-
-	z = (x::Int) + ?y
-
-would you expect the value of ?y to be got from the *occurrence sites*
-of 'z', or from the valuue of ?y at the *definition* of 'z'?  In the
-case of function definitions, the answer is clearly the former, but
-less so in the case of non-fucntion definitions.   On the other hand,
-if we say that we get the value of ?y from the definition site of 'z',
-then inlining 'z' might change the semantics of the program.
-
-Choice (C) really says "the monomorphism restriction doesn't apply
-to implicit parameters".  Which is fine, but remember that every
-innocent binding 'x = ...' that mentions an implicit parameter in
-the RHS becomes a *function* of that parameter, called at each
-use of 'x'.  Now, the chances are that there are no intervening 'with'
-clauses that bind ?y, so a decent compiler should common up all
-those function calls.  So I think I strongly favour (C).  Indeed,
-one could make a similar argument for abolishing the monomorphism
-restriction altogether.
-
-BOTTOM LINE: we choose (B) at present.  See tcSimplifyRestricted
-
-
-
-%************************************************************************
-%*									*
-\subsection{tcSimplifyInfer}
-%*									*
-%************************************************************************
-
-tcSimplify is called when we *inferring* a type.  Here's the overall game plan:
-
-    1. Compute Q = grow( fvs(T), C )
-
-    2. Partition C based on Q into Ct and Cq.  Notice that ambiguous
-       predicates will end up in Ct; we deal with them at the top level
-
-    3. Try improvement, using functional dependencies
-
-    4. If Step 3 did any unification, repeat from step 1
-       (Unification can change the result of 'grow'.)
-
-Note: we don't reduce dictionaries in step 2.  For example, if we have
-Eq (a,b), we don't simplify to (Eq a, Eq b).  So Q won't be different
-after step 2.  However note that we may therefore quantify over more
-type variables than we absolutely have to.
-
-For the guts, we need a loop, that alternates context reduction and
-improvement with unification.  E.g. Suppose we have
-
-	class C x y | x->y where ...
-
-and tcSimplify is called with:
-	(C Int a, C Int b)
-Then improvement unifies a with b, giving
-	(C Int a, C Int a)
-
-If we need to unify anything, we rattle round the whole thing all over
-again.
-
-
-\begin{code}
-tcSimplifyInfer
-	:: SDoc
-	-> TcTyVarSet		-- fv(T); type vars
-	-> [Inst]		-- Wanted
-	-> TcM ([TcTyVar],	-- Tyvars to quantify (zonked and quantified)
-		[Inst],		-- Dict Ids that must be bound here (zonked)
-		TcDictBinds)	-- Bindings
-	-- Any free (escaping) Insts are tossed into the environment
-\end{code}
-
-
-\begin{code}
-tcSimplifyInfer doc tau_tvs wanted
-  = do	{ tau_tvs1 <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
-	; wanted'  <- mapM zonkInst wanted	-- Zonk before deciding quantified tyvars
-	; gbl_tvs  <- tcGetGlobalTyVars
-	; let preds1   = fdPredsOfInsts wanted'
-	      gbl_tvs1 = oclose preds1 gbl_tvs
-	      qtvs     = growInstsTyVars wanted' tau_tvs1 `minusVarSet` gbl_tvs1
-			-- See Note [Choosing which variables to quantify]
-
-		-- To maximise sharing, remove from consideration any 
-		-- constraints that don't mention qtvs at all
-	; let (free, bound) = partition (isFreeWhenInferring qtvs) wanted'
-	; extendLIEs free
-
-		-- To make types simple, reduce as much as possible
-	; traceTc (text "infer" <+> (ppr preds1 $$ ppr (growInstsTyVars wanted' tau_tvs1) $$ ppr gbl_tvs $$ 
-		   ppr gbl_tvs1 $$ ppr free $$ ppr bound))
-	; (irreds1, binds1) <- tryHardCheckLoop doc bound
-
-		-- Note [Inference and implication constraints]
-	; let want_dict d = tyVarsOfInst d `intersectsVarSet` qtvs
-	; (irreds2, binds2) <- approximateImplications doc want_dict irreds1
-
-		-- Now work out all over again which type variables to quantify,
-		-- exactly in the same way as before, but starting from irreds2.  Why?
-		-- a) By now improvment may have taken place, and we must *not*
-		--    quantify over any variable free in the environment
-		--    tc137 (function h inside g) is an example
-		--
-		-- b) Do not quantify over constraints that *now* do not
-		--    mention quantified type variables, because they are
-		--    simply ambiguous (or might be bound further out).  Example:
-		--    	f :: Eq b => a -> (a, b)
-		--    	g x = fst (f x)
-		--    From the RHS of g we get the MethodInst f77 :: alpha -> (alpha, beta)
-		--    We decide to quantify over 'alpha' alone, but free1 does not include f77
-		--    because f77 mentions 'alpha'.  Then reducing leaves only the (ambiguous)
-		--    constraint (Eq beta), which we dump back into the free set
-		--    See test tcfail181
-		--
-		-- c) irreds may contain type variables not previously mentioned,
-		--    e.g.  instance D a x => Foo [a] 
-		--	    wanteds = Foo [a]
-		--       Then after simplifying we'll get (D a x), and x is fresh
-		-- 	 We must quantify over x else it'll be totally unbound
-	; tau_tvs2 <- zonkTcTyVarsAndFV (varSetElems tau_tvs1)
-	; gbl_tvs2 <- zonkTcTyVarsAndFV (varSetElems gbl_tvs1)
-		-- Note that we start from gbl_tvs1
-		-- We use tcGetGlobalTyVars, then oclose wrt preds2, because
-		-- we've already put some of the original preds1 into frees
-		-- E.g. 	wanteds = C a b	  (where a->b)
-		--		gbl_tvs = {a}
-		--		tau_tvs = {b}
-		-- Then b is fixed by gbl_tvs, so (C a b) will be in free, and
-		-- irreds2 will be empty.  But we don't want to generalise over b!
-	; let preds2 = fdPredsOfInsts irreds2	-- irreds2 is zonked
-	      qtvs   = growInstsTyVars irreds2 tau_tvs2 `minusVarSet` oclose preds2 gbl_tvs2
-		---------------------------------------------------
-		-- BUG WARNING: there's a nasty bug lurking here
-		-- fdPredsOfInsts may return preds that mention variables quantified in
-		-- one of the implication constraints in irreds2; and that is clearly wrong:
-		-- we might quantify over too many variables through accidental capture
-		---------------------------------------------------
-	; let (free, irreds3) = partition (isFreeWhenInferring qtvs) irreds2
-	; extendLIEs free
-
-		-- Turn the quantified meta-type variables into real type variables
-	; qtvs2 <- zonkQuantifiedTyVars (varSetElems qtvs)
-
-		-- We can't abstract over any remaining unsolved 
-		-- implications so instead just float them outwards. Ugh.
-	; let (q_dicts0, implics) = partition isAbstractableInst irreds3
-	; loc <- getInstLoc (ImplicOrigin doc)
-	; implic_bind <- bindIrreds loc qtvs2 q_dicts0 implics
-
-		-- Prepare equality instances for quantification
-	; let (q_eqs0,q_dicts) = partition isEqInst q_dicts0
-	; q_eqs <- mapM finalizeEqInst q_eqs0
-
-	; return (qtvs2, q_eqs ++ q_dicts, binds1 `unionBags` binds2 `unionBags` implic_bind) }
-	-- NB: when we are done, we might have some bindings, but
-	-- the final qtvs might be empty.  See Note [NO TYVARS] below.
-
-approximateImplications :: SDoc -> (Inst -> Bool) -> [Inst] -> TcM ([Inst], TcDictBinds)
--- Note [Inference and implication constraints]
--- Given a bunch of Dict and ImplicInsts, try to approximate the implications by
---	- fetching any dicts inside them that are free
---	- using those dicts as cruder constraints, to solve the implications
---	- returning the extra ones too
-
-approximateImplications doc want_dict irreds
-  | null extra_dicts 
-  = return (irreds, emptyBag)
-  | otherwise
-  = do	{ extra_dicts' <- mapM cloneDict extra_dicts
-	; tryHardCheckLoop doc (extra_dicts' ++ irreds) }
-		-- By adding extra_dicts', we make them 
-		-- available to solve the implication constraints
-  where 
-    extra_dicts = get_dicts (filter isImplicInst irreds)
-
-    get_dicts :: [Inst] -> [Inst]	-- Returns only Dicts
-	-- Find the wanted constraints in implication constraints that satisfy
-	-- want_dict, and are not bound by forall's in the constraint itself
-    get_dicts ds = concatMap get_dict ds
-
-    get_dict d@(Dict {}) | want_dict d = [d]
-		         | otherwise   = []
-    get_dict (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds})
-	= [ d | let tv_set = mkVarSet tvs
-	      , d <- get_dicts wanteds 
-	      , not (tyVarsOfInst d `intersectsVarSet` tv_set)]
-    get_dict i@(EqInst {}) | want_dict i = [i]
-			   | otherwise   = [] 
-    get_dict other = pprPanic "approximateImplications" (ppr other)
-\end{code}
-
-Note [Inference and implication constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
-Suppose we have a wanted implication constraint (perhaps arising from
-a nested pattern match) like
-	C a => D [a]
-and we are now trying to quantify over 'a' when inferring the type for
-a function.  In principle it's possible that there might be an instance
-	instance (C a, E a) => D [a]
-so the context (E a) would suffice.  The Right Thing is to abstract over
-the implication constraint, but we don't do that (a) because it'll be
-surprising to programmers and (b) because we don't have the machinery to deal
-with 'given' implications.
-
-So our best approximation is to make (D [a]) part of the inferred
-context, so we can use that to discharge the implication. Hence
-the strange function get_dicts in approximateImplications.
-
-The common cases are more clear-cut, when we have things like
-	forall a. C a => C b
-Here, abstracting over (C b) is not an approximation at all -- but see
-Note [Freeness and implications].
- 
-See Trac #1430 and test tc228.
-
-
-\begin{code}
------------------------------------------------------------
--- tcSimplifyInferCheck is used when we know the constraints we are to simplify
--- against, but we don't know the type variables over which we are going to quantify.
--- This happens when we have a type signature for a mutually recursive group
-tcSimplifyInferCheck
-	 :: InstLoc
-	 -> TcTyVarSet		-- fv(T)
-	 -> [Inst]		-- Given
-	 -> [Inst]		-- Wanted
-	 -> TcM ([TyVar],	-- Fully zonked, and quantified
-		 TcDictBinds)	-- Bindings
-
-tcSimplifyInferCheck loc tau_tvs givens wanteds
-  = do	{ traceTc (text "tcSimplifyInferCheck <-" <+> ppr wanteds)
-	; (irreds, binds) <- gentleCheckLoop loc givens wanteds
-
-	-- Figure out which type variables to quantify over
-	-- You might think it should just be the signature tyvars,
-	-- but in bizarre cases you can get extra ones
-	-- 	f :: forall a. Num a => a -> a
-	--	f x = fst (g (x, head [])) + 1
-	--	g a b = (b,a)
-	-- Here we infer g :: forall a b. a -> b -> (b,a)
-	-- We don't want g to be monomorphic in b just because
-	-- f isn't quantified over b.
-	; let all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens)
-	; all_tvs <- zonkTcTyVarsAndFV all_tvs
-	; gbl_tvs <- tcGetGlobalTyVars
-	; let qtvs = varSetElems (all_tvs `minusVarSet` gbl_tvs)
-		-- We could close gbl_tvs, but its not necessary for
-		-- soundness, and it'll only affect which tyvars, not which
-		-- dictionaries, we quantify over
-
-	; qtvs' <- zonkQuantifiedTyVars qtvs
-
-		-- Now we are back to normal (c.f. tcSimplCheck)
-	; implic_bind <- bindIrreds loc qtvs' givens irreds
-
-	; traceTc (text "tcSimplifyInferCheck ->" <+> ppr (implic_bind))
-	; return (qtvs', binds `unionBags` implic_bind) }
-\end{code}
-
-Note [Squashing methods]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Be careful if you want to float methods more:
-	truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
-From an application (truncate f i) we get
-	t1 = truncate at f
-	t2 = t1 at i
-If we have also have a second occurrence of truncate, we get
-	t3 = truncate at f
-	t4 = t3 at i
-When simplifying with i,f free, we might still notice that
-t1=t3; but alas, the binding for t2 (which mentions t1)
-may continue to float out!
-
-
-Note [NO TYVARS]
-~~~~~~~~~~~~~~~~~
-	class Y a b | a -> b where
-	    y :: a -> X b
-	
-	instance Y [[a]] a where
-	    y ((x:_):_) = X x
-	
-	k :: X a -> X a -> X a
-
-	g :: Num a => [X a] -> [X a]
-	g xs = h xs
-	    where
-	    h ys = ys ++ map (k (y [[0]])) xs
-
-The excitement comes when simplifying the bindings for h.  Initially
-try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}.
-From this we get t1~t2, but also various bindings.  We can't forget
-the bindings (because of [LOOP]), but in fact t1 is what g is
-polymorphic in.  
-
-The net effect of [NO TYVARS] 
-
-\begin{code}
-isFreeWhenInferring :: TyVarSet -> Inst	-> Bool
-isFreeWhenInferring qtvs inst
-  =  isFreeWrtTyVars qtvs inst	-- Constrains no quantified vars
-  && isInheritableInst inst	-- and no implicit parameter involved
-				--   see Note [Inheriting implicit parameters]
-
-{-	No longer used (with implication constraints)
-isFreeWhenChecking :: TyVarSet	-- Quantified tyvars
-	 	   -> NameSet	-- Quantified implicit parameters
-		   -> Inst -> Bool
-isFreeWhenChecking qtvs ips inst
-  =  isFreeWrtTyVars qtvs inst
-  && isFreeWrtIPs    ips inst
--}
-
-isFreeWrtTyVars :: VarSet -> Inst -> Bool
-isFreeWrtTyVars qtvs inst = tyVarsOfInst inst `disjointVarSet` qtvs
-isFreeWrtIPs :: NameSet -> Inst -> Bool
-isFreeWrtIPs     ips inst = not (any (`elemNameSet` ips) (ipNamesOfInst inst))
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection{tcSimplifyCheck}
-%*									*
-%************************************************************************
-
-@tcSimplifyCheck@ is used when we know exactly the set of variables
-we are going to quantify over.  For example, a class or instance declaration.
-
-\begin{code}
------------------------------------------------------------
--- tcSimplifyCheck is used when checking expression type signatures,
--- class decls, instance decls etc.
-tcSimplifyCheck	:: InstLoc
-	 	-> [TcTyVar]		-- Quantify over these
-	 	-> [Inst]		-- Given
-	 	-> [Inst]		-- Wanted
-	 	-> TcM TcDictBinds	-- Bindings
-tcSimplifyCheck loc qtvs givens wanteds 
-  = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs )
-    do	{ traceTc (text "tcSimplifyCheck")
-      	; (irreds, binds) <- gentleCheckLoop loc givens wanteds
-	; implic_bind <- bindIrreds loc qtvs givens irreds
-	; return (binds `unionBags` implic_bind) }
-
------------------------------------------------------------
--- tcSimplifyCheckPat is used for existential pattern match
-tcSimplifyCheckPat :: InstLoc
-	 	   -> [TcTyVar]		-- Quantify over these
-	 	   -> [Inst]		-- Given
-	 	   -> [Inst]		-- Wanted
-	 	   -> TcM TcDictBinds	-- Bindings
-tcSimplifyCheckPat loc qtvs givens wanteds
-  = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs )
-    do	{ traceTc (text "tcSimplifyCheckPat")
-      	; (irreds, binds) <- gentleCheckLoop loc givens wanteds
-	; implic_bind <- bindIrredsR loc qtvs givens irreds
-	; return (binds `unionBags` implic_bind) }
-
------------------------------------------------------------
-bindIrreds :: InstLoc -> [TcTyVar]
-	   -> [Inst] -> [Inst]
-	   -> TcM TcDictBinds
-bindIrreds loc qtvs givens irreds 
-  = bindIrredsR loc qtvs givens irreds
-
-bindIrredsR :: InstLoc -> [TcTyVar] -> [Inst] -> [Inst] -> TcM TcDictBinds	
--- Make a binding that binds 'irreds', by generating an implication
--- constraint for them, *and* throwing the constraint into the LIE
-bindIrredsR loc qtvs givens irreds
-  | null irreds
-  = return emptyBag
-  | otherwise
-  = do	{ let givens' = filter isAbstractableInst givens
-		-- The givens can (redundantly) include methods
-		-- We want to retain both EqInsts and Dicts
-		-- There should be no implicadtion constraints
-		-- See Note [Pruning the givens in an implication constraint]
-
-	   -- If there are no 'givens', then it's safe to 
-	   -- partition the 'wanteds' by their qtvs, thereby trimming irreds
-	   -- See Note [Freeness and implications]
-	; irreds' <- if null givens'
-	     	     then do
-	     	    	{ let qtv_set = mkVarSet qtvs
-	     	    	      (frees, real_irreds) = partition (isFreeWrtTyVars qtv_set) irreds
-	     	    	; extendLIEs frees
-	     	    	; return real_irreds }
-	     	     else return irreds
-	
-	; (implics, bind) <- makeImplicationBind loc qtvs givens' irreds'
-			-- This call does the real work
-			-- If irreds' is empty, it does something sensible
-	; extendLIEs implics
-	; return bind } 
-
-
-makeImplicationBind :: InstLoc -> [TcTyVar]
-		    -> [Inst] -> [Inst]
-		    -> TcM ([Inst], TcDictBinds)
--- Make a binding that binds 'irreds', by generating an implication
--- constraint for them.
---
--- The binding looks like
---	(ir1, .., irn) = f qtvs givens
--- where f is (evidence for) the new implication constraint
---	f :: forall qtvs. givens => (ir1, .., irn)
--- qtvs includes coercion variables
---
--- This binding must line up the 'rhs' in reduceImplication
-makeImplicationBind loc all_tvs
-		    givens 	-- Guaranteed all Dicts or EqInsts
-		    irreds
- | null irreds			-- If there are no irreds, we are done
- = return ([], emptyBag)
- | otherwise			-- Otherwise we must generate a binding
- = do	{ uniq <- newUnique 
-	; span <- getSrcSpanM
-	; let (eq_givens, dict_givens) = partition isEqInst givens
-
-                -- extract equality binders
-              eq_cotvs = map eqInstType eq_givens
-
-                -- make the implication constraint instance
-	      name = mkInternalName uniq (mkVarOcc "ic") span
-	      implic_inst = ImplicInst { tci_name = name,
-					 tci_tyvars = all_tvs, 
-					 tci_given = eq_givens ++ dict_givens,
-                                                       -- same order as binders
-					 tci_wanted = irreds, 
-                                         tci_loc = loc }
-
-	        -- create binders for the irreducible dictionaries
-	      dict_irreds    = filter (not . isEqInst) irreds
-	      dict_irred_ids = map instToId dict_irreds
-	      lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids)
-
-                -- create the binding
-	      rhs  = L span (mkHsWrap co (HsVar (instToId implic_inst)))
-	      co   =     mkWpApps (map instToId dict_givens)
-		     <.> mkWpTyApps eq_cotvs
-		     <.> mkWpTyApps (mkTyVarTys all_tvs)
-	      bind | [dict_irred_id] <- dict_irred_ids  
-                   = mkVarBind dict_irred_id rhs
-		   | otherwise        
-                   = L span $ 
-                     PatBind { pat_lhs = lpat
-			     , pat_rhs = unguardedGRHSs rhs 
-			     , pat_rhs_ty = hsLPatType lpat
-			     , bind_fvs = placeHolderNames 
-                             }
-
-	; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
-	; return ([implic_inst], unitBag bind) 
-        }
-
------------------------------------------------------------
-tryHardCheckLoop :: SDoc
-	     -> [Inst]			-- Wanted
-	     -> TcM ([Inst], TcDictBinds)
-
-tryHardCheckLoop doc wanteds
-  = do { (irreds,binds) <- checkLoop (mkInferRedEnv doc try_me) wanteds
-       ; return (irreds,binds)
-       }
-  where
-    try_me _ = ReduceMe
-	-- Here's the try-hard bit
-
------------------------------------------------------------
-gentleCheckLoop :: InstLoc
-	       -> [Inst]		-- Given
-	       -> [Inst]		-- Wanted
-	       -> TcM ([Inst], TcDictBinds)
-
-gentleCheckLoop inst_loc givens wanteds
-  = do { (irreds,binds) <- checkLoop env wanteds
-       ; return (irreds,binds)
-       }
-  where
-    env = mkRedEnv (pprInstLoc inst_loc) try_me givens
-
-    try_me inst | isMethodOrLit inst = ReduceMe
-		| otherwise	     = Stop
-	-- When checking against a given signature 
-	-- we MUST be very gentle: Note [Check gently]
-
-gentleInferLoop :: SDoc -> [Inst]
-	        -> TcM ([Inst], TcDictBinds)
-gentleInferLoop doc wanteds
-  = do 	{ (irreds, binds) <- checkLoop env wanteds
-	; return (irreds, binds) }
-  where
-    env = mkInferRedEnv doc try_me
-    try_me inst | isMethodOrLit inst = ReduceMe
-		| otherwise	     = Stop
-\end{code}
-
-Note [Check gently]
-~~~~~~~~~~~~~~~~~~~~
-We have to very careful about not simplifying too vigorously
-Example:  
-  data T a where
-    MkT :: a -> T [a]
-
-  f :: Show b => T b -> b
-  f (MkT x) = show [x]
-
-Inside the pattern match, which binds (a:*, x:a), we know that
-	b ~ [a]
-Hence we have a dictionary for Show [a] available; and indeed we 
-need it.  We are going to build an implication contraint
-	forall a. (b~[a]) => Show [a]
-Later, we will solve this constraint using the knowledge (Show b)
-	
-But we MUST NOT reduce (Show [a]) to (Show a), else the whole
-thing becomes insoluble.  So we simplify gently (get rid of literals
-and methods only, plus common up equal things), deferring the real
-work until top level, when we solve the implication constraint
-with tryHardCheckLooop.
-
-
-\begin{code}
------------------------------------------------------------
-checkLoop :: RedEnv
-	  -> [Inst]			-- Wanted
-	  -> TcM ([Inst], TcDictBinds) 
--- Precondition: givens are completely rigid
--- Postcondition: returned Insts are zonked
-
-checkLoop env wanteds
-  = go env wanteds
-  where go env wanteds
-	  = do  {  -- We do need to zonk the givens; cf Note [Zonking RedEnv]
-                ; env'     <- zonkRedEnv env
-		; wanteds' <- zonkInsts  wanteds
-	
-		; (improved, tybinds, binds, irreds) 
-                    <- reduceContext env' wanteds'
-                ; execTcTyVarBinds tybinds
-
-		; if null irreds || not improved then
-	 	    return (irreds, binds)
-		  else do
-	
-		-- If improvement did some unification, we go round again.
-		-- We start again with irreds, not wanteds
-		-- Using an instance decl might have introduced a fresh type
-		-- variable which might have been unified, so we'd get an 
-                -- infinite loop if we started again with wanteds!  
-                -- See Note [LOOP]
-		{ (irreds1, binds1) <- go env' irreds
-		; return (irreds1, binds `unionBags` binds1) } }
-\end{code}
-
-Note [Zonking RedEnv]
-~~~~~~~~~~~~~~~~~~~~~
-It might appear as if the givens in RedEnv are always rigid, but that is not
-necessarily the case for programs involving higher-rank types that have class
-contexts constraining the higher-rank variables.  An example from tc237 in the
-testsuite is
-
-  class Modular s a | s -> a
-
-  wim ::  forall a w. Integral a 
-                        => a -> (forall s. Modular s a => M s w) -> w
-  wim i k = error "urk"
-
-  test5  ::  (Modular s a, Integral a) => M s a
-  test5  =   error "urk"
-
-  test4   =   wim 4 test4'
-
-Notice how the variable 'a' of (Modular s a) in the rank-2 type of wim is
-quantified further outside.  When type checking test4, we have to check
-whether the signature of test5 is an instance of 
-
-  (forall s. Modular s a => M s w)
-
-Consequently, we will get (Modular s t_a), where t_a is a TauTv into the
-givens. 
-
-Given the FD of Modular in this example, class improvement will instantiate
-t_a to 'a', where 'a' is the skolem from test5's signatures (due to the
-Modular s a predicate in that signature).  If we don't zonk (Modular s t_a) in
-the givens, we will get into a loop as improveOne uses the unification engine
-Unify.tcUnifyTys, which doesn't know about mutable type variables.
-
-
-Note [LOOP]
-~~~~~~~~~~~
-	class If b t e r | b t e -> r
-	instance If T t e t
-	instance If F t e e
-	class Lte a b c | a b -> c where lte :: a -> b -> c
-	instance Lte Z b T
-	instance (Lte a b l,If l b a c) => Max a b c
-
-Wanted:	Max Z (S x) y
-
-Then we'll reduce using the Max instance to:
-	(Lte Z (S x) l, If l (S x) Z y)
-and improve by binding l->T, after which we can do some reduction
-on both the Lte and If constraints.  What we *can't* do is start again
-with (Max Z (S x) y)!
-
-
-
-%************************************************************************
-%*									*
-		tcSimplifySuperClasses
-%*									*
-%************************************************************************
-
-Note [SUPERCLASS-LOOP 1]
-~~~~~~~~~~~~~~~~~~~~~~~~
-We have to be very, very careful when generating superclasses, lest we
-accidentally build a loop. Here's an example:
-
-  class S a
-
-  class S a => C a where { opc :: a -> a }
-  class S b => D b where { opd :: b -> b }
-  
-  instance C Int where
-     opc = opd
-  
-  instance D Int where
-     opd = opc
-
-From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int}
-Simplifying, we may well get:
-	$dfCInt = :C ds1 (opd dd)
-	dd  = $dfDInt
-	ds1 = $p1 dd
-Notice that we spot that we can extract ds1 from dd.  
-
-Alas!  Alack! We can do the same for (instance D Int):
-
-	$dfDInt = :D ds2 (opc dc)
-	dc  = $dfCInt
-	ds2 = $p1 dc
-
-And now we've defined the superclass in terms of itself.
-Two more nasty cases are in
-	tcrun021
-	tcrun033
-
-Solution: 
-  - Satisfy the superclass context *all by itself* 
-    (tcSimplifySuperClasses)
-  - And do so completely; i.e. no left-over constraints
-    to mix with the constraints arising from method declarations
-
-
-Note [Recursive instances and superclases]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this code, which arises in the context of "Scrap Your 
-Boilerplate with Class".  
-
-    class Sat a
-    class Data ctx a
-    instance  Sat (ctx Char)             => Data ctx Char
-    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]
-
-    class Data Maybe a => Foo a
-
-    instance Foo t => Sat (Maybe t)
-
-    instance Data Maybe a => Foo a
-    instance Foo a        => Foo [a]
-    instance                 Foo [Char]
-
-In the instance for Foo [a], when generating evidence for the superclasses
-(ie in tcSimplifySuperClasses) we need a superclass (Data Maybe [a]).
-Using the instance for Data, we therefore need
-        (Sat (Maybe [a], Data Maybe a)
-But we are given (Foo a), and hence its superclass (Data Maybe a).
-So that leaves (Sat (Maybe [a])).  Using the instance for Sat means
-we need (Foo [a]).  And that is the very dictionary we are bulding
-an instance for!  So we must put that in the "givens".  So in this
-case we have
-	Given:  Foo a, Foo [a]
-	Watend: Data Maybe [a]
-
-BUT we must *not not not* put the *superclasses* of (Foo [a]) in
-the givens, which is what 'addGiven' would normally do. Why? Because
-(Data Maybe [a]) is the superclass, so we'd "satisfy" the wanted 
-by selecting a superclass from Foo [a], which simply makes a loop.
-
-On the other hand we *must* put the superclasses of (Foo a) in
-the givens, as you can see from the derivation described above.
-
-Conclusion: in the very special case of tcSimplifySuperClasses
-we have one 'given' (namely the "this" dictionary) whose superclasses
-must not be added to 'givens' by addGiven.  
-
-There is a complication though.  Suppose there are equalities
-      instance (Eq a, a~b) => Num (a,b)
-Then we normalise the 'givens' wrt the equalities, so the original
-given "this" dictionary is cast to one of a different type.  So it's a
-bit trickier than before to identify the "special" dictionary whose
-superclasses must not be added. See test
-   indexed-types/should_run/EqInInstance
-
-We need a persistent property of the dictionary to record this
-special-ness.  Current I'm using the InstLocOrigin (a bit of a hack,
-but cool), which is maintained by dictionary normalisation.
-Specifically, the InstLocOrigin is
-	     NoScOrigin
-then the no-superclass thing kicks in.  WATCH OUT if you fiddle
-with InstLocOrigin!
+*********************************************************************************
+*                                                                                 * 
+*                             Superclasses                                        *
+*                                                                                 *
+***********************************************************************************
+
+When constructing evidence for superclasses in an instance declaration, 
+  * we MUST have the "self" dictionary available, but
+  * we must NOT have its superclasses derived from "self"
+
+Moreover, we must *completely* solve the constraints right now,
+not wrap them in an implication constraint to solve later.  Why?
+Because when that implication constraint is solved there may
+be some unrelated other solved top-level constraints that
+recursively depend on the superclass we are building. Consider
+   class Ord a => C a where
+   instance C [Int] where ...
+Then we get
+   dCListInt :: C [Int]
+   dCListInt = MkC $cNum ...
+
+   $cNum :: Ord [Int] -- The superclass
+   $cNum = let self = dCListInt in <solve Ord [Int]>
+
+Now, if there is some *other* top-level constraint solved
+looking like
+	foo :: Ord [Int]
+        foo = scsel dCInt
+we must not solve the (Ord [Int]) wanted from foo!!
 
 \begin{code}
-tcSimplifySuperClasses
-	:: InstLoc 
-	-> Inst		-- The dict whose superclasses 
-			-- are being figured out
-	-> [Inst]	-- Given 
-	-> [Inst]	-- Wanted
-	-> TcM TcDictBinds
-tcSimplifySuperClasses loc this givens sc_wanteds
-  = do	{ traceTc (text "tcSimplifySuperClasses")
-
-	      -- Note [Recursive instances and superclases]
-        ; no_sc_loc <- getInstLoc NoScOrigin
-	; let no_sc_this = setInstLoc this no_sc_loc
-
-	; let env =  RedEnv { red_doc = pprInstLoc loc, 
-	     		      red_try_me = try_me,
-	     	     	      red_givens = no_sc_this : givens, 
-	     	     	      red_stack = (0,[]),
-	     	     	      red_improve = False }  -- No unification vars
-
-
-	; (irreds,binds1) <- checkLoop env sc_wanteds
-	; let (tidy_env, tidy_irreds) = tidyInsts irreds
-	; reportNoInstances tidy_env (Just (loc, givens)) [] tidy_irreds
-	; return binds1 }
-  where
-    try_me _ = ReduceMe  -- Try hard, so we completely solve the superclass 
-    	       		 -- constraints right here. See Note [SUPERCLASS-LOOP 1]
+simplifySuperClass :: EvVar	-- The "self" dictionary
+		   -> WantedConstraints
+		   -> TcM ()
+simplifySuperClass self wanteds
+  = do { wanteds <- mapBagM zonkWanted wanteds
+       ; loc <- getCtLoc NoScSkol
+       ; (unsolved, ev_binds) 
+             <- runTcS SimplCheck emptyVarSet $
+         	do { can_self <- canGivens loc [self]
+         	   ; let inert = foldlBag extendInertSet emptyInert can_self
+	 	     -- No need for solveInteract; we know it's inert
+
+	 	   ; solveWanteds inert wanteds }
+
+       ; ASSERT2( isEmptyBag ev_binds, ppr ev_binds )
+         reportUnsolved unsolved }
 \end{code}
 
 
-%************************************************************************
-%*									*
-\subsection{tcSimplifyRestricted}
-%*									*
-%************************************************************************
-
-tcSimplifyRestricted infers which type variables to quantify for a 
-group of restricted bindings.  This isn't trivial.
-
-Eg1:	id = \x -> x
-	We want to quantify over a to get id :: forall a. a->a
-	
-Eg2:	eq = (==)
-	We do not want to quantify over a, because there's an Eq a 
-	constraint, so we get eq :: a->a->Bool	(notice no forall)
-
-So, assume:
-	RHS has type 'tau', whose free tyvars are tau_tvs
-	RHS has constraints 'wanteds'
-
-Plan A (simple)
-  Quantify over (tau_tvs \ ftvs(wanteds))
-  This is bad. The constraints may contain (Monad (ST s))
-  where we have 	instance Monad (ST s) where...
-  so there's no need to be monomorphic in s!
-
-  Also the constraint might be a method constraint,
-  whose type mentions a perfectly innocent tyvar:
-	  op :: Num a => a -> b -> a
-  Here, b is unconstrained.  A good example would be
-	foo = op (3::Int)
-  We want to infer the polymorphic type
-	foo :: forall b. b -> b
-
-
-Plan B (cunning, used for a long time up to and including GHC 6.2)
-  Step 1: Simplify the constraints as much as possible (to deal 
-  with Plan A's problem).  Then set
-	qtvs = tau_tvs \ ftvs( simplify( wanteds ) )
-
-  Step 2: Now simplify again, treating the constraint as 'free' if 
-  it does not mention qtvs, and trying to reduce it otherwise.
-  The reasons for this is to maximise sharing.
-
-  This fails for a very subtle reason.  Suppose that in the Step 2
-  a constraint (Foo (Succ Zero) (Succ Zero) b) gets thrown upstairs as 'free'.
-  In the Step 1 this constraint might have been simplified, perhaps to
-  (Foo Zero Zero b), AND THEN THAT MIGHT BE IMPROVED, to bind 'b' to 'T'.
-  This won't happen in Step 2... but that in turn might prevent some other
-  constraint (Baz [a] b) being simplified (e.g. via instance Baz [a] T where {..}) 
-  and that in turn breaks the invariant that no constraints are quantified over.
-
-  Test typecheck/should_compile/tc177 (which failed in GHC 6.2) demonstrates
-  the problem.
-
-
-Plan C (brutal)
-  Step 1: Simplify the constraints as much as possible (to deal 
-  with Plan A's problem).  Then set
-	qtvs = tau_tvs \ ftvs( simplify( wanteds ) )
-  Return the bindings from Step 1.
-  
-
-A note about Plan C (arising from "bug" reported by George Russel March 2004)
-Consider this:
-
-      instance (HasBinary ty IO) => HasCodedValue ty
-
-      foo :: HasCodedValue a => String -> IO a
-
-      doDecodeIO :: HasCodedValue a => () -> () -> IO a
-      doDecodeIO codedValue view  
-        = let { act = foo "foo" } in  act
-
-You might think this should work becuase the call to foo gives rise to a constraint
-(HasCodedValue t), which can be satisfied by the type sig for doDecodeIO.  But the
-restricted binding act = ... calls tcSimplifyRestricted, and PlanC simplifies the
-constraint using the (rather bogus) instance declaration, and now we are stuffed.
+*********************************************************************************
+*                                                                                 * 
+*                             RULES                                               *
+*                                                                                 *
+***********************************************************************************
 
-I claim this is not really a bug -- but it bit Sergey as well as George.  So here's
-plan D
+Note [Simplifying RULE lhs constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+On the LHS of transformation rules we only simplify only equalitis,
+but not dictionaries.  We want to keep dictionaries unsimplified, to
+serve as the available stuff for the RHS of the rule.  We *do* want to
+simplify equalities, however, to detect ill-typed rules that cannot be
+applied.
 
-
-Plan D (a variant of plan B)
-  Step 1: Simplify the constraints as much as possible (to deal 
-  with Plan A's problem), BUT DO NO IMPROVEMENT.  Then set
-	qtvs = tau_tvs \ ftvs( simplify( wanteds ) )
-
-  Step 2: Now simplify again, treating the constraint as 'free' if 
-  it does not mention qtvs, and trying to reduce it otherwise.
-
-  The point here is that it's generally OK to have too few qtvs; that is,
-  to make the thing more monomorphic than it could be.  We don't want to
-  do that in the common cases, but in wierd cases it's ok: the programmer
-  can always add a signature.  
-
-  Too few qtvs => too many wanteds, which is what happens if you do less
-  improvement.
-
-
-\begin{code}
-tcSimplifyRestricted 	-- Used for restricted binding groups
-			-- i.e. ones subject to the monomorphism restriction
-	:: SDoc
-	-> TopLevelFlag
-	-> [Name]		-- Things bound in this group
-	-> TcTyVarSet		-- Free in the type of the RHSs
-	-> [Inst]		-- Free in the RHSs
-	-> TcM ([TyVar],	-- Tyvars to quantify (zonked and quantified)
-		TcDictBinds)	-- Bindings
-	-- tcSimpifyRestricted returns no constraints to
-	-- quantify over; by definition there are none.
-	-- They are all thrown back in the LIE
-
-tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
-	-- Zonk everything in sight
-  = do	{ traceTc (text "tcSimplifyRestricted")
-	; wanteds_z <- zonkInsts wanteds
-
-   	-- 'ReduceMe': Reduce as far as we can.  Don't stop at
-	-- dicts; the idea is to get rid of as many type
-	-- variables as possible, and we don't want to stop
-	-- at (say) Monad (ST s), because that reduces
-	-- immediately, with no constraint on s.
-	--
-	-- BUT do no improvement!  See Plan D above
-	-- HOWEVER, some unification may take place, if we instantiate
-	-- 	    a method Inst with an equality constraint
-	; let env = mkNoImproveRedEnv doc (\_ -> ReduceMe)
-	; (_imp, _tybinds, _binds, constrained_dicts) 
-            <- reduceContext env wanteds_z
-
-	-- Next, figure out the tyvars we will quantify over
-	; tau_tvs' <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
-	; gbl_tvs' <- tcGetGlobalTyVars
-	; constrained_dicts' <- zonkInsts constrained_dicts
-
-	; let qtvs1 = tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs'
-				-- As in tcSimplifyInfer
-
-		-- Do not quantify over constrained type variables:
-		-- this is the monomorphism restriction
-	      constrained_tvs' = tyVarsOfInsts constrained_dicts'
-	      qtvs = qtvs1 `minusVarSet` constrained_tvs'
-	      pp_bndrs = pprWithCommas (quotes . ppr) bndrs
-
-	-- Warn in the mono
-	; warn_mono <- doptM Opt_WarnMonomorphism
-	; warnTc (warn_mono && (constrained_tvs' `intersectsVarSet` qtvs1))
-		 (vcat[ ptext (sLit "the Monomorphism Restriction applies to the binding")
-				<> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs,
-			ptext (sLit "Consider giving a type signature for") <+> pp_bndrs])
-
-	; traceTc (text "tcSimplifyRestricted" <+> vcat [
-		pprInsts wanteds, pprInsts constrained_dicts',
-		ppr _binds,
-		ppr constrained_tvs', ppr tau_tvs', ppr qtvs ])
-
-	-- The first step may have squashed more methods than
-	-- necessary, so try again, this time more gently, knowing the exact
-	-- set of type variables to quantify over.
-	--
-	-- We quantify only over constraints that are captured by qtvs;
-	-- these will just be a subset of non-dicts.  This in contrast
-	-- to normal inference (using isFreeWhenInferring) in which we quantify over
-	-- all *non-inheritable* constraints too.  This implements choice
-	-- (B) under "implicit parameter and monomorphism" above.
-	--
-	-- Remember that we may need to do *some* simplification, to
-	-- (for example) squash {Monad (ST s)} into {}.  It's not enough
-	-- just to float all constraints
-	--
-	-- At top level, we *do* squash methods because we want to 
-	-- expose implicit parameters to the test that follows
-	; let is_nested_group = isNotTopLevel top_lvl
-	      try_me inst | isFreeWrtTyVars qtvs inst,
-			   (is_nested_group || isDict inst) = Stop
-		          | otherwise  	                    = ReduceMe 
-	      env = mkNoImproveRedEnv doc try_me
-	; (_imp, tybinds, binds, irreds) <- reduceContext env wanteds_z
-        ; execTcTyVarBinds tybinds
-
-	-- See "Notes on implicit parameters, Question 4: top level"
-	; ASSERT( all (isFreeWrtTyVars qtvs) irreds )	-- None should be captured
-	  if is_nested_group then
-		extendLIEs irreds
-	  else do { let (bad_ips, non_ips) = partition isIPDict irreds
-		  ; addTopIPErrs bndrs bad_ips
-		  ; extendLIEs non_ips }
-
-	; qtvs' <- zonkQuantifiedTyVars (varSetElems qtvs)
-	; return (qtvs', binds) }
-\end{code}
-
-
-%************************************************************************
-%*									*
-		tcSimplifyRuleLhs
-%*									*
-%************************************************************************
-
-On the LHS of transformation rules we only simplify methods and constants,
-getting dictionaries.  We want to keep all of them unsimplified, to serve
-as the available stuff for the RHS of the rule.
+Implementation: the TcSFlags carried by the TcSMonad controls the
+amount of simplification, so simplifyRuleLhs just sets the flag
+appropriately.
 
 Example.  Consider the following left-hand side of a rule
-	
 	f (x == y) (y > z) = ...
-
 If we typecheck this expression we get constraints
-
 	d1 :: Ord a, d2 :: Eq a
-
 We do NOT want to "simplify" to the LHS
-
 	forall x::a, y::a, z::a, d1::Ord a.
 	  f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ...
-
 Instead we want	
-
 	forall x::a, y::a, z::a, d1::Ord a, d2::Eq a.
 	  f ((==) d2 x y) ((>) d1 y z) = ...
 
 Here is another example:
-
 	fromIntegral :: (Integral a, Num b) => a -> b
 	{-# RULES "foo"  fromIntegral = id :: Int -> Int #-}
-
 In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But
 we *dont* want to get
-
 	forall dIntegralInt.
 	   fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
-
 because the scsel will mess up RULE matching.  Instead we want
-
 	forall dIntegralInt, dNumInt.
 	  fromIntegral Int Int dIntegralInt dNumInt = id Int
 
 Even if we have 
-
 	g (x == y) (y == z) = ..
-
 where the two dictionaries are *identical*, we do NOT WANT
-
 	forall x::a, y::a, z::a, d1::Eq a
 	  f ((==) d1 x y) ((>) d1 y z) = ...
-
 because that will only match if the dict args are (visibly) equal.
 Instead we want to quantify over the dictionaries separately.
 
-In short, tcSimplifyRuleLhs must *only* squash LitInst and MethInts, leaving
-all dicts unchanged, with absolutely no sharing.  It's simpler to do this
-from scratch, rather than further parameterise simpleReduceLoop etc.
-Simpler, maybe, but alas not simple (see Trac #2494)
-
-* Type errors may give rise to an (unsatisfiable) equality constraint
-
-* Applications of a higher-rank function on the LHS may give
-  rise to an implication constraint, esp if there are unsatisfiable
-  equality constraints inside.
+In short, simplifyRuleLhs must *only* squash equalities, leaving
+all dicts unchanged, with absolutely no sharing.  
 
-\begin{code}
-tcSimplifyRuleLhs :: [Inst] -> TcM ([Inst], TcDictBinds)
-tcSimplifyRuleLhs wanteds
-  = do	{ wanteds' <- zonkInsts wanteds
-    	
-		-- Simplify equalities  
-		-- It's important to do this: Trac #3346 for example
-        ; (_, wanteds'', tybinds, binds1) <- tcReduceEqs [] wanteds'
-        ; execTcTyVarBinds tybinds
-
-	  	-- Simplify other constraints
-	; (irreds, binds2) <- go [] emptyBag wanteds''
-
-	  	-- Report anything that is left
-	; let (dicts, bad_irreds) = partition isDict irreds
-	; traceTc (text "tcSimplifyrulelhs" <+> pprInsts bad_irreds)
-	; addNoInstanceErrs (nub bad_irreds)
-		-- The nub removes duplicates, which has
-		-- not happened otherwise (see notes above)
-
-	; return (dicts, binds1 `unionBags` binds2) }
-  where
-    go :: [Inst] -> TcDictBinds -> [Inst] -> TcM ([Inst], TcDictBinds)
-    go irreds binds []
-	= return (irreds, binds)
-    go irreds binds (w:ws)
-	| isDict w
-	= go (w:irreds) binds ws
-	| isImplicInst w	-- Have a go at reducing the implication
-	= do { (binds1, irreds1) <- reduceImplication red_env w
-	     ; let (bad_irreds, ok_irreds) = partition isImplicInst irreds1
-	     ; go (bad_irreds ++ irreds) 
-		  (binds `unionBags` binds1) 
-		  (ok_irreds ++ ws)}
-	| otherwise
-	= do { w' <- zonkInst w  -- So that (3::Int) does not generate a call
-				 -- to fromInteger; this looks fragile to me
-	     ; lookup_result <- lookupSimpleInst w'
-	     ; case lookup_result of
-		 NoInstance      -> go (w:irreds) binds ws
-		 GenInst ws' rhs -> go irreds binds' (ws' ++ ws)
-			where
-			  binds' = addInstToDictBind binds w rhs
-	  }
-
-	-- Sigh: we need to reduce inside implications
-    red_env = mkInferRedEnv doc try_me
-    doc = ptext (sLit "Implication constraint in RULE lhs")
-    try_me inst | isMethodOrLit inst = ReduceMe
-		| otherwise	     = Stop	-- Be gentle
-\end{code}
-
-tcSimplifyBracket is used when simplifying the constraints arising from
-a Template Haskell bracket [| ... |].  We want to check that there aren't
-any constraints that can't be satisfied (e.g. Show Foo, where Foo has no
-Show instance), but we aren't otherwise interested in the results.
-Nor do we care about ambiguous dictionaries etc.  We will type check
-this bracket again at its usage site.
+HOWEVER, under a nested implication things are different
+Consider
+  f :: (forall a. Eq a => a->a) -> Bool -> ...
+  {-# RULES "foo" forall (v::forall b. Eq b => b->b).
+       f b True = ...
+    #=}
+Here we *must* solve the wanted (Eq a) from the given (Eq a)
+resulting from skolemising the agument type of g.  So we 
+revert to SimplCheck when going under an implication.  
 
 \begin{code}
-tcSimplifyBracket :: [Inst] -> TcM ()
-tcSimplifyBracket wanteds
-  = do	{ _ <- tryHardCheckLoop doc wanteds
-	; return () }
-  where
-    doc = text "tcSimplifyBracket"
+simplifyRule :: RuleName 
+             -> [TcTyVar]		-- Explicit skolems
+             -> WantedConstraints	-- Constraints from LHS
+             -> WantedConstraints	-- Constraints from RHS
+             -> TcM ([EvVar], 		-- LHS dicts
+                     TcEvBinds,		-- Evidence for LHS
+                     TcEvBinds)		-- Evidence for RHS
+-- See Note [Simplifying RULE lhs constraints]
+simplifyRule name tv_bndrs lhs_wanted rhs_wanted
+  = do { zonked_lhs <- mapBagM zonkWanted lhs_wanted
+       ; (lhs_residual, lhs_binds) <- simplifyAsMuchAsPossible SimplRuleLhs zonked_lhs
+
+       -- Don't quantify over equalities (judgement call here)
+       ; let (eqs, dicts) = partitionBag (isEqPred . wantedEvVarPred) lhs_residual
+             lhs_dicts    = map wantedEvVarToVar (bagToList dicts)  
+	     	     	       	 -- Dicts and implicit parameters
+       ; reportUnsolvedWantedEvVars eqs
+
+	     -- Notice that we simplify the RHS with only the explicitly
+	     -- introduced skolems, allowing the RHS to constrain any 
+	     -- unification variables.
+	     -- Then, and only then, we call zonkQuantifiedTypeVariables
+	     -- Example   foo :: Ord a => a -> a
+	     --		  foo_spec :: Int -> Int
+	     --		  {-# RULE "foo"  foo = foo_spec #-}
+	     --	    Here, it's the RHS that fixes the type variable
+
+	     -- So we don't want to make untouchable the type
+	     -- variables in the envt of the RHS, because they include
+	     -- the template variables of the RULE
+
+	     -- Hence the rather painful ad-hoc treatement here
+       ; rhs_binds_var@(EvBindsVar evb_ref _)  <- newTcEvBinds
+       ; loc        <- getCtLoc (RuleSkol name)
+       ; rhs_binds1 <- simplifyCheck SimplCheck $ unitBag $ WcImplic $ 
+             Implic { ic_env_tvs = emptyVarSet	  -- No untouchables
+             	    , ic_env = emptyNameEnv
+             	    , ic_skols = mkVarSet tv_bndrs
+             	    , ic_scoped = panic "emitImplication"
+             	    , ic_given = lhs_dicts
+             	    , ic_wanted = rhs_wanted
+             	    , ic_binds = rhs_binds_var
+             	    , ic_loc = loc }
+       ; rhs_binds2 <- readTcRef evb_ref
+
+       ; return ( lhs_dicts
+                , EvBinds lhs_binds 
+                , EvBinds (rhs_binds1 `unionBags` evBindMapBinds rhs_binds2)) }
 \end{code}
 
 
-%************************************************************************
-%*									*
-\subsection{Filtering at a dynamic binding}
-%*									*
-%************************************************************************
-
-When we have
-	let ?x = R in B
-
-we must discharge all the ?x constraints from B.  We also do an improvement
-step; if we have ?x::t1 and ?x::t2 we must unify t1, t2.
-
-Actually, the constraints from B might improve the types in ?x. For example
-
-	f :: (?x::Int) => Char -> Char
-	let ?x = 3 in f 'c'
-
-then the constraint (?x::Int) arising from the call to f will
-force the binding for ?x to be of type Int.
+*********************************************************************************
+*                                                                                 * 
+*                                 Main Simplifier                                 *
+*                                                                                 *
+***********************************************************************************
 
 \begin{code}
-tcSimplifyIPs :: [Inst]		-- The implicit parameters bound here
-	      -> [Inst]		-- Wanted
-	      -> TcM TcDictBinds
-	-- We need a loop so that we do improvement, and then
-	-- (next time round) generate a binding to connect the two
-	-- 	let ?x = e in ?x
-	-- Here the two ?x's have different types, and improvement 
-	-- makes them the same.
-
-tcSimplifyIPs given_ips wanteds
-  = do	{ wanteds'   <- zonkInsts wanteds
-	; given_ips' <- zonkInsts given_ips
-		-- Unusually for checking, we *must* zonk the given_ips
-
-	; let env = mkRedEnv doc try_me given_ips'
-	; (improved, tybinds, binds, irreds) <- reduceContext env wanteds'
-        ; execTcTyVarBinds tybinds
-
-	; if null irreds || not improved then 
-		ASSERT( all is_free irreds )
-		do { extendLIEs irreds
-		   ; return binds }
-	  else do
-        -- If improvement did some unification, we go round again.
-        -- We start again with irreds, not wanteds
-        -- Using an instance decl might have introduced a fresh type
-        -- variable which might have been unified, so we'd get an 
-        -- infinite loop if we started again with wanteds!  
-        -- See Note [LOOP]
-        { binds1 <- tcSimplifyIPs given_ips' irreds
-        ; return $ binds `unionBags` binds1
-        } }
+simplifyCheck :: SimplContext
+	      -> WantedConstraints	-- Wanted
+              -> TcM (Bag EvBind)
+-- Solve a single, top-level implication constraint
+-- e.g. typically one created from a top-level type signature
+-- 	    f :: forall a. [a] -> [a]
+--          f x = rhs
+-- We do this even if the function has no polymorphism:
+--    	    g :: Int -> Int
+
+--          g y = rhs
+-- (whereas for *nested* bindings we would not create
+--  an implication constraint for g at all.)
+--
+-- Fails if can't solve something in the input wanteds
+simplifyCheck ctxt wanteds
+  = do { wanteds <- mapBagM zonkWanted wanteds
+
+       ; traceTc "simplifyCheck {" (vcat
+             [ ptext (sLit "wanted =") <+> ppr wanteds ])
+
+       ; (unsolved, ev_binds) <- runTcS ctxt emptyVarSet $
+                                 solveWanteds emptyInert wanteds
+
+       ; traceTc "simplifyCheck }" $
+             ptext (sLit "unsolved =") <+> ppr unsolved
+
+       ; reportUnsolved unsolved
+
+       ; return ev_binds }
+
+----------------
+solveWanteds :: InertSet	       -- Given 
+             -> WantedConstraints      -- Wanted
+             -> TcS (CanonicalCts,     -- Unsolved flats
+                     Bag Implication)  -- Unsolved implications
+-- solveWanteds iterates when it is able to float equalities
+-- out of one or more of the implications 
+solveWanteds inert wanteds
+  = do { let (flat_wanteds, implic_wanteds) = splitWanteds wanteds
+       ; can_flats <- canWanteds $ bagToList flat_wanteds
+       ; traceTcS "solveWanteds {" $
+                 vcat [ text "wanteds =" <+> ppr wanteds
+                      , text "inert =" <+> ppr inert ]
+       ; (unsolved_flats, unsolved_implics) 
+               <- simpl_loop 1 can_flats implic_wanteds
+       ; traceTcS "solveWanteds }" $
+                 vcat [ text "wanteds =" <+> ppr wanteds
+                      , text "unsolved_flats =" <+> ppr unsolved_flats
+                      , text "unsolved_implics =" <+> ppr unsolved_implics ]
+       ; return (unsolved_flats, unsolved_implics)  }
   where
-    doc	   = text "tcSimplifyIPs" <+> ppr given_ips
-    ip_set = mkNameSet (ipNamesOfInsts given_ips)
-    is_free inst = isFreeWrtIPs ip_set inst
-
-	-- Simplify any methods that mention the implicit parameter
-    try_me inst | is_free inst = Stop
-		| otherwise    = ReduceMe
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
-%*									*
-%************************************************************************
-
-When doing a binding group, we may have @Insts@ of local functions.
-For example, we might have...
-\begin{verbatim}
-let f x = x + 1	    -- orig local function (overloaded)
-    f.1 = f Int	    -- two instances of f
-    f.2 = f Float
- in
-    (f.1 5, f.2 6.7)
-\end{verbatim}
-The point is: we must drop the bindings for @f.1@ and @f.2@ here,
-where @f@ is in scope; those @Insts@ must certainly not be passed
-upwards towards the top-level.	If the @Insts@ were binding-ified up
-there, they would have unresolvable references to @f@.
-
-We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
-For each method @Inst@ in the @init_lie@ that mentions one of the
-@Ids@, we create a binding.  We return the remaining @Insts@ (in an
-@LIE@), as well as the @HsBinds@ generated.
-
-\begin{code}
-bindInstsOfLocalFuns ::	[Inst] -> [TcId] -> TcM TcDictBinds
--- Simlifies only MethodInsts, and generate only bindings of form 
---	fm = f tys dicts
--- We're careful not to even generate bindings of the form
---	d1 = d2
--- You'd think that'd be fine, but it interacts with what is
--- arguably a bug in Match.tidyEqnInfo (see notes there)
-
-bindInstsOfLocalFuns wanteds local_ids
-  | null overloaded_ids = do
-	-- Common case
-    extendLIEs wanteds
-    return emptyLHsBinds
-
-  | otherwise
-  = do	{ (irreds, binds) <- gentleInferLoop doc for_me
-	; extendLIEs not_for_me	
-	; extendLIEs irreds
-	; return binds }
+    simpl_loop :: Int 
+               -> CanonicalCts	-- May inlude givens (in the recursive call)
+               -> Bag Implication
+               -> TcS (CanonicalCts, Bag Implication)
+    simpl_loop n can_ws implics
+      | n>10
+      = trace "solveWanteds: loop" $	-- Always bleat
+        do { traceTcS "solveWanteds: loop" (ppr inert)  -- Bleat more informatively
+           ; return (can_ws, implics) }
+
+      | otherwise
+      = do { inert1 <- solveInteract inert can_ws
+           ; let (inert2, unsolved_flats) = extractUnsolved inert1
+
+           ; traceTcS "solveWanteds/done flats"  $ 
+                 vcat [ text "inerts =" <+> ppr inert2
+                      , text "unsolved =" <+> ppr unsolved_flats ]
+
+                   -- See Note [Preparing inert set for implications]
+           ; inert_for_implics <- solveInteract inert2 (makeGivens unsolved_flats)
+           ; (implic_eqs, unsolved_implics) 
+                <- flatMapBagPairM (solveImplication inert_for_implics) implics
+
+		-- Apply defaulting rules if and only if there 
+		-- no floated equalities.  If there are, they may
+		-- solve the remaining wanteds, so don't do defaulting.
+           ; final_eqs <- if not (isEmptyBag implic_eqs)
+			  then return implic_eqs
+                          else applyDefaultingRules inert2 unsolved_flats
+	        -- default_eqs are *givens*, so simpl_loop may 
+		-- recurse with givens in the argument
+
+           ; if isEmptyBag final_eqs then
+                 return (unsolved_flats, unsolved_implics)
+             else 
+                 do { traceTcS ("solveWanteds iteration " ++ show n) $ vcat
+                        [ text "floated_unsolved_eqs =" <+> ppr final_eqs
+                        , text "unsolved_implics = " <+> ppr unsolved_implics ]
+                    ; simpl_loop (n+1) 
+                             	 (unsolved_flats `unionBags` final_eqs)
+                             	 unsolved_implics 
+           }        }
+
+solveImplication :: InertSet     -- Given 
+                    -> Implication  -- Wanted 
+                    -> TcS (CanonicalCts,	-- Unsolved unification var = type
+                            Bag Implication) 	-- Unsolved rest (always empty or singleton)
+-- Returns: 
+--  1. A bag of floatable wanted constraints, not mentioning any skolems, 
+--     that are of the form unification var = type
+-- 
+--  2. Maybe a unsolved implication, empty if entirely solved! 
+-- 
+-- Precondition: everything is zonked by now
+solveImplication inert 
+     imp@(Implic { ic_env_tvs = untch 
+                 , ic_binds   = ev_binds
+                 , ic_skols   = skols 
+                 , ic_given   = givens
+                 , ic_wanted = wanteds
+                 , ic_loc = loc })
+  = nestImplicTcS ev_binds untch $
+    do { traceTcS "solveImplication {" (ppr imp) 
+
+         -- Solve flat givens
+       ; can_givens  <- canGivens loc givens
+       ; given_inert <- solveInteract inert can_givens
+
+         -- Simplify the wanteds
+       ; (unsolved_flats, unsolved_implics) <- solveWanteds given_inert wanteds
+
+       ; let (res_flat_free, res_flat_bound) 
+                      = floatEqualities skols givens unsolved_flats
+             unsolved = mkWantedConstraints res_flat_bound unsolved_implics
+
+       ; traceTcS "solveImplication end }" $ vcat
+             [ text "res_flat_free =" <+> ppr res_flat_free
+             , text "res_flat_bound =" <+> ppr res_flat_bound
+             , text "unsolved_implics =" <+> ppr unsolved_implics ]
+
+       ; let res_bag | isEmptyBag unsolved = emptyBag
+                     | otherwise           = unitBag (imp { ic_wanted  = unsolved })
+
+       ; return (res_flat_free, res_bag) }
+
+floatEqualities :: TcTyVarSet -> [EvVar]
+                -> CanonicalCts -> (CanonicalCts, CanonicalCts)
+floatEqualities skols can_given wanteds
+  | hasEqualities can_given = (emptyBag, wanteds)
+  | otherwise                 = partitionBag is_floatable wanteds
   where
-    doc		     = text "bindInsts" <+> ppr local_ids
-    overloaded_ids   = filter is_overloaded local_ids
-    is_overloaded id = isOverloadedTy (idType id)
-    (for_me, not_for_me) = partition (isMethodFor overloaded_set) wanteds
-
-    overloaded_set = mkVarSet overloaded_ids	-- There can occasionally be a lot of them
-						-- so it's worth building a set, so that
-						-- lookup (in isMethodFor) is faster
+    is_floatable :: CanonicalCt -> Bool
+    is_floatable (CTyEqCan { cc_tyvar = tv, cc_rhs = ty })
+      | isMetaTyVar tv || isMetaTyVarTy ty
+      = skols `disjointVarSet` (extendVarSet (tyVarsOfType ty) tv)
+    is_floatable _ = False
 \end{code}
 
-
-%************************************************************************
-%*									*
-\subsection{Data types for the reduction mechanism}
-%*									*
-%************************************************************************
-
-The main control over context reduction is here
-
-\begin{code}
-data RedEnv 
-  = RedEnv { red_doc	:: SDoc			-- The context
-	   , red_try_me :: Inst -> WhatToDo
-	   , red_improve :: Bool		-- True <=> do improvement
-	   , red_givens :: [Inst]		-- All guaranteed rigid
-						-- Always dicts & equalities
-						-- but see Note [Rigidity]
+Note [Preparing inert set for implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Before solving the nested implications, we convert any unsolved flat wanteds
+to givens, and add them to the inert set.  Reasons:
+  a) In checking mode, suppresses unnecessary errors.  We already have 
+     on unsolved-wanted error; adding it to the givens prevents any 
+     consequential errors from showing uop
+  b) More importantly, in inference mode, we are going to quantify over this
+     constraint, and we *don't* want to quantify over any constraints that
+     are deducible from it.
+
+The unsolved wanteds are *canonical* but they may not be *inert*,
+because when made into a given they might interact with other givens.
+Hence the call to solveInteract.  Example:
+
+ Original inert set = (d :_g D a) /\ (co :_w  a ~ [beta]) 
+
+We were not able to solve (a ~w [beta]) but we can't just assume it as
+given because the resulting set is not inert. Hence we have to do a
+'solveInteract' step first
+
+*********************************************************************************
+*                                                                               * 
+*                          Defaulting and disamgiguation                        *
+*                                                                               *
+*********************************************************************************
+
+Basic plan behind applyDefaulting rules: 
  
-	   , red_stack  :: (Int, [Inst])	-- Recursion stack (for err msg)
-						-- See Note [RedStack]
-  }
-
--- Note [Rigidity]
--- The red_givens are rigid so far as cmpInst is concerned.
--- There is one case where they are not totally rigid, namely in tcSimplifyIPs
---	let ?x = e in ...
--- Here, the given is (?x::a), where 'a' is not necy a rigid type
--- But that doesn't affect the comparison, which is based only on mame.
-
--- Note [RedStack]
--- The red_stack pair (n,insts) pair is just used for error reporting.
--- 'n' is always the depth of the stack.
--- The 'insts' is the stack of Insts being reduced: to produce X
--- I had to produce Y, to produce Y I had to produce Z, and so on.
-
-
-mkRedEnv :: SDoc -> (Inst -> WhatToDo) -> [Inst] -> RedEnv
-mkRedEnv doc try_me givens
-  = RedEnv { red_doc = doc, red_try_me = try_me,
-	     red_givens = givens, 
-	     red_stack = (0,[]),
-	     red_improve = True }	
-
-mkInferRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv
--- No givens at all
-mkInferRedEnv doc try_me
-  = RedEnv { red_doc = doc, red_try_me = try_me,
-	     red_givens = [], 
-	     red_stack = (0,[]),
-	     red_improve = True }	
-
-mkNoImproveRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv
--- Do not do improvement; no givens
-mkNoImproveRedEnv doc try_me
-  = RedEnv { red_doc = doc, red_try_me = try_me,
-	     red_givens = [], 
-	     red_stack = (0,[]),
-	     red_improve = True }	
-
-data WhatToDo
- = ReduceMe 	-- Try to reduce this
-		-- If there's no instance, add the inst to the 
-		-- irreductible ones, but don't produce an error 
-		-- message of any kind.
-		-- It might be quite legitimate such as (Eq a)!
-
- | Stop		-- Return as irreducible unless it can
-			-- be reduced to a constant in one step
-			-- Do not add superclasses; see 
-
-data WantSCs = NoSCs | AddSCs	-- Tells whether we should add the superclasses
-				-- of a predicate when adding it to the avails
-	-- The reason for this flag is entirely the super-class loop problem
-	-- Note [SUPER-CLASS LOOP 1]
-
-zonkRedEnv :: RedEnv -> TcM RedEnv
-zonkRedEnv env
-  = do { givens' <- mapM zonkInst (red_givens env)
-       ; return $ env {red_givens = givens'}
-       }
-\end{code}
-
-
-%************************************************************************
-%*									*
-\subsection[reduce]{@reduce@}
-%*									*
-%************************************************************************
-
-Note [Ancestor Equalities]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-During context reduction, we add to the wanted equalities also those
-equalities that (transitively) occur in superclass contexts of wanted
-class constraints.  Consider the following code
-
-  class a ~ Int => C a
-  instance C Int
-
-If (C a) is wanted, we want to add (a ~ Int), which will be discharged by
-substituting Int for a.  Hence, we ultimately want (C Int), which we
-discharge with the explicit instance.
-
-\begin{code}
-reduceContext :: RedEnv
-	      -> [Inst]			-- Wanted
-	      -> TcM (ImprovementDone,
-                      TcTyVarBinds,     -- Type variable bindings
-		      TcDictBinds,	-- Dictionary bindings
-		      [Inst])		-- Irreducible
-
-reduceContext env wanteds0
-  = do	{ traceTc (text "reduceContext" <+> (vcat [
-	     text "----------------------",
-	     red_doc env,
-	     text "given" <+> ppr (red_givens env),
-	     text "wanted" <+> ppr wanteds0,
-	     text "----------------------"
-	     ]))
-
-          -- We want to add as wanted equalities those that (transitively) 
-          -- occur in superclass contexts of wanted class constraints.
-          -- See Note [Ancestor Equalities]
-	; ancestor_eqs <- ancestorEqualities wanteds0
-	; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs
-
-          -- Normalise and solve all equality constraints as far as possible
-          -- and normalise all dictionary constraints wrt to the reduced
-          -- equalities.  The returned wanted constraints include the
-          -- irreducible wanted equalities.
-        ; let wanteds = wanteds0 ++ ancestor_eqs
-              givens  = red_givens env
-        ; (givens', 
-           wanteds', 
-           tybinds,
-           normalise_binds) <- tcReduceEqs givens wanteds
-	; traceTc $ text "reduceContext: tcReduceEqs result" <+> vcat
-		      [ppr givens', ppr wanteds', ppr tybinds, 
-                       ppr normalise_binds]
-
-          -- Build the Avail mapping from "given_dicts"
-	; (init_state, _) <- getLIE $ do 
-		{ init_state <- foldlM addGiven emptyAvails givens'
-		; return init_state
-                }
-
-          -- Solve the *wanted* *dictionary* constraints (not implications)
-	  -- This may expose some further equational constraints in the course
-          -- of improvement due to functional dependencies if any of the
-          -- involved unifications gets deferred.
-	; let (wanted_implics, wanted_dicts) = partition isImplicInst wanteds'
-	; (avails, extra_eqs) <- getLIE (reduceList env wanted_dicts init_state)
-	  	   -- The getLIE is reqd because reduceList does improvement
-		   -- (via extendAvails) which may in turn do unification
-	; (dict_binds, 
-           bound_dicts, 
-           dict_irreds)       <- extractResults avails wanted_dicts
-	; traceTc $ text "reduceContext: extractResults" <+> vcat
-		      [ppr avails, ppr wanted_dicts, ppr dict_binds]
-
-	  -- Solve the wanted *implications*.  In doing so, we can provide
-	  -- as "given"   all the dicts that were originally given, 
-	  --		  *or* for which we now have bindings, 
-	  --		  *or* which are now irreds
-          -- NB: Equality irreds need to be converted, as the recursive 
-          --     invocation of the solver will still treat them as wanteds
-          --     otherwise.
-	; let implic_env = env { red_givens 
-                                   = givens ++ bound_dicts ++
-                                     map wantedToLocalEqInst dict_irreds }
-	; (implic_binds_s, implic_irreds_s) 
-            <- mapAndUnzipM (reduceImplication implic_env) wanted_implics
-	; let implic_binds  = unionManyBags implic_binds_s
-	      implic_irreds = concat implic_irreds_s
-
-          -- Collect all irreducible instances, and determine whether we should
-          -- go round again.  We do so in either of two cases:
-          -- (1) If dictionary reduction or equality solving led to
-          --     improvement (i.e., bindings for type variables).
-          -- (2) If we reduced dictionaries (i.e., got dictionary bindings),
-          --     they may have exposed further opportunities to normalise
-          --     family applications.  See Note [Dictionary Improvement]
-          --
-          -- NB: We do *not* go around for new extra_eqs.  Morally, we should,
-          --     but we can't without risking non-termination (see #2688).  By
-          --     not going around, we miss some legal programs mixing FDs and
-          --     TFs, but we never claimed to support such programs in the
-          --     current implementation anyway.
-
-	; let all_irreds       = dict_irreds ++ implic_irreds ++ extra_eqs
-      	      avails_improved  = availsImproved avails
-              eq_improved      = anyBag (not . isCoVarBind) tybinds
-              improvedFlexible = avails_improved || eq_improved
-              reduced_dicts    = not (isEmptyBag dict_binds)
-              improved         = improvedFlexible || reduced_dicts
-              --
-              improvedHint  = (if avails_improved then " [AVAILS]" else "") ++
-                              (if eq_improved then " [EQ]" else "")
-
-	; traceTc (text "reduceContext end" <+> (vcat [
-	     text "----------------------",
-	     red_doc env,
-	     text "given" <+> ppr givens,
-	     text "wanted" <+> ppr wanteds0,
-	     text "----",
-	     text "tybinds" <+> ppr tybinds,
-	     text "avails" <+> pprAvails avails,
-	     text "improved =" <+> ppr improved <+> text improvedHint,
-	     text "(all) irreds = " <+> ppr all_irreds,
-	     text "dict-binds = " <+> ppr dict_binds,
-	     text "implic-binds = " <+> ppr implic_binds,
-	     text "----------------------"
-	     ]))
-
-	; return (improved, 
-                  tybinds,
-                  normalise_binds `unionBags` dict_binds 
-                                  `unionBags` implic_binds, 
-                  all_irreds) 
-        }
-  where
-    isCoVarBind (TcTyVarBind tv _) = isCoVar tv
-
-tcImproveOne :: Avails -> Inst -> TcM ImprovementDone
-tcImproveOne avails inst
-  | not (isDict inst) = return False
-  | otherwise
-  = do	{ inst_envs <- tcGetInstEnvs
-	; let eqns = improveOne (classInstances inst_envs)
-				(dictPred inst, pprInstArising inst)
-				[ (dictPred p, pprInstArising p)
-				| p <- availsInsts avails, isDict p ]
-		-- Avails has all the superclasses etc (good)
-		-- It also has all the intermediates of the deduction (good)
-		-- It does not have duplicates (good)
-		-- NB that (?x::t1) and (?x::t2) will be held separately in 
-                --    avails so that improve will see them separate
-	; traceTc (text "improveOne" <+> ppr inst)
-	; unifyEqns eqns }
-
-unifyEqns :: [(Equation, (PredType, SDoc), (PredType, SDoc))] 
-	  -> TcM ImprovementDone
-unifyEqns [] = return False
-unifyEqns eqns
-  = do	{ traceTc (ptext (sLit "Improve:") <+> vcat (map pprEquationDoc eqns))
-        ; improved <- mapM unify eqns
-	; return $ or improved
-        }
-  where
-    unify ((qtvs, pairs), what1, what2)
-         = addErrCtxtM (mkEqnMsg what1 what2) $ 
-             do { let freeTyVars = unionVarSets (map tvs_pr pairs) 
-                                   `minusVarSet` qtvs
-                ; (_, _, tenv) <- tcInstTyVars (varSetElems qtvs)
-                ; mapM_ (unif_pr tenv) pairs
-                ; anyM isFilledMetaTyVar $ varSetElems freeTyVars
-                }
-
-    unif_pr tenv (ty1, ty2) = unifyType (substTy tenv ty1) (substTy tenv ty2)
-
-    tvs_pr (ty1, ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
-
-pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc
-pprEquationDoc (eqn, (p1, _), (p2, _)) 
-  = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
-
-mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv
-         -> TcM (TidyEnv, SDoc)
-mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
-  = do	{ pred1' <- zonkTcPredType pred1
-        ; pred2' <- zonkTcPredType pred2
-	; let { pred1'' = tidyPred tidy_env pred1'
-              ; pred2'' = tidyPred tidy_env pred2' }
-	; let msg = vcat [ptext (sLit "When using functional dependencies to combine"),
-			  nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]), 
-			  nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])]
-	; return (tidy_env, msg) }
-\end{code}
-
-Note [Dictionary Improvement]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In reduceContext, we first reduce equalities and then class constraints.
-However, the letter may expose further opportunities for the former.  Hence,
-we need to go around again if dictionary reduction produced any dictionary
-bindings.  The following example demonstrated the point:
-
-  data EX _x _y (p :: * -> *)
-  data ANY
-
-  class Base p
-
-  class Base (Def p) => Prop p where
-   type Def p
-
-  instance Base ()
-  instance Prop () where
-   type Def () = ()
-
-  instance (Base (Def (p ANY))) => Base (EX _x _y p)
-  instance (Prop (p ANY)) => Prop (EX _x _y p) where
-   type Def (EX _x _y p) = EX _x _y p
-
-  data FOO x
-  instance Prop (FOO x) where
-   type Def (FOO x) = ()
-
-  data BAR
-  instance Prop BAR where
-   type Def BAR = EX () () FOO
-
-During checking the last instance declaration, we need to check the superclass
-cosntraint Base (Def BAR), which family normalisation reduced to 
-Base (EX () () FOO).  Chasing the instance for Base (EX _x _y p), gives us
-Base (Def (FOO ANY)), which again requires family normalisation of Def to
-Base () before we can finish.
-
+ Step 1:  
+    Split wanteds into defaultable groups, `groups' and the rest `rest_wanted' 
+    For each defaultable group, do: 
+      For each possible substitution for [alpha |-> tau] where `alpha' is the 
+      group's variable, do: 
+        1) Make up new TcEvBinds
+        2) Extend TcS with (groupVariable 
+        3) given_inert <- solveOne inert (given : a ~ tau) 
+        4) (final_inert,unsolved) <- solveWanted (given_inert) (group_constraints)
+        5) if unsolved == empty then 
+                 sneakyUnify a |-> tau 
+                 write the evidence bins
+                 return (final_inert ++ group_constraints,[]) 
+                      -- will contain the info (alpha |-> tau)!!
+                 goto next defaultable group 
+           if unsolved <> empty then 
+                 throw away evidence binds
+                 try next substitution 
+     If you've run out of substitutions for this group, too bad, you failed 
+                 return (inert,group) 
+                 goto next defaultable group
+ 
+ Step 2: 
+   Collect all the (canonical-cts, wanteds) gathered this way. 
+   - Do a solveGiven over the canonical-cts to make sure they are inert 
+------------------------------------------------------------------------------------------
 
-The main context-reduction function is @reduce@.  Here's its game plan.
 
 \begin{code}
-reduceList :: RedEnv -> [Inst] -> Avails -> TcM Avails
-reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state
-  = do	{ traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state))
-	; dopts <- getDOpts
-	; when (debugIsOn && (n > 8)) $ do
-		debugDumpTcRn (hang (ptext (sLit "Interesting! Context reduction stack depth") <+> int n) 
-			     2 (ifPprDebug (nest 2 (pprStack stk))))
-	; if n >= ctxtStkDepth dopts then
-	    failWithTc (reduceDepthErr n stk)
-	  else
-	    go wanteds state }
-  where
-    go []     state = return state
-    go (w:ws) state = do { state' <- reduce (env {red_stack = (n+1, w:stk)}) w state
-			 ; go ws state' }
-
-    -- Base case: we're done!
-reduce :: RedEnv -> Inst -> Avails -> TcM Avails
-reduce env wanted avails
-
-    -- We don't reduce equalities here (and they must not end up as irreds
-    -- in the Avails!)
-  | isEqInst wanted
-  = return avails
-
-    -- It's the same as an existing inst, or a superclass thereof
-  | Just _ <- findAvail avails wanted
-  = do { traceTc (text "reduce: found " <+> ppr wanted)
-       ; return avails
-       }
-
+applyDefaultingRules :: InertSet
+                     -> CanonicalCts 	-- All wanteds
+                     -> TcS CanonicalCts
+-- Return some *extra* givens, which express the 
+-- type-class-default choice
+
+applyDefaultingRules inert wanteds
+  | isEmptyBag wanteds 
+  = return emptyBag
   | otherwise
-  = do	{ traceTc (text "reduce" <+> ppr wanted $$ ppr avails)
-	; case red_try_me env wanted of {
-	    Stop -> try_simple (addIrred NoSCs);
-			-- See Note [No superclasses for Stop]
-
-	    ReduceMe -> do	-- It should be reduced
-		{ (avails, lookup_result) <- reduceInst env avails wanted
-		; case lookup_result of
-		    NoInstance -> addIrred AddSCs avails wanted
-			     -- Add it and its superclasses
-		    	     
-		    GenInst [] rhs -> addWanted AddSCs avails wanted rhs []
-
-		    GenInst wanteds' rhs
-			  -> do	{ avails1 <- addIrred NoSCs avails wanted
-				; avails2 <- reduceList env wanteds' avails1
-				; addWanted AddSCs avails2 wanted rhs wanteds' } }
-		-- Temporarily do addIrred *before* the reduceList, 
-		-- which has the effect of adding the thing we are trying
-		-- to prove to the database before trying to prove the things it
-		-- needs.  See note [RECURSIVE DICTIONARIES]
-		-- NB: we must not do an addWanted before, because that adds the
-		--     superclasses too, and that can lead to a spurious loop; see
-		--     the examples in [SUPERCLASS-LOOP]
-		-- So we do an addIrred before, and then overwrite it afterwards with addWanted
-    } }
-  where
-  	-- First, see if the inst can be reduced to a constant in one step
-	-- Works well for literals (1::Int) and constant dictionaries (d::Num Int)
-	-- Don't bother for implication constraints, which take real work
-    try_simple do_this_otherwise
-      = do { res <- lookupSimpleInst wanted
-	   ; case res of
-	        GenInst [] rhs -> addWanted AddSCs avails wanted rhs []
-	        _              -> do_this_otherwise avails wanted }
-\end{code}
-
-
-Note [RECURSIVE DICTIONARIES]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider 
-    data D r = ZeroD | SuccD (r (D r));
-    
-    instance (Eq (r (D r))) => Eq (D r) where
-        ZeroD     == ZeroD     = True
-        (SuccD a) == (SuccD b) = a == b
-        _         == _         = False;
-    
-    equalDC :: D [] -> D [] -> Bool;
-    equalDC = (==);
-
-We need to prove (Eq (D [])).  Here's how we go:
-
-	d1 : Eq (D [])
-
-by instance decl, holds if
-	d2 : Eq [D []]
-	where 	d1 = dfEqD d2
-
-by instance decl of Eq, holds if
-	d3 : D []
-	where	d2 = dfEqList d3
-		d1 = dfEqD d2
-
-But now we can "tie the knot" to give
-
-	d3 = d1
-	d2 = dfEqList d3
-	d1 = dfEqD d2
-
-and it'll even run!  The trick is to put the thing we are trying to prove
-(in this case Eq (D []) into the database before trying to prove its
-contributing clauses.
-	
-Note [SUPERCLASS-LOOP 2]
-~~~~~~~~~~~~~~~~~~~~~~~~
-We need to be careful when adding "the constaint we are trying to prove".
-Suppose we are *given* d1:Ord a, and want to deduce (d2:C [a]) where
-
-	class Ord a => C a where
-	instance Ord [a] => C [a] where ...
-
-Then we'll use the instance decl to deduce C [a] from Ord [a], and then add the
-superclasses of C [a] to avails.  But we must not overwrite the binding
-for Ord [a] (which is obtained from Ord a) with a superclass selection or we'll just
-build a loop! 
-
-Here's another variant, immortalised in tcrun020
-	class Monad m => C1 m
-	class C1 m => C2 m x
-	instance C2 Maybe Bool
-For the instance decl we need to build (C1 Maybe), and it's no good if
-we run around and add (C2 Maybe Bool) and its superclasses to the avails 
-before we search for C1 Maybe.
-
-Here's another example 
- 	class Eq b => Foo a b
-	instance Eq a => Foo [a] a
-If we are reducing
-	(Foo [t] t)
-
-we'll first deduce that it holds (via the instance decl).  We must not
-then overwrite the Eq t constraint with a superclass selection!
-
-At first I had a gross hack, whereby I simply did not add superclass constraints
-in addWanted, though I did for addGiven and addIrred.  This was sub-optimal,
-becuase it lost legitimate superclass sharing, and it still didn't do the job:
-I found a very obscure program (now tcrun021) in which improvement meant the
-simplifier got two bites a the cherry... so something seemed to be an Stop
-first time, but reducible next time.
-
-Now we implement the Right Solution, which is to check for loops directly 
-when adding superclasses.  It's a bit like the occurs check in unification.
-
-
-
-%************************************************************************
-%*									*
-		Reducing a single constraint
-%*									*
-%************************************************************************
-
-\begin{code}
----------------------------------------------
-reduceInst :: RedEnv -> Avails -> Inst -> TcM (Avails, LookupInstResult)
-reduceInst _ avails other_inst
-  = do	{ result <- lookupSimpleInst other_inst
-	; return (avails, result) }
-\end{code}
-
-Note [Equational Constraints in Implication Constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-An implication constraint is of the form 
-	Given => Wanted 
-where Given and Wanted may contain both equational and dictionary
-constraints. The delay and reduction of these two kinds of constraints
-is distinct:
-
--) In the generated code, wanted Dictionary constraints are wrapped up in an
-   implication constraint that is created at the code site where the wanted
-   dictionaries can be reduced via a let-binding. This let-bound implication
-   constraint is deconstructed at the use-site of the wanted dictionaries.
-
--) While the reduction of equational constraints is also delayed, the delay
-   is not manifest in the generated code. The required evidence is generated
-   in the code directly at the use-site. There is no let-binding and deconstruction
-   necessary. The main disadvantage is that we cannot exploit sharing as the
-   same evidence may be generated at multiple use-sites. However, this disadvantage
-   is limited because it only concerns coercions which are erased.
-
-The different treatment is motivated by the different in representation. Dictionary
-constraints require manifest runtime dictionaries, while equations require coercions
-which are types.
-
-\begin{code}
----------------------------------------------
-reduceImplication :: RedEnv
-		  -> Inst
-		  -> TcM (TcDictBinds, [Inst])
-\end{code}
-
-Suppose we are simplifying the constraint
-	forall bs. extras => wanted
-in the context of an overall simplification problem with givens 'givens'.
-
-Note that
-  * The 'givens' need not mention any of the quantified type variables
-	e.g. 	forall {}. Eq a => Eq [a]
-		forall {}. C Int => D (Tree Int)
-
-    This happens when you have something like
-	data T a where
-	  T1 :: Eq a => a -> T a
-
-	f :: T a -> Int
-	f x = ...(case x of { T1 v -> v==v })...
-
-\begin{code}
-	-- ToDo: should we instantiate tvs?  I think it's not necessary
-	--
-	-- Note on coercion variables:
-	--
-	--	The extra given coercion variables are bound at two different 
-        --      sites:
-        --
-	--	-) in the creation context of the implication constraint	
-	--		the solved equational constraints use these binders
-	--
-	--	-) at the solving site of the implication constraint
-	--		the solved dictionaries use these binders;
-	--		these binders are generated by reduceImplication
-	--
-        -- Note [Binders for equalities]
-        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-        -- To reuse the binders of local/given equalities in the binders of 
-        -- implication constraints, it is crucial that these given equalities
-        -- always have the form
-        --   cotv :: t1 ~ t2
-        -- where cotv is a simple coercion type variable (and not a more
-        -- complex coercion term).  We require that the extra_givens always
-        -- have this form and exploit the special form when generating binders.
-reduceImplication env
-	orig_implic@(ImplicInst { tci_name = name, tci_loc = inst_loc,
-		      	   	  tci_tyvars = tvs,
-		      	   	  tci_given = extra_givens, tci_wanted = wanteds
-                                 })
-  = do	{ 	-- Solve the sub-problem
-	; let try_me _ = ReduceMe  -- Note [Freeness and implications]
-	      env' = env { red_givens = extra_givens ++ red_givens env
-			 , red_doc = sep [ptext (sLit "reduceImplication for") 
-                                            <+> ppr name,
-					  nest 2 (parens $ ptext (sLit "within")
-                                                           <+> red_doc env)]
-			 , red_try_me = try_me }
-
-	; traceTc (text "reduceImplication" <+> vcat
-			[ ppr (red_givens env), ppr extra_givens, 
-			  ppr wanteds])
-	; (irreds, binds) <- checkLoop env' wanteds
-
-	; traceTc (text "reduceImplication result" <+> vcat
-			[ppr irreds, ppr binds])
-
-	; -- extract superclass binds
-	  --  (sc_binds,_) <- extractResults avails []
--- 	; traceTc (text "reduceImplication sc_binds" <+> vcat
---			[ppr sc_binds, ppr avails])
---  
-
-	-- SLPJ Sept 07: what if improvement happened inside the checkLoop?
-	-- Then we must iterate the outer loop too!
-
-        ; didntSolveWantedEqs <- allM wantedEqInstIsUnsolved wanteds
-                                   -- we solve wanted eqs by side effect!
-
-            -- Progress is no longer measered by the number of bindings
-            -- If there are any irreds, but no bindings and no solved
-            -- equalities, we back off and do nothing
-        ; let backOff = isEmptyLHsBinds binds &&   -- no new bindings
-                        (not $ null irreds)   &&   -- but still some irreds
-                        didntSolveWantedEqs        -- no instantiated cotv
-
-	; if backOff then 	-- No progress
-		return (emptyBag, [orig_implic])
-	  else do
-	{ (simpler_implic_insts, bind) 
-            <- makeImplicationBind inst_loc tvs extra_givens irreds
-		-- This binding is useless if the recursive simplification
-		-- made no progress; but currently we don't try to optimise that
-		-- case.  After all, we only try hard to reduce at top level, or
-		-- when inferring types.
-
-	; let   -- extract Id binders for dicts and CoTyVar binders for eqs;
-                -- see Note [Binders for equalities]
-	      (extra_eq_givens, extra_dict_givens) = partition isEqInst 
-                                                               extra_givens
-              eq_cotvs = map instToVar extra_eq_givens
-	      dict_ids = map instToId  extra_dict_givens 
-
-              co         = mkWpTyLams tvs
-                           <.> mkWpTyLams eq_cotvs
-                           <.> mkWpLams dict_ids
-                           <.> WpLet (binds `unionBags` bind)
-              rhs        = mkLHsWrap co payload
-              loc        = instLocSpan inst_loc
-		             -- wanted equalities are solved by updating their
-                             -- cotv; we don't generate bindings for them
-              dict_bndrs =   map (L loc . HsVar . instToId) 
-                           . filter (not . isEqInst) 
-                           $ wanteds
-              payload    = mkBigLHsTup dict_bndrs
-	
-	; traceTc (vcat [text "reduceImplication" <+> ppr name,
-			 ppr simpler_implic_insts,
-			 text "->" <+> ppr rhs])
-	; return (unitBag (L loc (VarBind { var_id= instToId orig_implic
-					  , var_rhs = rhs
-					  , var_inline = notNull dict_ids }
-				-- See Note [Always inline implication constraints]
-			  )),
-		  simpler_implic_insts)
-  	} 
-    }
-reduceImplication _ i = pprPanic "reduceImplication" (ppr i)
-\end{code}
-
-Note [Always inline implication constraints]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose an implication constraint floats out of an INLINE function.
-Then although the implication has a single call site, it won't be 
-inlined.  And that is bad because it means that even if there is really
-*no* overloading (type signatures specify the exact types) there will
-still be dictionary passing in the resulting code.  To avert this,
-we mark the implication constraints themselves as INLINE, at least when
-there is no loss of sharing as a result.
-
-Note [Freeness and implications]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It's hard to say when an implication constraint can be floated out.  Consider
-	forall {} Eq a => Foo [a]
-The (Foo [a]) doesn't mention any of the quantified variables, but it
-still might be partially satisfied by the (Eq a). 
-
-There is a useful special case when it *is* easy to partition the 
-constraints, namely when there are no 'givens'.  Consider
-	forall {a}. () => Bar b
-There are no 'givens', and so there is no reason to capture (Bar b).
-We can let it float out.  But if there is even one constraint we
-must be much more careful:
-	forall {a}. C a b => Bar (m b)
-because (C a b) might have a superclass (D b), from which we might 
-deduce (Bar [b]) when m later gets instantiated to [].  Ha!
-
-Here is an even more exotic example
-	class C a => D a b
-Now consider the constraint
-	forall b. D Int b => C Int
-We can satisfy the (C Int) from the superclass of D, so we don't want
-to float the (C Int) out, even though it mentions no type variable in
-the constraints!
-
-One more example: the constraint
-	class C a => D a b
-	instance (C a, E c) => E (a,c)
-
-	constraint: forall b. D Int b => E (Int,c)
-
-You might think that the (D Int b) can't possibly contribute
-to solving (E (Int,c)), since the latter mentions 'c'.  But 
-in fact it can, because solving the (E (Int,c)) constraint needs 
-dictionaries
-	C Int, E c
-and the (C Int) can be satisfied from the superclass of (D Int b).
-So we must still not float (E (Int,c)) out.
-
-To think about: special cases for unary type classes?
-
-Note [Pruning the givens in an implication constraint]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we are about to form the implication constraint
-	forall tvs.  Eq a => Ord b
-The (Eq a) cannot contribute to the (Ord b), because it has no access to
-the type variable 'b'.  So we could filter out the (Eq a) from the givens.
-But BE CAREFUL of the examples above in [Freeness and implications].
-
-Doing so would be a bit tidier, but all the implication constraints get
-simplified away by the optimiser, so it's no great win.   So I don't take
-advantage of that at the moment.
-
-If you do, BE CAREFUL of wobbly type variables.
-
-
-%************************************************************************
-%*									*
-		Avails and AvailHow: the pool of evidence
-%*									*
-%************************************************************************
-
-
-\begin{code}
-data Avails = Avails !ImprovementDone !AvailEnv
-
-type ImprovementDone = Bool	-- True <=> some unification has happened
-				-- so some Irreds might now be reducible
-				-- keys that are now 
-
-type AvailEnv = FiniteMap Inst AvailHow
-data AvailHow
-  = IsIrred 		-- Used for irreducible dictionaries,
-			-- which are going to be lambda bound
-
-  | Given Inst 		-- Used for dictionaries for which we have a binding
-			-- e.g. those "given" in a signature
-
-  | Rhs 		-- Used when there is a RHS
-	(LHsExpr TcId) 	-- The RHS
-	[Inst]		-- Insts free in the RHS; we need these too
-
-instance Outputable Avails where
-  ppr = pprAvails
-
-pprAvails :: Avails -> SDoc
-pprAvails (Avails imp avails)
-  = vcat [ ptext (sLit "Avails") <> (if imp then ptext (sLit "[improved]") else empty)
-	 , nest 2 $ braces $ 
-	   vcat [ sep [ppr inst, nest 2 (equals <+> ppr avail)]
-		| (inst,avail) <- fmToList avails ]]
-
-instance Outputable AvailHow where
-    ppr = pprAvail
-
--------------------------
-pprAvail :: AvailHow -> SDoc
-pprAvail IsIrred	= text "Irred"
-pprAvail (Given x)   	= text "Given" <+> ppr x
-pprAvail (Rhs rhs bs)   = sep [text "Rhs" <+> ppr bs,
-			       nest 2 (ppr rhs)]
-
--------------------------
-extendAvailEnv :: AvailEnv -> Inst -> AvailHow -> AvailEnv
-extendAvailEnv env inst avail = addToFM env inst avail
-
-findAvailEnv :: AvailEnv -> Inst -> Maybe AvailHow
-findAvailEnv env wanted = lookupFM env wanted
-	-- NB 1: the Ord instance of Inst compares by the class/type info
-	--  *not* by unique.  So
-	--	d1::C Int ==  d2::C Int
-
-emptyAvails :: Avails
-emptyAvails = Avails False emptyFM
-
-findAvail :: Avails -> Inst -> Maybe AvailHow
-findAvail (Avails _ avails) wanted = findAvailEnv avails wanted
-
-elemAvails :: Inst -> Avails -> Bool
-elemAvails wanted (Avails _ avails) = wanted `elemFM` avails
-
-extendAvails :: Avails -> Inst -> AvailHow -> TcM Avails
--- Does improvement
-extendAvails avails@(Avails imp env) inst avail
-  = do	{ imp1 <- tcImproveOne avails inst	-- Do any improvement
-	; return (Avails (imp || imp1) (extendAvailEnv env inst avail)) }
-
-availsInsts :: Avails -> [Inst]
-availsInsts (Avails _ avails) = keysFM avails
-
-availsImproved :: Avails -> ImprovementDone
-availsImproved (Avails imp _) = imp
-\end{code}
-
-Extracting the bindings from a bunch of Avails.
-The bindings do *not* come back sorted in dependency order.
-We assume that they'll be wrapped in a big Rec, so that the
-dependency analyser can sort them out later
-
-\begin{code}
-type DoneEnv = FiniteMap Inst [Id]
--- Tracks which things we have evidence for
-
-extractResults :: Avails
-	       -> [Inst]		-- Wanted
-	       -> TcM (TcDictBinds, 	-- Bindings
-		       [Inst],		-- The insts bound by the bindings
-		       [Inst])		-- Irreducible ones
-			-- Note [Reducing implication constraints]
-
-extractResults (Avails _ avails) wanteds
-  = go emptyBag [] [] emptyFM wanteds
-  where
-    go	:: TcDictBinds 	-- Bindings for dicts
-	-> [Inst]	-- Bound by the bindings
-	-> [Inst]	-- Irreds
-	-> DoneEnv	-- Has an entry for each inst in the above three sets
-	-> [Inst]	-- Wanted
-	-> TcM (TcDictBinds, [Inst], [Inst])
-    go binds bound_dicts irreds _ [] 
-      = return (binds, bound_dicts, irreds)
-
-    go binds bound_dicts irreds done (w:ws)
-      | isEqInst w
-      = go binds bound_dicts (w:irreds) done' ws
-
-      | Just done_ids@(done_id : rest_done_ids) <- lookupFM done w
-      = if w_id `elem` done_ids then
-	   go binds bound_dicts irreds done ws
-	else
-	   go (add_bind (nlHsVar done_id)) bound_dicts irreds
-	      (addToFM done w (done_id : w_id : rest_done_ids)) ws
-
-      | otherwise	-- Not yet done
-      = case findAvailEnv avails w of
-	  Nothing -> pprTrace "Urk: extractResults" (ppr w) $
-		     go binds bound_dicts irreds done ws
-
-	  Just IsIrred -> go binds bound_dicts (w:irreds) done' ws
-
-	  Just (Rhs rhs ws') -> go (add_bind rhs) (w:bound_dicts) irreds done' (ws' ++ ws)
-
-	  Just (Given g) -> go binds' bound_dicts irreds (addToFM done w [g_id]) ws 
-		where
-		  g_id = instToId g
-		  binds' | w_id == g_id = binds
-			 | otherwise    = add_bind (nlHsVar g_id)
-      where
-	w_id  = instToId w	
-	done' = addToFM done w [w_id]
-	add_bind rhs = addInstToDictBind binds w rhs
-\end{code}
-
-
-Note [No superclasses for Stop]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When we decide not to reduce an Inst -- the 'WhatToDo' --- we still
-add it to avails, so that any other equal Insts will be commoned up
-right here.  However, we do *not* add superclasses.  If we have
-	df::Floating a
-	dn::Num a
-but a is not bound here, then we *don't* want to derive dn from df
-here lest we lose sharing.
-
-\begin{code}
-addWanted :: WantSCs -> Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails
-addWanted want_scs avails wanted rhs_expr wanteds
-  = addAvailAndSCs want_scs avails wanted avail
-  where
-    avail = Rhs rhs_expr wanteds
-
-addGiven :: Avails -> Inst -> TcM Avails
-addGiven avails given 
-  = addAvailAndSCs want_scs avails given (Given given)
-  where
-    want_scs = case instLocOrigin (instLoc given) of
-    	         NoScOrigin -> NoSCs
-		 _other	    -> AddSCs
-	-- Conditionally add superclasses for 'given'
-	-- See Note [Recursive instances and superclases]
-
-  -- No ASSERT( not (given `elemAvails` avails) ) because in an
-  -- instance decl for Ord t we can add both Ord t and Eq t as
-  -- 'givens', so the assert isn't true
-\end{code}
-
-\begin{code}
-addIrred :: WantSCs -> Avails -> Inst -> TcM Avails
-addIrred want_scs avails irred = ASSERT2( not (irred `elemAvails` avails), ppr irred $$ ppr avails )
-    	      		         addAvailAndSCs want_scs avails irred IsIrred
-
-addAvailAndSCs :: WantSCs -> Avails -> Inst -> AvailHow -> TcM Avails
-addAvailAndSCs want_scs avails inst avail
-  | not (isClassDict inst) = extendAvails avails inst avail
-  | NoSCs <- want_scs	   = extendAvails avails inst avail
-  | otherwise		   = do { traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps])
-				; avails' <- extendAvails avails inst avail
-				; addSCs is_loop avails' inst }
-  where
-    is_loop pred = any (`tcEqType` mkPredTy pred) dep_tys
-			-- Note: this compares by *type*, not by Unique
-    deps         = findAllDeps (unitVarSet (instToVar inst)) avail
-    dep_tys	 = map idType (varSetElems deps)
-
-    findAllDeps :: IdSet -> AvailHow -> IdSet
-    -- Find all the Insts that this one depends on
-    -- See Note [SUPERCLASS-LOOP 2]
-    -- Watch out, though.  Since the avails may contain loops 
-    -- (see Note [RECURSIVE DICTIONARIES]), so we need to track the ones we've seen so far
-    findAllDeps so_far (Rhs _ kids) = foldl find_all so_far kids
-    findAllDeps so_far _            = so_far
-
-    find_all :: IdSet -> Inst -> IdSet
-    find_all so_far kid
-      | isEqInst kid                       = so_far
-      | kid_id `elemVarSet` so_far	   = so_far
-      | Just avail <- findAvail avails kid = findAllDeps so_far' avail
-      | otherwise			   = so_far'
-      where
-	so_far' = extendVarSet so_far kid_id	-- Add the new kid to so_far
-	kid_id = instToId kid
-
-addSCs :: (TcPredType -> Bool) -> Avails -> Inst -> TcM Avails
-	-- Add all the superclasses of the Inst to Avails
-	-- The first param says "don't do this because the original thing
-	--	depends on this one, so you'd build a loop"
-	-- Invariant: the Inst is already in Avails.
-
-addSCs is_loop avails dict
-  = ASSERT( isDict dict )
-    do	{ sc_dicts <- newDictBndrs (instLoc dict) sc_theta'
-	; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) }
-  where
-    (clas, tys) = getDictClassTys dict
-    (tyvars, sc_theta, sc_sels, _) = classBigSig clas
-    sc_theta' = filter (not . isEqPred) $
-                  substTheta (zipTopTvSubst tyvars tys) sc_theta
-
-    add_sc avails (sc_dict, sc_sel)
-      | is_loop (dictPred sc_dict) = return avails 	-- See Note [SUPERCLASS-LOOP 2]
-      | is_given sc_dict 	   = return avails
-      | otherwise		   = do { avails' <- extendAvails avails sc_dict (Rhs sc_sel_rhs [dict])
-					; addSCs is_loop avails' sc_dict }
-      where
-	sc_sel_rhs = L (instSpan dict) (HsWrap co_fn (HsVar sc_sel))
-	co_fn	   = WpApp (instToVar dict) <.> mkWpTyApps tys
-
-    is_given :: Inst -> Bool
-    is_given sc_dict = case findAvail avails sc_dict of
-			  Just (Given _) -> True	-- Given is cheaper than superclass selection
-			  _              -> False
-
--- From the a set of insts obtain all equalities that (transitively) occur in
--- superclass contexts of class constraints (aka the ancestor equalities). 
+  = do { untch <- getUntouchablesTcS
+       ; tv_cts <- mapM (defaultTyVar untch) $
+                   varSetElems (tyVarsOfCanonicals wanteds)
+
+       ; info@(_, default_tys, _) <- getDefaultInfo
+       ; let groups = findDefaultableGroups info untch wanteds
+       ; deflt_cts <- mapM (disambigGroup default_tys untch inert) groups
+
+       ; traceTcS "deflt2" (vcat [ text "Tyvar defaults =" <+> ppr tv_cts
+                                 , text "Type defaults =" <+> ppr deflt_cts])
+
+       ; return (unionManyBags deflt_cts `andCCan` unionManyBags tv_cts) }
+
+------------------
+defaultTyVar :: TcTyVarSet -> TcTyVar -> TcS CanonicalCts
+-- defaultTyVar is used on any un-instantiated meta type variables to
+-- default the kind of ? and ?? etc to *.  This is important to ensure
+-- that instance declarations match.  For example consider
+--	instance Show (a->b)
+--	foo x = show (\_ -> True)
+-- Then we'll get a constraint (Show (p ->q)) where p has argTypeKind (printed ??), 
+-- and that won't match the typeKind (*) in the instance decl.  
+-- See test tc217.
 --
-ancestorEqualities :: [Inst] -> TcM [Inst]
-ancestorEqualities
-  =   mapM mkWantedEqInst               -- turn only equality predicates..
-    . filter isEqPred                   -- ..into wanted equality insts
-    . bagToList 
-    . addAEsToBag emptyBag              -- collect the superclass constraints..
-    . map dictPred                      -- ..of all predicates in a bag
-    . filter isClassDict
+-- We look only at touchable type variables. No further constraints
+-- are going to affect these type variables, so it's time to do it by
+-- hand.  However we aren't ready to default them fully to () or
+-- whatever, because the type-class defaulting rules have yet to run.
+
+defaultTyVar untch the_tv 
+  | isMetaTyVar the_tv
+  , not (the_tv `elemVarSet` untch)
+  , not (k `eqKind` default_k)
+  = do { (ev, better_ty) <- TcSMonad.newKindConstraint (mkTyVarTy the_tv) default_k
+       ; let loc = CtLoc TypeEqOrigin (getSrcSpan the_tv) [] -- Yuk
+             wanted_eq  = CTyEqCan { cc_id     = ev
+                                   , cc_flavor = Wanted loc
+                                   , cc_tyvar  = the_tv
+           	                   , cc_rhs    = better_ty }
+       ; return (unitBag wanted_eq) }
+
+  | otherwise            
+  = return emptyCCan	 -- The common case
   where
-    addAEsToBag :: Bag PredType -> [PredType] -> Bag PredType
-    addAEsToBag bag []           = bag
-    addAEsToBag bag (pred:preds)
-      | pred `elemBag` bag = addAEsToBag bag         preds
-      | isEqPred pred      = addAEsToBag bagWithPred preds
-      | isClassPred pred   = addAEsToBag bagWithPred predsWithSCs
-      | otherwise          = addAEsToBag bag         preds
-      where
-        bagWithPred  = bag `snocBag` pred
-        predsWithSCs = preds ++ substTheta (zipTopTvSubst tyvars tys) sc_theta
-        --
-        (tyvars, sc_theta, _, _) = classBigSig clas
-        (clas, tys) 		 = getClassPredTys pred 
-\end{code}
-
-
-%************************************************************************
-%*									*
-\section{tcSimplifyTop: defaulting}
-%*									*
-%************************************************************************
-
-
-@tcSimplifyTop@ is called once per module to simplify all the constant
-and ambiguous Insts.
-
-We need to be careful of one case.  Suppose we have
-
-	instance Num a => Num (Foo a b) where ...
-
-and @tcSimplifyTop@ is given a constraint (Num (Foo x y)).  Then it'll simplify
-to (Num x), and default x to Int.  But what about y??
-
-It's OK: the final zonking stage should zap y to (), which is fine.
-
-
-\begin{code}
-tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds
-tcSimplifyTop wanteds
-  = tc_simplify_top doc False wanteds
+    k = tyVarKind the_tv
+    default_k = defaultKind k
+
+
+----------------
+findDefaultableGroups 
+    :: ( SimplContext 
+       , [Type]
+       , (Bool,Bool) )  -- (Overloaded strings, extended default rules)
+    -> TcTyVarSet	-- Untouchable
+    -> CanonicalCts	-- Unsolved
+    -> [[(CanonicalCt,TcTyVar)]]
+findDefaultableGroups (ctxt, default_tys, (ovl_strings, extended_defaults)) 
+                      untch wanteds
+  | not (performDefaulting ctxt) = []
+  | null default_tys             = []
+  | otherwise = filter is_defaultable_group (equivClasses cmp_tv unaries)
   where 
-    doc = text "tcSimplifyTop"
-
-tcSimplifyInteractive wanteds
-  = tc_simplify_top doc True wanteds
-  where 
-    doc = text "tcSimplifyInteractive"
-
--- The TcLclEnv should be valid here, solely to improve
--- error message generation for the monomorphism restriction
-tc_simplify_top :: SDoc -> Bool -> [Inst] -> TcM (Bag (LHsBind TcId))
-tc_simplify_top doc interactive wanteds
-  = do	{ dflags <- getDOpts
-	; wanteds <- zonkInsts wanteds
-	; mapM_ zonkTopTyVar (varSetElems (tyVarsOfInsts wanteds))
-
-	; traceTc (text "tc_simplify_top 0: " <+> ppr wanteds)
-	; (irreds1, binds1) <- tryHardCheckLoop doc1 wanteds
---	; (irreds1, binds1) <- gentleInferLoop doc1 wanteds
-	; traceTc (text "tc_simplify_top 1: " <+> ppr irreds1)
-	; (irreds2, binds2) <- approximateImplications doc2 (\_ -> True) irreds1
-	; traceTc (text "tc_simplify_top 2: " <+> ppr irreds2)
-
-		-- Use the defaulting rules to do extra unification
-		-- NB: irreds2 are already zonked
-	; (irreds3, binds3) <- disambiguate doc3 interactive dflags irreds2
-
-		-- Deal with implicit parameters
-	; let (bad_ips, non_ips) = partition isIPDict irreds3
-	      (ambigs, others)   = partition isTyVarDict non_ips
-
-	; topIPErrs bad_ips	-- Can arise from   f :: Int -> Int
-				--		    f x = x + ?y
-	; addNoInstanceErrs others
-	; addTopAmbigErrs ambigs	
-
-	; return (binds1 `unionBags` binds2 `unionBags` binds3) }
-  where
-    doc1 = doc <+> ptext (sLit "(first round)")
-    doc2 = doc <+> ptext (sLit "(approximate)")
-    doc3 = doc <+> ptext (sLit "(disambiguate)")
-\end{code}
-
-If a dictionary constrains a type variable which is
-	* not mentioned in the environment
-	* and not mentioned in the type of the expression
-then it is ambiguous. No further information will arise to instantiate
-the type variable; nor will it be generalised and turned into an extra
-parameter to a function.
-
-It is an error for this to occur, except that Haskell provided for
-certain rules to be applied in the special case of numeric types.
-Specifically, if
-	* at least one of its classes is a numeric class, and
-	* all of its classes are numeric or standard
-then the type variable can be defaulted to the first type in the
-default-type list which is an instance of all the offending classes.
-
-So here is the function which does the work.  It takes the ambiguous
-dictionaries and either resolves them (producing bindings) or
-complains.  It works by splitting the dictionary list by type
-variable, and using @disambigOne@ to do the real business.
-
-@disambigOne@ assumes that its arguments dictionaries constrain all
-the same type variable.
-
-ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
-@()@ instead of @Int@.  I reckon this is the Right Thing to do since
-the most common use of defaulting is code like:
-\begin{verbatim}
-	_ccall_ foo	`seqPrimIO` bar
-\end{verbatim}
-Since we're not using the result of @foo@, the result if (presumably)
-@void@.
-
-\begin{code}
-disambiguate :: SDoc -> Bool -> DynFlags -> [Inst] -> TcM ([Inst], TcDictBinds)
-	-- Just does unification to fix the default types
-	-- The Insts are assumed to be pre-zonked
-disambiguate doc interactive dflags insts
-  | null insts
-  = return (insts, emptyBag)
-
-  | null defaultable_groups
-  = do	{ traceTc (text "disambigutate, no defaultable groups" <+> vcat [ppr unaries, ppr insts, ppr bad_tvs, ppr defaultable_groups])
-	; return (insts, emptyBag) }
-
-  | otherwise
-  = do 	{  	-- Figure out what default types to use
-	  default_tys <- getDefaultTys extended_defaulting ovl_strings
-
-	; traceTc (text "disambiguate1" <+> vcat [ppr insts, ppr unaries, ppr bad_tvs, ppr defaultable_groups])
-	; mapM_ (disambigGroup default_tys) defaultable_groups
-
-	-- disambigGroup does unification, hence try again
-	; tryHardCheckLoop doc insts }
-
-  where
-   extended_defaulting = interactive || dopt Opt_ExtendedDefaultRules dflags
-   		       -- See also Trac #1974
-   ovl_strings = dopt Opt_OverloadedStrings dflags
-
-   unaries :: [(Inst, Class, TcTyVar)]  -- (C tv) constraints
-   bad_tvs :: TcTyVarSet  -- Tyvars mentioned by *other* constraints
-   (unaries, bad_tvs_s) = partitionWith find_unary insts 
-   bad_tvs 		= unionVarSets bad_tvs_s
-
-	-- Finds unary type-class constraints
-   find_unary d@(Dict {tci_pred = ClassP cls [ty]})
-	| Just tv <- tcGetTyVar_maybe ty = Left (d,cls,tv)
-   find_unary inst			 = Right (tyVarsOfInst inst)
-
-		-- Group by type variable
-   defaultable_groups :: [[(Inst,Class,TcTyVar)]]
-   defaultable_groups = filter defaultable_group (equivClasses cmp_tv unaries)
-   cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2
-
-   defaultable_group :: [(Inst,Class,TcTyVar)] -> Bool
-   defaultable_group ds@((_,_,tv):_)
-	=  isTyConableTyVar tv	-- Note [Avoiding spurious errors]
-	&& not (tv `elemVarSet` bad_tvs)
-	&& defaultable_classes [c | (_,c,_) <- ds]
-   defaultable_group [] = panic "defaultable_group"
-
-   defaultable_classes clss 
-	| extended_defaulting = any isInteractiveClass clss
-	| otherwise 	      = all is_std_class clss && (any is_num_class clss)
-
- 	-- In interactive mode, or with -XExtendedDefaultRules,
-	-- we default Show a to Show () to avoid graututious errors on "show []"
-   isInteractiveClass cls 
-	= is_num_class cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
-
-   is_num_class cls = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))
-	-- is_num_class adds IsString to the standard numeric classes, 
-	-- when -foverloaded-strings is enabled
-
-   is_std_class cls = isStandardClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))
-	-- Similarly is_std_class
-
------------------------
-disambigGroup :: [Type]			-- The default types
-	      -> [(Inst,Class,TcTyVar)]	-- All standard classes of form (C a)
-	      -> TcM ()	-- Just does unification, to fix the default types
-
-disambigGroup default_tys dicts
-  = do { mb_chosen_ty <- try_default default_tys
-       ; case mb_chosen_ty of
-            Nothing        -> return ()
-            Just chosen_ty -> do { _ <- unifyType chosen_ty (mkTyVarTy tyvar) 
-	    	 	         ; warnDefault dicts chosen_ty } }
-  where
-    (_,_,tyvar) = ASSERT(not (null dicts)) head dicts	-- Should be non-empty
-    classes = [c | (_,c,_) <- dicts]
-
-    try_default [] = return Nothing
-    try_default (default_ty : default_tys)
-      = tryTcLIE_ (try_default default_tys) $
-    	do { tcSimplifyDefault [mkClassPred clas [default_ty] | clas <- classes]
-		-- This may fail; then the tryTcLIE_ kicks in
-		-- Failure here is caused by there being no type in the
-		-- default list which can satisfy all the ambiguous classes.
-		-- For example, if Real a is reqd, but the only type in the
-		-- default list is Int.
-
-	   ; return (Just default_ty) -- TOMDO: do something with the coercion
-	   }
-
-
------------------------
-getDefaultTys :: Bool -> Bool -> TcM [Type]
-getDefaultTys extended_deflts ovl_strings
-  = do	{ mb_defaults <- getDeclaredDefaultTys
-	; case mb_defaults of {
-	   Just tys -> return tys ;	-- User-supplied defaults
-	   Nothing  -> do
-
-	-- No use-supplied default
-	-- Use [Integer, Double], plus modifications
-	{ integer_ty <- tcMetaTy integerTyConName
-	; checkWiredInTyCon doubleTyCon
-	; string_ty <- tcMetaTy stringTyConName
-	; return (opt_deflt extended_deflts unitTy
-			-- Note [Default unitTy]
-			++
-		  [integer_ty,doubleTy]
-			++
-		  opt_deflt ovl_strings string_ty) } } }
+    unaries     :: [(CanonicalCt, TcTyVar)]  -- (C tv) constraints
+    non_unaries :: [CanonicalCt]             -- *other* constraints
+    
+    (unaries, non_unaries) = partitionWith find_unary (bagToList wanteds)
+        -- Finds unary type-class constraints
+    find_unary cc@(CDictCan { cc_tyargs = [ty] })
+        | Just tv <- tcGetTyVar_maybe ty
+        = Left (cc, tv)
+    find_unary cc = Right cc  -- Non unary or non dictionary 
+
+    bad_tvs :: TcTyVarSet  -- TyVars mentioned by non-unaries 
+    bad_tvs = foldr (unionVarSet . tyVarsOfCanonical) emptyVarSet non_unaries 
+
+    cmp_tv (_,tv1) (_,tv2) = tv1 `compare` tv2
+
+    is_defaultable_group ds@((_,tv):_)
+        = isTyConableTyVar tv	-- Note [Avoiding spurious errors]
+        && not (tv `elemVarSet` bad_tvs)
+        && not (tv `elemVarSet` untch)    -- Non untouchable
+        && defaultable_classes [cc_class cc | (cc,_) <- ds]
+    is_defaultable_group [] = panic "defaultable_group"
+
+    defaultable_classes clss 
+        | extended_defaults = any isInteractiveClass clss
+        | otherwise         = all is_std_class clss && (any is_num_class clss)
+
+    -- In interactive mode, or with -XExtendedDefaultRules,
+    -- we default Show a to Show () to avoid graututious errors on "show []"
+    isInteractiveClass cls 
+        = is_num_class cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
+
+    is_num_class cls = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))
+    -- is_num_class adds IsString to the standard numeric classes, 
+    -- when -foverloaded-strings is enabled
+
+    is_std_class cls = isStandardClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))
+    -- Similarly is_std_class
+
+------------------------------
+disambigGroup :: [Type]                    -- The default types 
+	      -> TcTyVarSet		   -- Untouchables
+              -> InertSet                  -- Given inert 
+              -> [(CanonicalCt, TcTyVar)]  -- All classes of the form (C a)
+	      	 		           --  sharing same type variable
+              -> TcS CanonicalCts
+
+disambigGroup [] _inert _untch _grp 
+  = return emptyBag
+disambigGroup (default_ty:default_tys) untch inert group
+  = do { traceTcS "disambigGroup" (ppr group $$ ppr default_ty)
+       ; ev <- newGivOrDerCoVar (mkTyVarTy the_tv) default_ty default_ty -- Refl 
+		       	 -- We know this equality is canonical,
+			 -- so we directly construct it as such
+       ; let given_eq = CTyEqCan { cc_id     = ev
+                                 , cc_flavor = mkGivenFlavor (cc_flavor the_ct) UnkSkol
+                               	 , cc_tyvar  = the_tv
+           	                 , cc_rhs    = default_ty }
+
+       ; success <- tryTcS (extendVarSet untch the_tv) $ 
+           	    do { given_inert <- solveOne inert given_eq
+           	       ; final_inert <- solveInteract given_inert (listToBag wanteds)
+           	       ; let (_, unsolved) = extractUnsolved final_inert
+           	       ; return (isEmptyBag unsolved) }
+
+       ; case success of
+           True  ->   -- Success: record the type variable binding, and return
+                    do { setWantedTyBind the_tv default_ty
+		       ; wrapWarnTcS $ warnDefaulting wanted_ev_vars default_ty
+		       ; traceTcS "disambigGoup succeeded" (ppr default_ty)
+                       ; return (unitBag given_eq) }
+           False ->    -- Failure: try with the next type
+		    do { traceTcS "disambigGoup succeeded" (ppr default_ty)
+                       ; disambigGroup default_tys untch inert group } }
   where
-    opt_deflt True  ty = [ty]
-    opt_deflt False _  = []
+    ((the_ct,the_tv):_) = group
+    wanteds = map fst group
+    wanted_ev_vars = map deCanonicaliseWanted wanteds
 \end{code}
 
-Note [Default unitTy]
-~~~~~~~~~~~~~~~~~~~~~
-In interative mode (or with -XExtendedDefaultRules) we add () as the first type we
-try when defaulting.  This has very little real impact, except in the following case.
-Consider: 
-	Text.Printf.printf "hello"
-This has type (forall a. IO a); it prints "hello", and returns 'undefined'.  We don't
-want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to
-default the 'a' to (), rather than to Integer (which is what would otherwise happen;
-and then GHCi doesn't attempt to print the ().  So in interactive mode, we add
-() to the list of defaulting types.  See Trac #1200.
-
 Note [Avoiding spurious errors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When doing the unification for defaulting, we check for skolem
@@ -2982,335 +908,3 @@ we try to unify a with Int (to default it), but find that it's
 already been unified with the rigid variable from g's type sig
 
 
-%************************************************************************
-%*									*
-\subsection[simple]{@Simple@ versions}
-%*									*
-%************************************************************************
-
-Much simpler versions when there are no bindings to make!
-
-@tcSimplifyThetas@ simplifies class-type constraints formed by
-@deriving@ declarations and when specialising instances.  We are
-only interested in the simplified bunch of class/type constraints.
-
-It simplifies to constraints of the form (C a b c) where
-a,b,c are type variables.  This is required for the context of
-instance declarations.
-
-\begin{code}
-tcSimplifyDeriv :: InstOrigin
-		-> [TyVar]	
-		-> ThetaType		-- Wanted
-	        -> TcM ThetaType	-- Needed
--- Given  instance (wanted) => C inst_ty 
--- Simplify 'wanted' as much as possible
-
-tcSimplifyDeriv orig tyvars theta
-  = do	{ (tvs, _, tenv) <- tcInstTyVars tyvars
-	-- The main loop may do unification, and that may crash if 
-	-- it doesn't see a TcTyVar, so we have to instantiate. Sigh
-	-- ToDo: what if two of them do get unified?
-	; wanteds <- newDictBndrsO orig (substTheta tenv theta)
-	; (irreds, _) <- tryHardCheckLoop doc wanteds
-
-	; let (tv_dicts, others) = partition ok irreds
-	      (tidy_env, tidy_insts) = tidyInsts others
-        ; reportNoInstances tidy_env Nothing [alt_fix] tidy_insts
-	-- See Note [Exotic derived instance contexts] in TcMType
-
-	; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
-	      simpl_theta = substTheta rev_env (map dictPred tv_dicts)
-		-- This reverse-mapping is a pain, but the result
-		-- should mention the original TyVars not TcTyVars
-
-	; return simpl_theta }
-  where
-    doc = ptext (sLit "deriving classes for a data type")
-
-    ok dict | isDict dict = validDerivPred (dictPred dict)
-	    | otherwise	  = False
-    alt_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration instead,"),
-                    ptext (sLit "so you can specify the instance context yourself")]
-\end{code}
-
-
-@tcSimplifyDefault@ just checks class-type constraints, essentially;
-used with \tr{default} declarations.  We are only interested in
-whether it worked or not.
-
-\begin{code}
-tcSimplifyDefault :: ThetaType	-- Wanted; has no type variables in it
-		  -> TcM ()
-
-tcSimplifyDefault theta = do
-    wanteds <- newDictBndrsO DefaultOrigin theta
-    (irreds, _) <- tryHardCheckLoop doc wanteds
-    addNoInstanceErrs irreds
-    if null irreds then
-	return ()
-     else
-	traceTc (ptext (sLit "tcSimplifyDefault failing")) >> failM
-  where
-    doc = ptext (sLit "default declaration")
-\end{code}
-
-
-
-%************************************************************************
-%*									*
-\section{Errors and contexts}
-%*									*
-%************************************************************************
-
-ToDo: for these error messages, should we note the location as coming
-from the insts, or just whatever seems to be around in the monad just
-now?
-
-\begin{code}
-groupErrs :: ([Inst] -> TcM ())	-- Deal with one group
-	  -> [Inst]		-- The offending Insts
-          -> TcM ()
--- Group together insts with the same origin
--- We want to report them together in error messages
-
-groupErrs _ [] 
-  = return ()
-groupErrs report_err (inst:insts)
-  = do	{ do_one (inst:friends)
-	; groupErrs report_err others }
-  where
-	-- (It may seem a bit crude to compare the error messages,
-	--  but it makes sure that we combine just what the user sees,
-	--  and it avoids need equality on InstLocs.)
-   (friends, others) = partition is_friend insts
-   loc_msg	     = showSDoc (pprInstLoc (instLoc inst))
-   is_friend friend  = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
-   do_one insts = setInstCtxt (instLoc (head insts)) (report_err insts)
-		-- Add location and context information derived from the Insts
-
--- Add the "arising from..." part to a message about bunch of dicts
-addInstLoc :: [Inst] -> Message -> Message
-addInstLoc insts msg = msg $$ nest 2 (pprInstArising (head insts))
-
-addTopIPErrs :: [Name] -> [Inst] -> TcM ()
-addTopIPErrs _ [] 
-  = return ()
-addTopIPErrs bndrs ips
-  = do	{ dflags <- getDOpts
-	; addErrTcM (tidy_env, mk_msg dflags tidy_ips) }
-  where
-    (tidy_env, tidy_ips) = tidyInsts ips
-    mk_msg dflags ips 
-	= vcat [sep [ptext (sLit "Implicit parameters escape from"),
-	        nest 2 (ptext (sLit "the monomorphic top-level binding") 
-					    <> plural bndrs <+> ptext (sLit "of")
-					    <+> pprBinders bndrs <> colon)],
-		nest 2 (vcat (map ppr_ip ips)),
-		monomorphism_fix dflags]
-    ppr_ip ip = pprPred (dictPred ip) <+> pprInstArising ip
-
-topIPErrs :: [Inst] -> TcM ()
-topIPErrs dicts
-  = groupErrs report tidy_dicts
-  where
-    (tidy_env, tidy_dicts) = tidyInsts dicts
-    report dicts = addErrTcM (tidy_env, mk_msg dicts)
-    mk_msg dicts = addInstLoc dicts (ptext (sLit "Unbound implicit parameter") <> 
-				     plural tidy_dicts <+> pprDictsTheta tidy_dicts)
-
-addNoInstanceErrs :: [Inst]	-- Wanted (can include implications)
-		  -> TcM ()	
-addNoInstanceErrs insts
-  = do	{ let (tidy_env, tidy_insts) = tidyInsts insts
-	; reportNoInstances tidy_env Nothing [] tidy_insts }
-
-reportNoInstances 
-	:: TidyEnv
-	-> Maybe (InstLoc, [Inst])	-- Context
-			-- Nothing => top level
-			-- Just (d,g) => d describes the construct
-			--		 with givens g
-        -> [SDoc]	-- Alternative fix for no-such-instance
-	-> [Inst]	-- What is wanted (can include implications)
-	-> TcM ()	
-
-reportNoInstances tidy_env mb_what alt_fix insts 
-  = groupErrs (report_no_instances tidy_env mb_what alt_fix) insts
-
-report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [SDoc] -> [Inst] -> TcM ()
-report_no_instances tidy_env mb_what alt_fixes insts
-  = do { inst_envs <- tcGetInstEnvs
-       ; let (implics, insts1)  = partition isImplicInst insts
-	     (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1
-             (eqInsts, insts3)  = partition isEqInst insts2
-       ; traceTc (text "reportNoInstances" <+> vcat 
-                       [ppr insts, ppr implics, ppr insts1, ppr insts2])
-       ; mapM_ complain_implic implics
-       ; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps
-       ; groupErrs complain_no_inst insts3 
-       ; mapM_ (addErrTcM . mk_eq_err) eqInsts
-       }
-  where
-    complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts)
-
-    complain_implic inst	-- Recurse!
-      = reportNoInstances tidy_env 
-			  (Just (tci_loc inst, tci_given inst)) 
-			  alt_fixes (tci_wanted inst)
-
-    check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc
-	-- Right msg  => overlap message
-	-- Left  inst => no instance
-    check_overlap inst_envs wanted
-	| not (isClassDict wanted) = Left wanted
-	| otherwise
-	= case lookupInstEnv inst_envs clas tys of
-		([], _) -> Left wanted		-- No match
-		-- The case of exactly one match and no unifiers means a
-		-- successful lookup.  That can't happen here, because dicts
-		-- only end up here if they didn't match in Inst.lookupInst
-		([_],[])
-		 | debugIsOn -> pprPanic "reportNoInstance" (ppr wanted)
-		res -> Right (mk_overlap_msg wanted res)
-	  where
-	    (clas,tys) = getDictClassTys wanted
-
-    mk_overlap_msg dict (matches, unifiers)
-      = ASSERT( not (null matches) )
-        vcat [	addInstLoc [dict] ((ptext (sLit "Overlapping instances for") 
-					<+> pprPred (dictPred dict))),
-    		sep [ptext (sLit "Matching instances") <> colon,
-    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])],
-		if not (isSingleton matches)
-    		then 	-- Two or more matches
-		     empty
-    		else 	-- One match, plus some unifiers
-		ASSERT( not (null unifiers) )
-		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
-	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))),
-			      ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
-			      ptext (sLit "when compiling the other instance declarations")])]
-      where
-    	ispecs = [ispec | (ispec, _) <- matches]
-
-    mk_eq_err :: Inst -> (TidyEnv, SDoc)
-    mk_eq_err inst = misMatchMsg tidy_env (eqInstTys inst)
-
-    mk_no_inst_err insts
-      | null insts = empty
-
-      | Just (loc, givens) <- mb_what,   -- Nested (type signatures, instance decls)
-	not (isEmptyVarSet (tyVarsOfInsts insts))
-      = vcat [ addInstLoc insts $
-	       sep [ ptext (sLit "Could not deduce") <+> pprDictsTheta insts
-	           , nest 2 $ ptext (sLit "from the context") <+> pprDictsTheta givens]
-	     , show_fixes (fix1 loc : fixes2 ++ alt_fixes) ]
-
-      | otherwise	-- Top level 
-      = vcat [ addInstLoc insts $
-	       ptext (sLit "No instance") <> plural insts
-		    <+> ptext (sLit "for") <+> pprDictsTheta insts
-	     , show_fixes (fixes2 ++ alt_fixes) ]
-
-      where
-    	fix1 loc = sep [ ptext (sLit "add") <+> pprDictsTheta insts
-				 <+> ptext (sLit "to the context of"),
-			 nest 2 (ppr (instLocOrigin loc)) ]
-			 -- I'm not sure it helps to add the location
-			 -- nest 2 (ptext (sLit "at") <+> ppr (instLocSpan loc)) ]
-
-    	fixes2 | null instance_dicts = []
-	       | otherwise	     = [sep [ptext (sLit "add an instance declaration for"),
-				        pprDictsTheta instance_dicts]]
-	instance_dicts = [d | d <- insts, isClassDict d, not (isTyVarDict d)]
-		-- Insts for which it is worth suggesting an adding an instance declaration
-		-- Exclude implicit parameters, and tyvar dicts
-
-	show_fixes :: [SDoc] -> SDoc
-	show_fixes []     = empty
-	show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), 
-				 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
-
-addTopAmbigErrs :: [Inst] -> TcRn ()
-addTopAmbigErrs dicts
--- Divide into groups that share a common set of ambiguous tyvars
-  = ifErrsM (return ()) $	-- Only report ambiguity if no other errors happened
-				-- See Note [Avoiding spurious errors]
-    mapM_ report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts])
-  where
-    (tidy_env, tidy_dicts) = tidyInsts dicts
-
-    tvs_of :: Inst -> [TcTyVar]
-    tvs_of d = varSetElems (tyVarsOfInst d)
-    cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
-    
-    report :: [(Inst,[TcTyVar])] -> TcM ()
-    report pairs@((inst,tvs) : _) = do	-- The pairs share a common set of ambiguous tyvars
-	  (tidy_env, mono_msg) <- mkMonomorphismMsg tidy_env tvs
-	  setSrcSpan (instSpan inst) $
-		-- the location of the first one will do for the err message
-	   addErrTcM (tidy_env, msg $$ mono_msg)
-	where
-	  dicts = map fst pairs
-	  msg = sep [text "Ambiguous type variable" <> plural tvs <+> 
-			  pprQuotedList tvs <+> in_msg,
-		     nest 2 (pprDictsInFull dicts)]
-	  in_msg = text "in the constraint" <> plural dicts <> colon
-    report [] = panic "addTopAmbigErrs"
-
-
-mkMonomorphismMsg :: TidyEnv -> [TcTyVar] -> TcM (TidyEnv, Message)
--- There's an error with these Insts; if they have free type variables
--- it's probably caused by the monomorphism restriction. 
--- Try to identify the offending variable
--- ASSUMPTION: the Insts are fully zonked
-mkMonomorphismMsg tidy_env inst_tvs
-  = do	{ dflags <- getDOpts
-	; (tidy_env, docs) <- findGlobals (mkVarSet inst_tvs) tidy_env
-	; return (tidy_env, mk_msg dflags docs) }
-  where
-    mk_msg _ _ | any isRuntimeUnk inst_tvs
-        =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
-                   (pprWithCommas ppr inst_tvs),
-                ptext (sLit "Use :print or :force to determine these types")]
-    mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
-			-- This happens in things like
-			--	f x = show (read "foo")
-			-- where monomorphism doesn't play any role
-    mk_msg dflags docs 
-	= vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
-		nest 2 (vcat docs),
-		monomorphism_fix dflags]
-
-monomorphism_fix :: DynFlags -> SDoc
-monomorphism_fix dflags
-  = ptext (sLit "Probable fix:") <+> vcat
-	[ptext (sLit "give these definition(s) an explicit type signature"),
-	 if dopt Opt_MonomorphismRestriction dflags
-           then ptext (sLit "or use -XNoMonomorphismRestriction")
-           else empty]	-- Only suggest adding "-XNoMonomorphismRestriction"
-			-- if it is not already set!
-    
-warnDefault :: [(Inst, Class, Var)] -> Type -> TcM ()
-warnDefault ups default_ty = do
-    warn_flag <- doptM Opt_WarnTypeDefaults
-    setInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
-  where
-    dicts = [d | (d,_,_) <- ups]
-
-	-- Tidy them first
-    (_, tidy_dicts) = tidyInsts dicts
-    warn_msg  = vcat [ptext (sLit "Defaulting the following constraint(s) to type") <+>
-				quotes (ppr default_ty),
-		      pprDictsInFull tidy_dicts]
-
-reduceDepthErr :: Int -> [Inst] -> SDoc
-reduceDepthErr n stack
-  = vcat [ptext (sLit "Context reduction stack overflow; size =") <+> int n,
-	  ptext (sLit "Use -fcontext-stack=N to increase stack size to N"),
-	  nest 4 (pprStack stack)]
-
-pprStack :: [Inst] -> SDoc
-pprStack stack = vcat (map pprInstInFull stack)
-\end{code}
diff --git a/compiler/typecheck/TcSimplify.lhs-old b/compiler/typecheck/TcSimplify.lhs-old
new file mode 100644
index 0000000..c9b5736
--- /dev/null
+++ b/compiler/typecheck/TcSimplify.lhs-old
@@ -0,0 +1,3297 @@
+%
+% (c) The University of Glasgow 2006
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+
+TcSimplify
+
+\begin{code}
+module TcSimplify (
+	tcSimplifyInfer, tcSimplifyInferCheck,
+	tcSimplifyCheck, tcSimplifyRestricted,
+	tcSimplifyRuleLhs, tcSimplifyIPs, 
+	tcSimplifySuperClasses,
+	tcSimplifyTop, tcSimplifyInteractive,
+	tcSimplifyBracket, tcSimplifyCheckPat,
+
+	tcSimplifyDeriv, tcSimplifyDefault,
+	bindInstsOfLocalFuns, 
+	
+        misMatchMsg
+    ) where
+
+#include "HsVersions.h"
+
+import {-# SOURCE #-} TcUnify( unifyType )
+import HsSyn
+
+import TcRnMonad
+import TcHsSyn	( hsLPatType )
+import Inst
+import TcEnv
+import InstEnv
+import TcType
+import TcMType
+import TcIface
+import TcTyFuns
+import DsUtils	-- Big-tuple functions
+import Var
+import Id
+import Name
+import NameSet
+import Class
+import FunDeps
+import PrelInfo
+import PrelNames
+import TysWiredIn
+import ErrUtils
+import BasicTypes
+import VarSet
+import VarEnv
+import FiniteMap
+import Bag
+import Outputable
+import ListSetOps
+import Util
+import SrcLoc
+import DynFlags
+import FastString
+
+import Control.Monad
+import Data.List
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{NOTES}
+%*									*
+%************************************************************************
+
+	--------------------------------------
+	Notes on functional dependencies (a bug)
+	--------------------------------------
+
+Consider this:
+
+	class C a b | a -> b
+	class D a b | a -> b
+
+	instance D a b => C a b	-- Undecidable 
+				-- (Not sure if it's crucial to this eg)
+	f :: C a b => a -> Bool
+	f _ = True
+	
+	g :: C a b => a -> Bool
+	g = f
+
+Here f typechecks, but g does not!!  Reason: before doing improvement,
+we reduce the (C a b1) constraint from the call of f to (D a b1).
+
+Here is a more complicated example:
+
+@
+  > class Foo a b | a->b
+  >
+  > class Bar a b | a->b
+  >
+  > data Obj = Obj
+  >
+  > instance Bar Obj Obj
+  >
+  > instance (Bar a b) => Foo a b
+  >
+  > foo:: (Foo a b) => a -> String
+  > foo _ = "works"
+  >
+  > runFoo:: (forall a b. (Foo a b) => a -> w) -> w
+  > runFoo f = f Obj
+
+  *Test> runFoo foo
+
+  <interactive>:1:
+      Could not deduce (Bar a b) from the context (Foo a b)
+        arising from use of `foo' at <interactive>:1
+      Probable fix:
+          Add (Bar a b) to the expected type of an expression
+      In the first argument of `runFoo', namely `foo'
+      In the definition of `it': it = runFoo foo
+
+  Why all of the sudden does GHC need the constraint Bar a b? The
+  function foo didn't ask for that...
+@
+
+The trouble is that to type (runFoo foo), GHC has to solve the problem:
+
+	Given constraint	Foo a b
+	Solve constraint	Foo a b'
+
+Notice that b and b' aren't the same.  To solve this, just do
+improvement and then they are the same.  But GHC currently does
+	simplify constraints
+	apply improvement
+	and loop
+
+That is usually fine, but it isn't here, because it sees that Foo a b is
+not the same as Foo a b', and so instead applies the instance decl for
+instance Bar a b => Foo a b.  And that's where the Bar constraint comes
+from.
+
+The Right Thing is to improve whenever the constraint set changes at
+all.  Not hard in principle, but it'll take a bit of fiddling to do.  
+
+Note [Choosing which variables to quantify]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are about to do a generalisation step.  We have in our hand
+
+	G	the environment
+	T	the type of the RHS
+	C	the constraints from that RHS
+
+The game is to figure out
+
+	Q	the set of type variables over which to quantify
+	Ct	the constraints we will *not* quantify over
+	Cq	the constraints we will quantify over
+
+So we're going to infer the type
+
+	forall Q. Cq => T
+
+and float the constraints Ct further outwards.
+
+Here are the things that *must* be true:
+
+ (A)	Q intersect fv(G) = EMPTY			limits how big Q can be
+ (B)	Q superset fv(Cq union T) \ oclose(fv(G),C)	limits how small Q can be
+
+ (A) says we can't quantify over a variable that's free in the environment. 
+ (B) says we must quantify over all the truly free variables in T, else 
+     we won't get a sufficiently general type.  
+
+We do not *need* to quantify over any variable that is fixed by the
+free vars of the environment G.
+
+	BETWEEN THESE TWO BOUNDS, ANY Q WILL DO!
+
+Example:	class H x y | x->y where ...
+
+	fv(G) = {a}	C = {H a b, H c d}
+			T = c -> b
+
+	(A)  Q intersect {a} is empty
+	(B)  Q superset {a,b,c,d} \ oclose({a}, C) = {a,b,c,d} \ {a,b} = {c,d}
+
+	So Q can be {c,d}, {b,c,d}
+
+In particular, it's perfectly OK to quantify over more type variables
+than strictly necessary; there is no need to quantify over 'b', since
+it is determined by 'a' which is free in the envt, but it's perfectly
+OK to do so.  However we must not quantify over 'a' itself.
+
+Other things being equal, however, we'd like to quantify over as few
+variables as possible: smaller types, fewer type applications, more
+constraints can get into Ct instead of Cq.  Here's a good way to
+choose Q:
+
+	Q = grow( fv(T), C ) \ oclose( fv(G), C )
+
+That is, quantify over all variable that that MIGHT be fixed by the
+call site (which influences T), but which aren't DEFINITELY fixed by
+G.  This choice definitely quantifies over enough type variables,
+albeit perhaps too many.
+
+Why grow( fv(T), C ) rather than fv(T)?  Consider
+
+	class H x y | x->y where ...
+
+	T = c->c
+	C = (H c d)
+
+  If we used fv(T) = {c} we'd get the type
+
+	forall c. H c d => c -> b
+
+  And then if the fn was called at several different c's, each of
+  which fixed d differently, we'd get a unification error, because
+  d isn't quantified.  Solution: quantify d.  So we must quantify
+  everything that might be influenced by c.
+
+Why not oclose( fv(T), C )?  Because we might not be able to see
+all the functional dependencies yet:
+
+	class H x y | x->y where ...
+	instance H x y => Eq (T x y) where ...
+
+	T = c->c
+	C = (Eq (T c d))
+
+Now oclose(fv(T),C) = {c}, because the functional dependency isn't
+apparent yet, and that's wrong.  We must really quantify over d too.
+
+There really isn't any point in quantifying over any more than
+grow( fv(T), C ), because the call sites can't possibly influence
+any other type variables.
+
+
+
+-------------------------------------
+	Note [Ambiguity]
+-------------------------------------
+
+It's very hard to be certain when a type is ambiguous.  Consider
+
+	class K x
+	class H x y | x -> y
+	instance H x y => K (x,y)
+
+Is this type ambiguous?
+	forall a b. (K (a,b), Eq b) => a -> a
+
+Looks like it!  But if we simplify (K (a,b)) we get (H a b) and
+now we see that a fixes b.  So we can't tell about ambiguity for sure
+without doing a full simplification.  And even that isn't possible if
+the context has some free vars that may get unified.  Urgle!
+
+Here's another example: is this ambiguous?
+	forall a b. Eq (T b) => a -> a
+Not if there's an insance decl (with no context)
+	instance Eq (T b) where ...
+
+You may say of this example that we should use the instance decl right
+away, but you can't always do that:
+
+	class J a b where ...
+	instance J Int b where ...
+
+	f :: forall a b. J a b => a -> a
+
+(Notice: no functional dependency in J's class decl.)
+Here f's type is perfectly fine, provided f is only called at Int.
+It's premature to complain when meeting f's signature, or even
+when inferring a type for f.
+
+
+
+However, we don't *need* to report ambiguity right away.  It'll always
+show up at the call site.... and eventually at main, which needs special
+treatment.  Nevertheless, reporting ambiguity promptly is an excellent thing.
+
+So here's the plan.  We WARN about probable ambiguity if
+
+	fv(Cq) is not a subset of  oclose(fv(T) union fv(G), C)
+
+(all tested before quantification).
+That is, all the type variables in Cq must be fixed by the the variables
+in the environment, or by the variables in the type.
+
+Notice that we union before calling oclose.  Here's an example:
+
+	class J a b c | a b -> c
+	fv(G) = {a}
+
+Is this ambiguous?
+	forall b c. (J a b c) => b -> b
+
+Only if we union {a} from G with {b} from T before using oclose,
+do we see that c is fixed.
+
+It's a bit vague exactly which C we should use for this oclose call.  If we
+don't fix enough variables we might complain when we shouldn't (see
+the above nasty example).  Nothing will be perfect.  That's why we can
+only issue a warning.
+
+
+Can we ever be *certain* about ambiguity?  Yes: if there's a constraint
+
+	c in C such that fv(c) intersect (fv(G) union fv(T)) = EMPTY
+
+then c is a "bubble"; there's no way it can ever improve, and it's
+certainly ambiguous.  UNLESS it is a constant (sigh).  And what about
+the nasty example?
+
+	class K x
+	class H x y | x -> y
+	instance H x y => K (x,y)
+
+Is this type ambiguous?
+	forall a b. (K (a,b), Eq b) => a -> a
+
+Urk.  The (Eq b) looks "definitely ambiguous" but it isn't.  What we are after
+is a "bubble" that's a set of constraints
+
+	Cq = Ca union Cq'  st  fv(Ca) intersect (fv(Cq') union fv(T) union fv(G)) = EMPTY
+
+Hence another idea.  To decide Q start with fv(T) and grow it
+by transitive closure in Cq (no functional dependencies involved).
+Now partition Cq using Q, leaving the definitely-ambiguous and probably-ok.
+The definitely-ambiguous can then float out, and get smashed at top level
+(which squashes out the constants, like Eq (T a) above)
+
+
+	--------------------------------------
+		Notes on principal types
+	--------------------------------------
+
+    class C a where
+      op :: a -> a
+
+    f x = let g y = op (y::Int) in True
+
+Here the principal type of f is (forall a. a->a)
+but we'll produce the non-principal type
+    f :: forall a. C Int => a -> a
+
+
+	--------------------------------------
+	The need for forall's in constraints
+	--------------------------------------
+
+[Exchange on Haskell Cafe 5/6 Dec 2000]
+
+  class C t where op :: t -> Bool
+  instance C [t] where op x = True
+
+  p y = (let f :: c -> Bool; f x = op (y >> return x) in f, y ++ [])
+  q y = (y ++ [], let f :: c -> Bool; f x = op (y >> return x) in f)
+
+The definitions of p and q differ only in the order of the components in
+the pair on their right-hand sides.  And yet:
+
+  ghc and "Typing Haskell in Haskell" reject p, but accept q;
+  Hugs rejects q, but accepts p;
+  hbc rejects both p and q;
+  nhc98 ... (Malcolm, can you fill in the blank for us!).
+
+The type signature for f forces context reduction to take place, and
+the results of this depend on whether or not the type of y is known,
+which in turn depends on which component of the pair the type checker
+analyzes first.  
+
+Solution: if y::m a, float out the constraints
+	Monad m, forall c. C (m c)
+When m is later unified with [], we can solve both constraints.
+
+
+	--------------------------------------
+		Notes on implicit parameters
+	--------------------------------------
+
+Note [Inheriting implicit parameters]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+
+	f x = (x::Int) + ?y
+
+where f is *not* a top-level binding.
+From the RHS of f we'll get the constraint (?y::Int).
+There are two types we might infer for f:
+
+	f :: Int -> Int
+
+(so we get ?y from the context of f's definition), or
+
+	f :: (?y::Int) => Int -> Int
+
+At first you might think the first was better, becuase then
+?y behaves like a free variable of the definition, rather than
+having to be passed at each call site.  But of course, the WHOLE
+IDEA is that ?y should be passed at each call site (that's what
+dynamic binding means) so we'd better infer the second.
+
+BOTTOM LINE: when *inferring types* you *must* quantify 
+over implicit parameters. See the predicate isFreeWhenInferring.
+
+
+Note [Implicit parameters and ambiguity] 
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Only a *class* predicate can give rise to ambiguity
+An *implicit parameter* cannot.  For example:
+	foo :: (?x :: [a]) => Int
+	foo = length ?x
+is fine.  The call site will suppply a particular 'x'
+
+Furthermore, the type variables fixed by an implicit parameter
+propagate to the others.  E.g.
+	foo :: (Show a, ?x::[a]) => Int
+	foo = show (?x++?x)
+The type of foo looks ambiguous.  But it isn't, because at a call site
+we might have
+	let ?x = 5::Int in foo
+and all is well.  In effect, implicit parameters are, well, parameters,
+so we can take their type variables into account as part of the
+"tau-tvs" stuff.  This is done in the function 'FunDeps.grow'.
+
+
+Question 2: type signatures
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+BUT WATCH OUT: When you supply a type signature, we can't force you
+to quantify over implicit parameters.  For example:
+
+	(?x + 1) :: Int
+
+This is perfectly reasonable.  We do not want to insist on
+
+	(?x + 1) :: (?x::Int => Int)
+
+That would be silly.  Here, the definition site *is* the occurrence site,
+so the above strictures don't apply.  Hence the difference between
+tcSimplifyCheck (which *does* allow implicit paramters to be inherited)
+and tcSimplifyCheckBind (which does not).
+
+What about when you supply a type signature for a binding?
+Is it legal to give the following explicit, user type 
+signature to f, thus:
+
+	f :: Int -> Int
+	f x = (x::Int) + ?y
+
+At first sight this seems reasonable, but it has the nasty property
+that adding a type signature changes the dynamic semantics.
+Consider this:
+
+	(let f x = (x::Int) + ?y
+ 	 in (f 3, f 3 with ?y=5))  with ?y = 6
+
+		returns (3+6, 3+5)
+vs
+	(let f :: Int -> Int
+	     f x = x + ?y
+	 in (f 3, f 3 with ?y=5))  with ?y = 6
+
+		returns (3+6, 3+6)
+
+Indeed, simply inlining f (at the Haskell source level) would change the
+dynamic semantics.
+
+Nevertheless, as Launchbury says (email Oct 01) we can't really give the
+semantics for a Haskell program without knowing its typing, so if you 
+change the typing you may change the semantics.
+
+To make things consistent in all cases where we are *checking* against
+a supplied signature (as opposed to inferring a type), we adopt the
+rule: 
+
+	a signature does not need to quantify over implicit params.
+
+[This represents a (rather marginal) change of policy since GHC 5.02,
+which *required* an explicit signature to quantify over all implicit
+params for the reasons mentioned above.]
+
+But that raises a new question.  Consider 
+
+	Given (signature)	?x::Int
+	Wanted (inferred)	?x::Int, ?y::Bool
+
+Clearly we want to discharge the ?x and float the ?y out.  But
+what is the criterion that distinguishes them?  Clearly it isn't
+what free type variables they have.  The Right Thing seems to be
+to float a constraint that
+	neither mentions any of the quantified type variables
+	nor any of the quantified implicit parameters
+
+See the predicate isFreeWhenChecking.
+
+
+Question 3: monomorphism
+~~~~~~~~~~~~~~~~~~~~~~~~
+There's a nasty corner case when the monomorphism restriction bites:
+
+	z = (x::Int) + ?y
+
+The argument above suggests that we *must* generalise
+over the ?y parameter, to get
+	z :: (?y::Int) => Int,
+but the monomorphism restriction says that we *must not*, giving
+	z :: Int.
+Why does the momomorphism restriction say this?  Because if you have
+
+	let z = x + ?y in z+z
+
+you might not expect the addition to be done twice --- but it will if
+we follow the argument of Question 2 and generalise over ?y.
+
+
+Question 4: top level
+~~~~~~~~~~~~~~~~~~~~~
+At the top level, monomorhism makes no sense at all.
+
+    module Main where
+	main = let ?x = 5 in print foo
+
+	foo = woggle 3
+
+	woggle :: (?x :: Int) => Int -> Int
+	woggle y = ?x + y
+
+We definitely don't want (foo :: Int) with a top-level implicit parameter
+(?x::Int) becuase there is no way to bind it.  
+
+
+Possible choices
+~~~~~~~~~~~~~~~~
+(A) Always generalise over implicit parameters
+    Bindings that fall under the monomorphism restriction can't
+	be generalised
+
+    Consequences:
+	* Inlining remains valid
+	* No unexpected loss of sharing
+	* But simple bindings like
+		z = ?y + 1
+	  will be rejected, unless you add an explicit type signature
+	  (to avoid the monomorphism restriction)
+		z :: (?y::Int) => Int
+		z = ?y + 1
+	  This seems unacceptable
+
+(B) Monomorphism restriction "wins"
+    Bindings that fall under the monomorphism restriction can't
+	be generalised
+    Always generalise over implicit parameters *except* for bindings
+	that fall under the monomorphism restriction
+
+    Consequences
+	* Inlining isn't valid in general
+	* No unexpected loss of sharing
+	* Simple bindings like
+		z = ?y + 1
+	  accepted (get value of ?y from binding site)
+
+(C) Always generalise over implicit parameters
+    Bindings that fall under the monomorphism restriction can't
+	be generalised, EXCEPT for implicit parameters
+    Consequences
+	* Inlining remains valid
+	* Unexpected loss of sharing (from the extra generalisation)
+	* Simple bindings like
+		z = ?y + 1
+	  accepted (get value of ?y from occurrence sites)
+
+
+Discussion
+~~~~~~~~~~
+None of these choices seems very satisfactory.  But at least we should
+decide which we want to do.
+
+It's really not clear what is the Right Thing To Do.  If you see
+
+	z = (x::Int) + ?y
+
+would you expect the value of ?y to be got from the *occurrence sites*
+of 'z', or from the valuue of ?y at the *definition* of 'z'?  In the
+case of function definitions, the answer is clearly the former, but
+less so in the case of non-fucntion definitions.   On the other hand,
+if we say that we get the value of ?y from the definition site of 'z',
+then inlining 'z' might change the semantics of the program.
+
+Choice (C) really says "the monomorphism restriction doesn't apply
+to implicit parameters".  Which is fine, but remember that every
+innocent binding 'x = ...' that mentions an implicit parameter in
+the RHS becomes a *function* of that parameter, called at each
+use of 'x'.  Now, the chances are that there are no intervening 'with'
+clauses that bind ?y, so a decent compiler should common up all
+those function calls.  So I think I strongly favour (C).  Indeed,
+one could make a similar argument for abolishing the monomorphism
+restriction altogether.
+
+BOTTOM LINE: we choose (B) at present.  See tcSimplifyRestricted
+
+
+
+%************************************************************************
+%*									*
+\subsection{tcSimplifyInfer}
+%*									*
+%************************************************************************
+
+tcSimplify is called when we *inferring* a type.  Here's the overall game plan:
+
+    1. Compute Q = grow( fvs(T), C )
+
+    2. Partition C based on Q into Ct and Cq.  Notice that ambiguous
+       predicates will end up in Ct; we deal with them at the top level
+
+    3. Try improvement, using functional dependencies
+
+    4. If Step 3 did any unification, repeat from step 1
+       (Unification can change the result of 'grow'.)
+
+Note: we don't reduce dictionaries in step 2.  For example, if we have
+Eq (a,b), we don't simplify to (Eq a, Eq b).  So Q won't be different
+after step 2.  However note that we may therefore quantify over more
+type variables than we absolutely have to.
+
+For the guts, we need a loop, that alternates context reduction and
+improvement with unification.  E.g. Suppose we have
+
+	class C x y | x->y where ...
+
+and tcSimplify is called with:
+	(C Int a, C Int b)
+Then improvement unifies a with b, giving
+	(C Int a, C Int a)
+
+If we need to unify anything, we rattle round the whole thing all over
+again.
+
+
+\begin{code}
+tcSimplifyInfer
+	:: SDoc
+	-> TcTyVarSet		-- fv(T); type vars
+	-> [Inst]		-- Wanted
+	-> TcM ([TcTyVar],	-- Tyvars to quantify (zonked and quantified)
+		[Inst],		-- Dict Ids that must be bound here (zonked)
+		TcDictBinds)	-- Bindings
+	-- Any free (escaping) Insts are tossed into the environment
+\end{code}
+
+
+\begin{code}
+tcSimplifyInfer doc tau_tvs wanted
+  = do	{ tau_tvs1 <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
+	; wanted'  <- mapM zonkInst wanted	-- Zonk before deciding quantified tyvars
+	; gbl_tvs  <- tcGetGlobalTyVars
+	; let preds1   = fdPredsOfInsts wanted'
+	      gbl_tvs1 = oclose preds1 gbl_tvs
+	      qtvs     = growInstsTyVars wanted' tau_tvs1 `minusVarSet` gbl_tvs1
+			-- See Note [Choosing which variables to quantify]
+
+		-- To maximise sharing, remove from consideration any 
+		-- constraints that don't mention qtvs at all
+	; let (free, bound) = partition (isFreeWhenInferring qtvs) wanted'
+	; extendLIEs free
+
+		-- To make types simple, reduce as much as possible
+	; traceTc (text "infer" <+> (ppr preds1 $$ ppr (growInstsTyVars wanted' tau_tvs1) $$ ppr gbl_tvs $$ 
+		   ppr gbl_tvs1 $$ ppr free $$ ppr bound))
+	; (irreds1, binds1) <- tryHardCheckLoop doc bound
+
+		-- Note [Inference and implication constraints]
+	; let want_dict d = tyVarsOfInst d `intersectsVarSet` qtvs
+	; (irreds2, binds2) <- approximateImplications doc want_dict irreds1
+
+		-- Now work out all over again which type variables to quantify,
+		-- exactly in the same way as before, but starting from irreds2.  Why?
+		-- a) By now improvment may have taken place, and we must *not*
+		--    quantify over any variable free in the environment
+		--    tc137 (function h inside g) is an example
+		--
+		-- b) Do not quantify over constraints that *now* do not
+		--    mention quantified type variables, because they are
+		--    simply ambiguous (or might be bound further out).  Example:
+		--    	f :: Eq b => a -> (a, b)
+		--    	g x = fst (f x)
+		--    From the RHS of g we get the MethodInst f77 :: alpha -> (alpha, beta)
+		--    We decide to quantify over 'alpha' alone, but free1 does not include f77
+		--    because f77 mentions 'alpha'.  Then reducing leaves only the (ambiguous)
+		--    constraint (Eq beta), which we dump back into the free set
+		--    See test tcfail181
+		--
+		-- c) irreds may contain type variables not previously mentioned,
+		--    e.g.  instance D a x => Foo [a] 
+		--	    wanteds = Foo [a]
+		--       Then after simplifying we'll get (D a x), and x is fresh
+		-- 	 We must quantify over x else it'll be totally unbound
+	; tau_tvs2 <- zonkTcTyVarsAndFV (varSetElems tau_tvs1)
+	; gbl_tvs2 <- zonkTcTyVarsAndFV (varSetElems gbl_tvs1)
+		-- Note that we start from gbl_tvs1
+		-- We use tcGetGlobalTyVars, then oclose wrt preds2, because
+		-- we've already put some of the original preds1 into frees
+		-- E.g. 	wanteds = C a b	  (where a->b)
+		--		gbl_tvs = {a}
+		--		tau_tvs = {b}
+		-- Then b is fixed by gbl_tvs, so (C a b) will be in free, and
+		-- irreds2 will be empty.  But we don't want to generalise over b!
+	; let preds2 = fdPredsOfInsts irreds2	-- irreds2 is zonked
+	      qtvs   = growInstsTyVars irreds2 tau_tvs2 `minusVarSet` oclose preds2 gbl_tvs2
+		---------------------------------------------------
+		-- BUG WARNING: there's a nasty bug lurking here
+		-- fdPredsOfInsts may return preds that mention variables quantified in
+		-- one of the implication constraints in irreds2; and that is clearly wrong:
+		-- we might quantify over too many variables through accidental capture
+		---------------------------------------------------
+	; let (free, irreds3) = partition (isFreeWhenInferring qtvs) irreds2
+	; extendLIEs free
+
+		-- Turn the quantified meta-type variables into real type variables
+	; qtvs2 <- zonkQuantifiedTyVars (varSetElems qtvs)
+
+		-- We can't abstract over any remaining unsolved 
+		-- implications so instead just float them outwards. Ugh.
+	; let (q_dicts0, implics) = partition isAbstractableInst irreds3
+	; loc <- getInstLoc (ImplicOrigin doc)
+	; implic_bind <- bindIrreds loc qtvs2 q_dicts0 implics
+
+		-- Prepare equality instances for quantification
+	; let (q_eqs0,q_dicts) = partition isEqInst q_dicts0
+	; q_eqs <- mapM finalizeEqInst q_eqs0
+
+	; return (qtvs2, q_eqs ++ q_dicts, binds1 `unionBags` binds2 `unionBags` implic_bind) }
+	-- NB: when we are done, we might have some bindings, but
+	-- the final qtvs might be empty.  See Note [NO TYVARS] below.
+
+approximateImplications :: SDoc -> (Inst -> Bool) -> [Inst] -> TcM ([Inst], TcDictBinds)
+-- Note [Inference and implication constraints]
+-- Given a bunch of Dict and ImplicInsts, try to approximate the implications by
+--	- fetching any dicts inside them that are free
+--	- using those dicts as cruder constraints, to solve the implications
+--	- returning the extra ones too
+
+approximateImplications doc want_dict irreds
+  | null extra_dicts 
+  = return (irreds, emptyBag)
+  | otherwise
+  = do	{ extra_dicts' <- mapM cloneDict extra_dicts
+	; tryHardCheckLoop doc (extra_dicts' ++ irreds) }
+		-- By adding extra_dicts', we make them 
+		-- available to solve the implication constraints
+  where 
+    extra_dicts = get_dicts (filter isImplicInst irreds)
+
+    get_dicts :: [Inst] -> [Inst]	-- Returns only Dicts
+	-- Find the wanted constraints in implication constraints that satisfy
+	-- want_dict, and are not bound by forall's in the constraint itself
+    get_dicts ds = concatMap get_dict ds
+
+    get_dict d@(Dict {}) | want_dict d = [d]
+		         | otherwise   = []
+    get_dict (ImplicInst {tci_tyvars = tvs, tci_wanted = wanteds})
+	= [ d | let tv_set = mkVarSet tvs
+	      , d <- get_dicts wanteds 
+	      , not (tyVarsOfInst d `intersectsVarSet` tv_set)]
+    get_dict i@(EqInst {}) | want_dict i = [i]
+			   | otherwise   = [] 
+    get_dict other = pprPanic "approximateImplications" (ppr other)
+\end{code}
+
+Note [Inference and implication constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
+Suppose we have a wanted implication constraint (perhaps arising from
+a nested pattern match) like
+	C a => D [a]
+and we are now trying to quantify over 'a' when inferring the type for
+a function.  In principle it's possible that there might be an instance
+	instance (C a, E a) => D [a]
+so the context (E a) would suffice.  The Right Thing is to abstract over
+the implication constraint, but we don't do that (a) because it'll be
+surprising to programmers and (b) because we don't have the machinery to deal
+with 'given' implications.
+
+So our best approximation is to make (D [a]) part of the inferred
+context, so we can use that to discharge the implication. Hence
+the strange function get_dicts in approximateImplications.
+
+The common cases are more clear-cut, when we have things like
+	forall a. C a => C b
+Here, abstracting over (C b) is not an approximation at all -- but see
+Note [Freeness and implications].
+ 
+See Trac #1430 and test tc228.
+
+
+\begin{code}
+-----------------------------------------------------------
+-- tcSimplifyInferCheck is used when we know the constraints we are to simplify
+-- against, but we don't know the type variables over which we are going to quantify.
+-- This happens when we have a type signature for a mutually recursive group
+tcSimplifyInferCheck
+	 :: InstLoc
+	 -> TcTyVarSet		-- fv(T)
+	 -> [Inst]		-- Given
+	 -> [Inst]		-- Wanted
+	 -> TcM ([TyVar],	-- Fully zonked, and quantified
+		 TcDictBinds)	-- Bindings
+
+tcSimplifyInferCheck loc tau_tvs givens wanteds
+  = do	{ traceTc (text "tcSimplifyInferCheck <-" <+> ppr wanteds)
+	; (irreds, binds) <- gentleCheckLoop loc givens wanteds
+
+	-- Figure out which type variables to quantify over
+	-- You might think it should just be the signature tyvars,
+	-- but in bizarre cases you can get extra ones
+	-- 	f :: forall a. Num a => a -> a
+	--	f x = fst (g (x, head [])) + 1
+	--	g a b = (b,a)
+	-- Here we infer g :: forall a b. a -> b -> (b,a)
+	-- We don't want g to be monomorphic in b just because
+	-- f isn't quantified over b.
+	; let all_tvs = varSetElems (tau_tvs `unionVarSet` tyVarsOfInsts givens)
+	; all_tvs <- zonkTcTyVarsAndFV all_tvs
+	; gbl_tvs <- tcGetGlobalTyVars
+	; let qtvs = varSetElems (all_tvs `minusVarSet` gbl_tvs)
+		-- We could close gbl_tvs, but its not necessary for
+		-- soundness, and it'll only affect which tyvars, not which
+		-- dictionaries, we quantify over
+
+	; qtvs' <- zonkQuantifiedTyVars qtvs
+
+		-- Now we are back to normal (c.f. tcSimplCheck)
+	; implic_bind <- bindIrreds loc qtvs' givens irreds
+
+	; traceTc (text "tcSimplifyInferCheck ->" <+> ppr (implic_bind))
+	; return (qtvs', binds `unionBags` implic_bind) }
+\end{code}
+
+Note [Squashing methods]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Be careful if you want to float methods more:
+	truncate :: forall a. RealFrac a => forall b. Integral b => a -> b
+From an application (truncate f i) we get
+	t1 = truncate at f
+	t2 = t1 at i
+If we have also have a second occurrence of truncate, we get
+	t3 = truncate at f
+	t4 = t3 at i
+When simplifying with i,f free, we might still notice that
+t1=t3; but alas, the binding for t2 (which mentions t1)
+may continue to float out!
+
+
+Note [NO TYVARS]
+~~~~~~~~~~~~~~~~~
+	class Y a b | a -> b where
+	    y :: a -> X b
+	
+	instance Y [[a]] a where
+	    y ((x:_):_) = X x
+	
+	k :: X a -> X a -> X a
+
+	g :: Num a => [X a] -> [X a]
+	g xs = h xs
+	    where
+	    h ys = ys ++ map (k (y [[0]])) xs
+
+The excitement comes when simplifying the bindings for h.  Initially
+try to simplify {y @ [[t1]] t2, 0 @ t1}, with initial qtvs = {t2}.
+From this we get t1~t2, but also various bindings.  We can't forget
+the bindings (because of [LOOP]), but in fact t1 is what g is
+polymorphic in.  
+
+The net effect of [NO TYVARS] 
+
+\begin{code}
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{tcSimplifyCheck}
+%*									*
+%************************************************************************
+
+@tcSimplifyCheck@ is used when we know exactly the set of variables
+we are going to quantify over.  For example, a class or instance declaration.
+
+\begin{code}
+-----------------------------------------------------------
+-- tcSimplifyCheck is used when checking expression type signatures,
+-- class decls, instance decls etc.
+tcSimplifyCheck	:: InstLoc
+	 	-> [TcTyVar]		-- Quantify over these
+	 	-> [Inst]		-- Given
+	 	-> [Inst]		-- Wanted
+	 	-> TcM TcDictBinds	-- Bindings
+tcSimplifyCheck loc qtvs givens wanteds 
+  = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs )
+    do	{ traceTc (text "tcSimplifyCheck")
+      	; (irreds, binds) <- gentleCheckLoop loc givens wanteds
+	; implic_bind <- bindIrreds loc qtvs givens irreds
+	; return (binds `unionBags` implic_bind) }
+
+-----------------------------------------------------------
+-- tcSimplifyCheckPat is used for existential pattern match
+tcSimplifyCheckPat :: InstLoc
+	 	   -> [TcTyVar]		-- Quantify over these
+	 	   -> [Inst]		-- Given
+	 	   -> [Inst]		-- Wanted
+	 	   -> TcM TcDictBinds	-- Bindings
+tcSimplifyCheckPat loc qtvs givens wanteds
+  = ASSERT( all isTcTyVar qtvs && all isSkolemTyVar qtvs )
+    do	{ traceTc (text "tcSimplifyCheckPat")
+      	; (irreds, binds) <- gentleCheckLoop loc givens wanteds
+	; implic_bind <- bindIrredsR loc qtvs givens irreds
+	; return (binds `unionBags` implic_bind) }
+
+-----------------------------------------------------------
+bindIrreds :: InstLoc -> [TcTyVar]
+	   -> [Inst] -> [Inst]
+	   -> TcM TcDictBinds
+bindIrreds loc qtvs givens irreds 
+  = bindIrredsR loc qtvs givens irreds
+
+bindIrredsR :: InstLoc -> [TcTyVar] -> [Inst] -> [Inst] -> TcM TcDictBinds	
+-- Make a binding that binds 'irreds', by generating an implication
+-- constraint for them, *and* throwing the constraint into the LIE
+bindIrredsR loc qtvs givens irreds
+  | null irreds
+  = return emptyBag
+  | otherwise
+  = do	{ let givens' = filter isAbstractableInst givens
+		-- The givens can (redundantly) include methods
+		-- We want to retain both EqInsts and Dicts
+		-- There should be no implicadtion constraints
+		-- See Note [Pruning the givens in an implication constraint]
+
+	   -- If there are no 'givens', then it's safe to 
+	   -- partition the 'wanteds' by their qtvs, thereby trimming irreds
+	   -- See Note [Freeness and implications]
+	; irreds' <- if null givens'
+	     	     then do
+	     	    	{ let qtv_set = mkVarSet qtvs
+	     	    	      (frees, real_irreds) = partition (isFreeWrtTyVars qtv_set) irreds
+	     	    	; extendLIEs frees
+	     	    	; return real_irreds }
+	     	     else return irreds
+	
+	; (implics, bind) <- makeImplicationBind loc qtvs givens' irreds'
+			-- This call does the real work
+			-- If irreds' is empty, it does something sensible
+	; extendLIEs implics
+	; return bind } 
+
+
+makeImplicationBind :: InstLoc -> [TcTyVar]
+		    -> [Inst] -> [Inst]
+		    -> TcM ([Inst], TcDictBinds)
+-- Make a binding that binds 'irreds', by generating an implication
+-- constraint for them.
+--
+-- The binding looks like
+--	(ir1, .., irn) = f qtvs givens
+-- where f is (evidence for) the new implication constraint
+--	f :: forall qtvs. givens => (ir1, .., irn)
+-- qtvs includes coercion variables
+--
+-- This binding must line up the 'rhs' in reduceImplication
+makeImplicationBind loc all_tvs
+		    givens 	-- Guaranteed all Dicts or EqInsts
+		    irreds
+ | null irreds			-- If there are no irreds, we are done
+ = return ([], emptyBag)
+ | otherwise			-- Otherwise we must generate a binding
+ = do	{ uniq <- newUnique 
+	; span <- getSrcSpanM
+	; let (eq_givens, dict_givens) = partition isEqInst givens
+
+                -- extract equality binders
+              eq_cotvs = map eqInstType eq_givens
+
+                -- make the implication constraint instance
+	      name = mkInternalName uniq (mkVarOcc "ic") span
+	      implic_inst = ImplicInst { tci_name = name,
+					 tci_tyvars = all_tvs, 
+					 tci_given = eq_givens ++ dict_givens,
+                                                       -- same order as binders
+					 tci_wanted = irreds, 
+                                         tci_loc = loc }
+
+	        -- create binders for the irreducible dictionaries
+	      dict_irreds    = filter (not . isEqInst) irreds
+	      dict_irred_ids = map instToId dict_irreds
+	      lpat = mkBigLHsPatTup (map (L span . VarPat) dict_irred_ids)
+
+                -- create the binding
+	      rhs  = L span (mkHsWrap co (HsVar (instToId implic_inst)))
+	      co   =     mkWpApps (map instToId dict_givens)
+		     <.> mkWpTyApps eq_cotvs
+		     <.> mkWpTyApps (mkTyVarTys all_tvs)
+	      bind | [dict_irred_id] <- dict_irred_ids  
+                   = mkVarBind dict_irred_id rhs
+		   | otherwise        
+                   = L span $ 
+                     PatBind { pat_lhs = lpat
+			     , pat_rhs = unguardedGRHSs rhs 
+			     , pat_rhs_ty = hsLPatType lpat
+			     , bind_fvs = placeHolderNames 
+                             }
+
+	; traceTc $ text "makeImplicationBind" <+> ppr implic_inst
+	; return ([implic_inst], unitBag bind) 
+        }
+
+-----------------------------------------------------------
+tryHardCheckLoop :: SDoc
+	     -> [Inst]			-- Wanted
+	     -> TcM ([Inst], TcDictBinds)
+
+tryHardCheckLoop doc wanteds
+  = do { (irreds,binds) <- checkLoop (mkInferRedEnv doc try_me) wanteds
+       ; return (irreds,binds)
+       }
+  where
+    try_me _ = ReduceMe
+	-- Here's the try-hard bit
+
+-----------------------------------------------------------
+gentleCheckLoop :: InstLoc
+	       -> [Inst]		-- Given
+	       -> [Inst]		-- Wanted
+	       -> TcM ([Inst], TcDictBinds)
+
+gentleCheckLoop inst_loc givens wanteds
+  = do { (irreds,binds) <- checkLoop env wanteds
+       ; return (irreds,binds)
+       }
+  where
+    env = mkRedEnv (pprInstLoc inst_loc) try_me givens
+
+    try_me inst | isMethodOrLit inst = ReduceMe
+		| otherwise	     = Stop
+	-- When checking against a given signature 
+	-- we MUST be very gentle: Note [Check gently]
+
+gentleInferLoop :: SDoc -> [Inst]
+	        -> TcM ([Inst], TcDictBinds)
+gentleInferLoop doc wanteds
+  = do 	{ (irreds, binds) <- checkLoop env wanteds
+	; return (irreds, binds) }
+  where
+    env = mkInferRedEnv doc try_me
+    try_me inst | isMethodOrLit inst = ReduceMe
+		| otherwise	     = Stop
+\end{code}
+
+Note [Check gently]
+~~~~~~~~~~~~~~~~~~~~
+We have to very careful about not simplifying too vigorously
+Example:  
+  data T a where
+    MkT :: a -> T [a]
+
+  f :: Show b => T b -> b
+  f (MkT x) = show [x]
+
+Inside the pattern match, which binds (a:*, x:a), we know that
+	b ~ [a]
+Hence we have a dictionary for Show [a] available; and indeed we 
+need it.  We are going to build an implication contraint
+	forall a. (b~[a]) => Show [a]
+Later, we will solve this constraint using the knowledge (Show b)
+	
+But we MUST NOT reduce (Show [a]) to (Show a), else the whole
+thing becomes insoluble.  So we simplify gently (get rid of literals
+and methods only, plus common up equal things), deferring the real
+work until top level, when we solve the implication constraint
+with tryHardCheckLooop.
+
+
+\begin{code}
+-----------------------------------------------------------
+checkLoop :: RedEnv
+	  -> [Inst]			-- Wanted
+	  -> TcM ([Inst], TcDictBinds) 
+-- Precondition: givens are completely rigid
+-- Postcondition: returned Insts are zonked
+
+checkLoop env wanteds
+  = go env wanteds
+  where go env wanteds
+	  = do  {  -- We do need to zonk the givens; cf Note [Zonking RedEnv]
+                ; env'     <- zonkRedEnv env
+		; wanteds' <- zonkInsts  wanteds
+	
+		; (improved, tybinds, binds, irreds) 
+                    <- reduceContext env' wanteds'
+                ; execTcTyVarBinds tybinds
+
+		; if null irreds || not improved then
+	 	    return (irreds, binds)
+		  else do
+	
+		-- If improvement did some unification, we go round again.
+		-- We start again with irreds, not wanteds
+		-- Using an instance decl might have introduced a fresh type
+		-- variable which might have been unified, so we'd get an 
+                -- infinite loop if we started again with wanteds!  
+                -- See Note [LOOP]
+		{ (irreds1, binds1) <- go env' irreds
+		; return (irreds1, binds `unionBags` binds1) } }
+\end{code}
+
+Note [Zonking RedEnv]
+~~~~~~~~~~~~~~~~~~~~~
+It might appear as if the givens in RedEnv are always rigid, but that is not
+necessarily the case for programs involving higher-rank types that have class
+contexts constraining the higher-rank variables.  An example from tc237 in the
+testsuite is
+
+  class Modular s a | s -> a
+
+  wim ::  forall a w. Integral a 
+                        => a -> (forall s. Modular s a => M s w) -> w
+  wim i k = error "urk"
+
+  test5  ::  (Modular s a, Integral a) => M s a
+  test5  =   error "urk"
+
+  test4   =   wim 4 test4'
+
+Notice how the variable 'a' of (Modular s a) in the rank-2 type of wim is
+quantified further outside.  When type checking test4, we have to check
+whether the signature of test5 is an instance of 
+
+  (forall s. Modular s a => M s w)
+
+Consequently, we will get (Modular s t_a), where t_a is a TauTv into the
+givens. 
+
+Given the FD of Modular in this example, class improvement will instantiate
+t_a to 'a', where 'a' is the skolem from test5's signatures (due to the
+Modular s a predicate in that signature).  If we don't zonk (Modular s t_a) in
+the givens, we will get into a loop as improveOne uses the unification engine
+Unify.tcUnifyTys, which doesn't know about mutable type variables.
+
+
+Note [LOOP]
+~~~~~~~~~~~
+	class If b t e r | b t e -> r
+	instance If T t e t
+	instance If F t e e
+	class Lte a b c | a b -> c where lte :: a -> b -> c
+	instance Lte Z b T
+	instance (Lte a b l,If l b a c) => Max a b c
+
+Wanted:	Max Z (S x) y
+
+Then we'll reduce using the Max instance to:
+	(Lte Z (S x) l, If l (S x) Z y)
+and improve by binding l->T, after which we can do some reduction
+on both the Lte and If constraints.  What we *can't* do is start again
+with (Max Z (S x) y)!
+
+
+
+%************************************************************************
+%*									*
+		tcSimplifySuperClasses
+%*									*
+%************************************************************************
+
+Note [SUPERCLASS-LOOP 1]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We have to be very, very careful when generating superclasses, lest we
+accidentally build a loop. Here's an example:
+
+  class S a
+
+  class S a => C a where { opc :: a -> a }
+  class S b => D b where { opd :: b -> b }
+  
+  instance C Int where
+     opc = opd
+  
+  instance D Int where
+     opd = opc
+
+From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int}
+Simplifying, we may well get:
+	$dfCInt = :C ds1 (opd dd)
+	dd  = $dfDInt
+	ds1 = $p1 dd
+Notice that we spot that we can extract ds1 from dd.  
+
+Alas!  Alack! We can do the same for (instance D Int):
+
+	$dfDInt = :D ds2 (opc dc)
+	dc  = $dfCInt
+	ds2 = $p1 dc
+
+And now we've defined the superclass in terms of itself.
+Two more nasty cases are in
+	tcrun021
+	tcrun033
+
+Solution: 
+  - Satisfy the superclass context *all by itself* 
+    (tcSimplifySuperClasses)
+  - And do so completely; i.e. no left-over constraints
+    to mix with the constraints arising from method declarations
+
+
+Note [Recursive instances and superclases]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this code, which arises in the context of "Scrap Your 
+Boilerplate with Class".  
+
+    class Sat a
+    class Data ctx a
+    instance  Sat (ctx Char)             => Data ctx Char
+    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]
+
+    class Data Maybe a => Foo a
+
+    instance Foo t => Sat (Maybe t)
+
+    instance Data Maybe a => Foo a
+    instance Foo a        => Foo [a]
+    instance                 Foo [Char]
+
+In the instance for Foo [a], when generating evidence for the superclasses
+(ie in tcSimplifySuperClasses) we need a superclass (Data Maybe [a]).
+Using the instance for Data, we therefore need
+        (Sat (Maybe [a], Data Maybe a)
+But we are given (Foo a), and hence its superclass (Data Maybe a).
+So that leaves (Sat (Maybe [a])).  Using the instance for Sat means
+we need (Foo [a]).  And that is the very dictionary we are bulding
+an instance for!  So we must put that in the "givens".  So in this
+case we have
+	Given:  Foo a, Foo [a]
+	Watend: Data Maybe [a]
+
+BUT we must *not not not* put the *superclasses* of (Foo [a]) in
+the givens, which is what 'addGiven' would normally do. Why? Because
+(Data Maybe [a]) is the superclass, so we'd "satisfy" the wanted 
+by selecting a superclass from Foo [a], which simply makes a loop.
+
+On the other hand we *must* put the superclasses of (Foo a) in
+the givens, as you can see from the derivation described above.
+
+Conclusion: in the very special case of tcSimplifySuperClasses
+we have one 'given' (namely the "this" dictionary) whose superclasses
+must not be added to 'givens' by addGiven.  
+
+There is a complication though.  Suppose there are equalities
+      instance (Eq a, a~b) => Num (a,b)
+Then we normalise the 'givens' wrt the equalities, so the original
+given "this" dictionary is cast to one of a different type.  So it's a
+bit trickier than before to identify the "special" dictionary whose
+superclasses must not be added. See test
+   indexed-types/should_run/EqInInstance
+
+We need a persistent property of the dictionary to record this
+special-ness.  Current I'm using the InstLocOrigin (a bit of a hack,
+but cool), which is maintained by dictionary normalisation.
+Specifically, the InstLocOrigin is
+	     NoScOrigin
+then the no-superclass thing kicks in.  WATCH OUT if you fiddle
+with InstLocOrigin!
+
+\begin{code}
+tcSimplifySuperClasses
+	:: InstLoc 
+	-> Inst		-- The dict whose superclasses 
+			-- are being figured out
+	-> [Inst]	-- Given 
+	-> [Inst]	-- Wanted
+	-> TcM TcDictBinds
+tcSimplifySuperClasses loc this givens sc_wanteds
+  = do	{ traceTc (text "tcSimplifySuperClasses")
+
+	      -- Note [Recursive instances and superclases]
+        ; no_sc_loc <- getInstLoc NoScOrigin
+	; let no_sc_this = setInstLoc this no_sc_loc
+
+	; let env =  RedEnv { red_doc = pprInstLoc loc, 
+	     		      red_try_me = try_me,
+	     	     	      red_givens = no_sc_this : givens, 
+	     	     	      red_stack = (0,[]),
+	     	     	      red_improve = False }  -- No unification vars
+
+
+	; (irreds,binds1) <- checkLoop env sc_wanteds
+	; let (tidy_env, tidy_irreds) = tidyInsts irreds
+	; reportNoInstances tidy_env (Just (loc, givens)) [] tidy_irreds
+	; return binds1 }
+  where
+    try_me _ = ReduceMe  -- Try hard, so we completely solve the superclass 
+    	       		 -- constraints right here. See Note [SUPERCLASS-LOOP 1]
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{tcSimplifyRestricted}
+%*									*
+%************************************************************************
+
+tcSimplifyRestricted infers which type variables to quantify for a 
+group of restricted bindings.  This isn't trivial.
+
+Eg1:	id = \x -> x
+	We want to quantify over a to get id :: forall a. a->a
+	
+Eg2:	eq = (==)
+	We do not want to quantify over a, because there's an Eq a 
+	constraint, so we get eq :: a->a->Bool	(notice no forall)
+
+So, assume:
+	RHS has type 'tau', whose free tyvars are tau_tvs
+	RHS has constraints 'wanteds'
+
+Plan A (simple)
+  Quantify over (tau_tvs \ ftvs(wanteds))
+  This is bad. The constraints may contain (Monad (ST s))
+  where we have 	instance Monad (ST s) where...
+  so there's no need to be monomorphic in s!
+
+  Also the constraint might be a method constraint,
+  whose type mentions a perfectly innocent tyvar:
+	  op :: Num a => a -> b -> a
+  Here, b is unconstrained.  A good example would be
+	foo = op (3::Int)
+  We want to infer the polymorphic type
+	foo :: forall b. b -> b
+
+
+Plan B (cunning, used for a long time up to and including GHC 6.2)
+  Step 1: Simplify the constraints as much as possible (to deal 
+  with Plan A's problem).  Then set
+	qtvs = tau_tvs \ ftvs( simplify( wanteds ) )
+
+  Step 2: Now simplify again, treating the constraint as 'free' if 
+  it does not mention qtvs, and trying to reduce it otherwise.
+  The reasons for this is to maximise sharing.
+
+  This fails for a very subtle reason.  Suppose that in the Step 2
+  a constraint (Foo (Succ Zero) (Succ Zero) b) gets thrown upstairs as 'free'.
+  In the Step 1 this constraint might have been simplified, perhaps to
+  (Foo Zero Zero b), AND THEN THAT MIGHT BE IMPROVED, to bind 'b' to 'T'.
+  This won't happen in Step 2... but that in turn might prevent some other
+  constraint (Baz [a] b) being simplified (e.g. via instance Baz [a] T where {..}) 
+  and that in turn breaks the invariant that no constraints are quantified over.
+
+  Test typecheck/should_compile/tc177 (which failed in GHC 6.2) demonstrates
+  the problem.
+
+
+Plan C (brutal)
+  Step 1: Simplify the constraints as much as possible (to deal 
+  with Plan A's problem).  Then set
+	qtvs = tau_tvs \ ftvs( simplify( wanteds ) )
+  Return the bindings from Step 1.
+  
+
+A note about Plan C (arising from "bug" reported by George Russel March 2004)
+Consider this:
+
+      instance (HasBinary ty IO) => HasCodedValue ty
+
+      foo :: HasCodedValue a => String -> IO a
+
+      doDecodeIO :: HasCodedValue a => () -> () -> IO a
+      doDecodeIO codedValue view  
+        = let { act = foo "foo" } in  act
+
+You might think this should work becuase the call to foo gives rise to a constraint
+(HasCodedValue t), which can be satisfied by the type sig for doDecodeIO.  But the
+restricted binding act = ... calls tcSimplifyRestricted, and PlanC simplifies the
+constraint using the (rather bogus) instance declaration, and now we are stuffed.
+
+I claim this is not really a bug -- but it bit Sergey as well as George.  So here's
+plan D
+
+
+Plan D (a variant of plan B)
+  Step 1: Simplify the constraints as much as possible (to deal 
+  with Plan A's problem), BUT DO NO IMPROVEMENT.  Then set
+	qtvs = tau_tvs \ ftvs( simplify( wanteds ) )
+
+  Step 2: Now simplify again, treating the constraint as 'free' if 
+  it does not mention qtvs, and trying to reduce it otherwise.
+
+  The point here is that it's generally OK to have too few qtvs; that is,
+  to make the thing more monomorphic than it could be.  We don't want to
+  do that in the common cases, but in wierd cases it's ok: the programmer
+  can always add a signature.  
+
+  Too few qtvs => too many wanteds, which is what happens if you do less
+  improvement.
+
+
+\begin{code}
+tcSimplifyRestricted 	-- Used for restricted binding groups
+			-- i.e. ones subject to the monomorphism restriction
+	:: SDoc
+	-> TopLevelFlag
+	-> [Name]		-- Things bound in this group
+	-> TcTyVarSet		-- Free in the type of the RHSs
+	-> [Inst]		-- Free in the RHSs
+	-> TcM ([TyVar],	-- Tyvars to quantify (zonked and quantified)
+		TcDictBinds)	-- Bindings
+	-- tcSimpifyRestricted returns no constraints to
+	-- quantify over; by definition there are none.
+	-- They are all thrown back in the LIE
+
+tcSimplifyRestricted doc top_lvl bndrs tau_tvs wanteds
+	-- Zonk everything in sight
+  = do	{ traceTc (text "tcSimplifyRestricted")
+	; wanteds_z <- zonkInsts wanteds
+
+   	-- 'ReduceMe': Reduce as far as we can.  Don't stop at
+	-- dicts; the idea is to get rid of as many type
+	-- variables as possible, and we don't want to stop
+	-- at (say) Monad (ST s), because that reduces
+	-- immediately, with no constraint on s.
+	--
+	-- BUT do no improvement!  See Plan D above
+	-- HOWEVER, some unification may take place, if we instantiate
+	-- 	    a method Inst with an equality constraint
+	; let env = mkNoImproveRedEnv doc (\_ -> ReduceMe)
+	; (_imp, _tybinds, _binds, constrained_dicts) 
+            <- reduceContext env wanteds_z
+
+	-- Next, figure out the tyvars we will quantify over
+	; tau_tvs' <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
+	; gbl_tvs' <- tcGetGlobalTyVars
+	; constrained_dicts' <- zonkInsts constrained_dicts
+
+	; let qtvs1 = tau_tvs' `minusVarSet` oclose (fdPredsOfInsts constrained_dicts) gbl_tvs'
+				-- As in tcSimplifyInfer
+
+		-- Do not quantify over constrained type variables:
+		-- this is the monomorphism restriction
+	      constrained_tvs' = tyVarsOfInsts constrained_dicts'
+	      qtvs = qtvs1 `minusVarSet` constrained_tvs'
+	      pp_bndrs = pprWithCommas (quotes . ppr) bndrs
+
+	-- Warn in the mono
+	; warn_mono <- doptM Opt_WarnMonomorphism
+	; warnTc (warn_mono && (constrained_tvs' `intersectsVarSet` qtvs1))
+		 (vcat[ ptext (sLit "the Monomorphism Restriction applies to the binding")
+				<> plural bndrs <+> ptext (sLit "for") <+> pp_bndrs,
+			ptext (sLit "Consider giving a type signature for") <+> pp_bndrs])
+
+	; traceTc (text "tcSimplifyRestricted" <+> vcat [
+		pprInsts wanteds, pprInsts constrained_dicts',
+		ppr _binds,
+		ppr constrained_tvs', ppr tau_tvs', ppr qtvs ])
+
+	-- The first step may have squashed more methods than
+	-- necessary, so try again, this time more gently, knowing the exact
+	-- set of type variables to quantify over.
+	--
+	-- We quantify only over constraints that are captured by qtvs;
+	-- these will just be a subset of non-dicts.  This in contrast
+	-- to normal inference (using isFreeWhenInferring) in which we quantify over
+	-- all *non-inheritable* constraints too.  This implements choice
+	-- (B) under "implicit parameter and monomorphism" above.
+	--
+	-- Remember that we may need to do *some* simplification, to
+	-- (for example) squash {Monad (ST s)} into {}.  It's not enough
+	-- just to float all constraints
+	--
+	-- At top level, we *do* squash methods because we want to 
+	-- expose implicit parameters to the test that follows
+	; let is_nested_group = isNotTopLevel top_lvl
+	      try_me inst | isFreeWrtTyVars qtvs inst,
+			   (is_nested_group || isDict inst) = Stop
+		          | otherwise  	                    = ReduceMe 
+	      env = mkNoImproveRedEnv doc try_me
+	; (_imp, tybinds, binds, irreds) <- reduceContext env wanteds_z
+        ; execTcTyVarBinds tybinds
+
+	-- See "Notes on implicit parameters, Question 4: top level"
+	; ASSERT( all (isFreeWrtTyVars qtvs) irreds )	-- None should be captured
+	  if is_nested_group then
+		extendLIEs irreds
+	  else do { let (bad_ips, non_ips) = partition isIPDict irreds
+		  ; addTopIPErrs bndrs bad_ips
+		  ; extendLIEs non_ips }
+
+	; qtvs' <- zonkQuantifiedTyVars (varSetElems qtvs)
+	; return (qtvs', binds) }
+\end{code}
+
+
+%************************************************************************
+%*									*
+		tcSimplifyRuleLhs
+%*									*
+%************************************************************************
+
+On the LHS of transformation rules we only simplify methods and constants,
+getting dictionaries.  We want to keep all of them unsimplified, to serve
+as the available stuff for the RHS of the rule.
+
+Example.  Consider the following left-hand side of a rule
+	
+	f (x == y) (y > z) = ...
+
+If we typecheck this expression we get constraints
+
+	d1 :: Ord a, d2 :: Eq a
+
+We do NOT want to "simplify" to the LHS
+
+	forall x::a, y::a, z::a, d1::Ord a.
+	  f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ...
+
+Instead we want	
+
+	forall x::a, y::a, z::a, d1::Ord a, d2::Eq a.
+	  f ((==) d2 x y) ((>) d1 y z) = ...
+
+Here is another example:
+
+	fromIntegral :: (Integral a, Num b) => a -> b
+	{-# RULES "foo"  fromIntegral = id :: Int -> Int #-}
+
+In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But
+we *dont* want to get
+
+	forall dIntegralInt.
+	   fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int
+
+because the scsel will mess up RULE matching.  Instead we want
+
+	forall dIntegralInt, dNumInt.
+	  fromIntegral Int Int dIntegralInt dNumInt = id Int
+
+Even if we have 
+
+	g (x == y) (y == z) = ..
+
+where the two dictionaries are *identical*, we do NOT WANT
+
+	forall x::a, y::a, z::a, d1::Eq a
+	  f ((==) d1 x y) ((>) d1 y z) = ...
+
+because that will only match if the dict args are (visibly) equal.
+Instead we want to quantify over the dictionaries separately.
+
+In short, tcSimplifyRuleLhs must *only* squash LitInst and MethInts, leaving
+all dicts unchanged, with absolutely no sharing.  It's simpler to do this
+from scratch, rather than further parameterise simpleReduceLoop etc.
+Simpler, maybe, but alas not simple (see Trac #2494)
+
+* Type errors may give rise to an (unsatisfiable) equality constraint
+
+* Applications of a higher-rank function on the LHS may give
+  rise to an implication constraint, esp if there are unsatisfiable
+  equality constraints inside.
+
+\begin{code}
+tcSimplifyRuleLhs :: [Inst] -> TcM ([Inst], TcDictBinds)
+tcSimplifyRuleLhs wanteds
+  = do	{ wanteds' <- zonkInsts wanteds
+    	
+		-- Simplify equalities  
+		-- It's important to do this: Trac #3346 for example
+        ; (_, wanteds'', tybinds, binds1) <- tcReduceEqs [] wanteds'
+        ; execTcTyVarBinds tybinds
+
+	  	-- Simplify other constraints
+	; (irreds, binds2) <- go [] emptyBag wanteds''
+
+	  	-- Report anything that is left
+	; let (dicts, bad_irreds) = partition isDict irreds
+	; traceTc (text "tcSimplifyrulelhs" <+> pprInsts bad_irreds)
+	; addNoInstanceErrs (nub bad_irreds)
+		-- The nub removes duplicates, which has
+		-- not happened otherwise (see notes above)
+
+	; return (dicts, binds1 `unionBags` binds2) }
+  where
+    go :: [Inst] -> TcDictBinds -> [Inst] -> TcM ([Inst], TcDictBinds)
+    go irreds binds []
+	= return (irreds, binds)
+    go irreds binds (w:ws)
+	| isDict w
+	= go (w:irreds) binds ws
+	| isImplicInst w	-- Have a go at reducing the implication
+	= do { (binds1, irreds1) <- reduceImplication red_env w
+	     ; let (bad_irreds, ok_irreds) = partition isImplicInst irreds1
+	     ; go (bad_irreds ++ irreds) 
+		  (binds `unionBags` binds1) 
+		  (ok_irreds ++ ws)}
+	| otherwise
+	= do { w' <- zonkInst w  -- So that (3::Int) does not generate a call
+				 -- to fromInteger; this looks fragile to me
+	     ; lookup_result <- lookupSimpleInst w'
+	     ; case lookup_result of
+		 NoInstance      -> go (w:irreds) binds ws
+		 GenInst ws' rhs -> go irreds binds' (ws' ++ ws)
+			where
+			  binds' = addInstToDictBind binds w rhs
+	  }
+
+	-- Sigh: we need to reduce inside implications
+    red_env = mkInferRedEnv doc try_me
+    doc = ptext (sLit "Implication constraint in RULE lhs")
+    try_me inst | isMethodOrLit inst = ReduceMe
+		| otherwise	     = Stop	-- Be gentle
+\end{code}
+
+tcSimplifyBracket is used when simplifying the constraints arising from
+a Template Haskell bracket [| ... |].  We want to check that there aren't
+any constraints that can't be satisfied (e.g. Show Foo, where Foo has no
+Show instance), but we aren't otherwise interested in the results.
+Nor do we care about ambiguous dictionaries etc.  We will type check
+this bracket again at its usage site.
+
+\begin{code}
+tcSimplifyBracket :: [Inst] -> TcM ()
+tcSimplifyBracket wanteds
+  = do	{ _ <- tryHardCheckLoop doc wanteds
+	; return () }
+  where
+    doc = text "tcSimplifyBracket"
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Filtering at a dynamic binding}
+%*									*
+%************************************************************************
+
+When we have
+	let ?x = R in B
+
+we must discharge all the ?x constraints from B.  We also do an improvement
+step; if we have ?x::t1 and ?x::t2 we must unify t1, t2.
+
+Actually, the constraints from B might improve the types in ?x. For example
+
+	f :: (?x::Int) => Char -> Char
+	let ?x = 3 in f 'c'
+
+then the constraint (?x::Int) arising from the call to f will
+force the binding for ?x to be of type Int.
+
+\begin{code}
+tcSimplifyIPs :: [Inst]		-- The implicit parameters bound here
+	      -> [Inst]		-- Wanted
+	      -> TcM TcDictBinds
+	-- We need a loop so that we do improvement, and then
+	-- (next time round) generate a binding to connect the two
+	-- 	let ?x = e in ?x
+	-- Here the two ?x's have different types, and improvement 
+	-- makes them the same.
+
+tcSimplifyIPs given_ips wanteds
+  = do	{ wanteds'   <- zonkInsts wanteds
+	; given_ips' <- zonkInsts given_ips
+		-- Unusually for checking, we *must* zonk the given_ips
+
+	; let env = mkRedEnv doc try_me given_ips'
+	; (improved, tybinds, binds, irreds) <- reduceContext env wanteds'
+        ; execTcTyVarBinds tybinds
+
+	; if null irreds || not improved then 
+		ASSERT( all is_free irreds )
+		do { extendLIEs irreds
+		   ; return binds }
+	  else do
+        -- If improvement did some unification, we go round again.
+        -- We start again with irreds, not wanteds
+        -- Using an instance decl might have introduced a fresh type
+        -- variable which might have been unified, so we'd get an 
+        -- infinite loop if we started again with wanteds!  
+        -- See Note [LOOP]
+        { binds1 <- tcSimplifyIPs given_ips' irreds
+        ; return $ binds `unionBags` binds1
+        } }
+  where
+    doc	   = text "tcSimplifyIPs" <+> ppr given_ips
+    ip_set = mkNameSet (ipNamesOfInsts given_ips)
+    is_free inst = isFreeWrtIPs ip_set inst
+
+	-- Simplify any methods that mention the implicit parameter
+    try_me inst | is_free inst = Stop
+		| otherwise    = ReduceMe
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[binds-for-local-funs]{@bindInstsOfLocalFuns@}
+%*									*
+%************************************************************************
+
+When doing a binding group, we may have @Insts@ of local functions.
+For example, we might have...
+\begin{verbatim}
+let f x = x + 1	    -- orig local function (overloaded)
+    f.1 = f Int	    -- two instances of f
+    f.2 = f Float
+ in
+    (f.1 5, f.2 6.7)
+\end{verbatim}
+The point is: we must drop the bindings for @f.1@ and @f.2@ here,
+where @f@ is in scope; those @Insts@ must certainly not be passed
+upwards towards the top-level.	If the @Insts@ were binding-ified up
+there, they would have unresolvable references to @f@.
+
+We pass in an @init_lie@ of @Insts@ and a list of locally-bound @Ids@.
+For each method @Inst@ in the @init_lie@ that mentions one of the
+@Ids@, we create a binding.  We return the remaining @Insts@ (in an
+@LIE@), as well as the @HsBinds@ generated.
+
+\begin{code}
+bindInstsOfLocalFuns ::	[Inst] -> [TcId] -> TcM TcDictBinds
+-- Simlifies only MethodInsts, and generate only bindings of form 
+--	fm = f tys dicts
+-- We're careful not to even generate bindings of the form
+--	d1 = d2
+-- You'd think that'd be fine, but it interacts with what is
+-- arguably a bug in Match.tidyEqnInfo (see notes there)
+
+bindInstsOfLocalFuns wanteds local_ids
+  | null overloaded_ids = do
+	-- Common case
+    extendLIEs wanteds
+    return emptyLHsBinds
+
+  | otherwise
+  = do	{ (irreds, binds) <- gentleInferLoop doc for_me
+	; extendLIEs not_for_me	
+	; extendLIEs irreds
+	; return binds }
+  where
+    doc		     = text "bindInsts" <+> ppr local_ids
+    overloaded_ids   = filter is_overloaded local_ids
+    is_overloaded id = isOverloadedTy (idType id)
+    (for_me, not_for_me) = partition (isMethodFor overloaded_set) wanteds
+
+    overloaded_set = mkVarSet overloaded_ids	-- There can occasionally be a lot of them
+						-- so it's worth building a set, so that
+						-- lookup (in isMethodFor) is faster
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection{Data types for the reduction mechanism}
+%*									*
+%************************************************************************
+
+The main control over context reduction is here
+
+\begin{code}
+data RedEnv 
+  = RedEnv { red_doc	:: SDoc			-- The context
+	   , red_try_me :: Inst -> WhatToDo
+	   , red_improve :: Bool		-- True <=> do improvement
+	   , red_givens :: [Inst]		-- All guaranteed rigid
+						-- Always dicts & equalities
+						-- but see Note [Rigidity]
+ 
+	   , red_stack  :: (Int, [Inst])	-- Recursion stack (for err msg)
+						-- See Note [RedStack]
+  }
+
+-- Note [Rigidity]
+-- The red_givens are rigid so far as cmpInst is concerned.
+-- There is one case where they are not totally rigid, namely in tcSimplifyIPs
+--	let ?x = e in ...
+-- Here, the given is (?x::a), where 'a' is not necy a rigid type
+-- But that doesn't affect the comparison, which is based only on mame.
+
+-- Note [RedStack]
+-- The red_stack pair (n,insts) pair is just used for error reporting.
+-- 'n' is always the depth of the stack.
+-- The 'insts' is the stack of Insts being reduced: to produce X
+-- I had to produce Y, to produce Y I had to produce Z, and so on.
+
+
+mkRedEnv :: SDoc -> (Inst -> WhatToDo) -> [Inst] -> RedEnv
+mkRedEnv doc try_me givens
+  = RedEnv { red_doc = doc, red_try_me = try_me,
+	     red_givens = givens, 
+	     red_stack = (0,[]),
+	     red_improve = True }	
+
+mkInferRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv
+-- No givens at all
+mkInferRedEnv doc try_me
+  = RedEnv { red_doc = doc, red_try_me = try_me,
+	     red_givens = [], 
+	     red_stack = (0,[]),
+	     red_improve = True }	
+
+mkNoImproveRedEnv :: SDoc -> (Inst -> WhatToDo) -> RedEnv
+-- Do not do improvement; no givens
+mkNoImproveRedEnv doc try_me
+  = RedEnv { red_doc = doc, red_try_me = try_me,
+	     red_givens = [], 
+	     red_stack = (0,[]),
+	     red_improve = True }	
+
+data WhatToDo
+ = ReduceMe 	-- Try to reduce this
+		-- If there's no instance, add the inst to the 
+		-- irreductible ones, but don't produce an error 
+		-- message of any kind.
+		-- It might be quite legitimate such as (Eq a)!
+
+ | Stop		-- Return as irreducible unless it can
+			-- be reduced to a constant in one step
+			-- Do not add superclasses; see 
+
+data WantSCs = NoSCs | AddSCs	-- Tells whether we should add the superclasses
+				-- of a predicate when adding it to the avails
+	-- The reason for this flag is entirely the super-class loop problem
+	-- Note [SUPER-CLASS LOOP 1]
+
+zonkRedEnv :: RedEnv -> TcM RedEnv
+zonkRedEnv env
+  = do { givens' <- mapM zonkInst (red_givens env)
+       ; return $ env {red_givens = givens'}
+       }
+\end{code}
+
+
+%************************************************************************
+%*									*
+\subsection[reduce]{@reduce@}
+%*									*
+%************************************************************************
+
+Note [Ancestor Equalities]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+During context reduction, we add to the wanted equalities also those
+equalities that (transitively) occur in superclass contexts of wanted
+class constraints.  Consider the following code
+
+  class a ~ Int => C a
+  instance C Int
+
+If (C a) is wanted, we want to add (a ~ Int), which will be discharged by
+substituting Int for a.  Hence, we ultimately want (C Int), which we
+discharge with the explicit instance.
+
+\begin{code}
+reduceContext :: RedEnv
+	      -> [Inst]			-- Wanted
+	      -> TcM (ImprovementDone,
+                      TcTyVarBinds,     -- Type variable bindings
+		      TcDictBinds,	-- Dictionary bindings
+		      [Inst])		-- Irreducible
+
+reduceContext env wanteds0
+  = do	{ traceTc (text "reduceContext" <+> (vcat [
+	     text "----------------------",
+	     red_doc env,
+	     text "given" <+> ppr (red_givens env),
+	     text "wanted" <+> ppr wanteds0,
+	     text "----------------------"
+	     ]))
+
+          -- We want to add as wanted equalities those that (transitively) 
+          -- occur in superclass contexts of wanted class constraints.
+          -- See Note [Ancestor Equalities]
+	; ancestor_eqs <- ancestorEqualities wanteds0
+	; traceTc $ text "reduceContext: ancestor eqs" <+> ppr ancestor_eqs
+
+          -- Normalise and solve all equality constraints as far as possible
+          -- and normalise all dictionary constraints wrt to the reduced
+          -- equalities.  The returned wanted constraints include the
+          -- irreducible wanted equalities.
+        ; let wanteds = wanteds0 ++ ancestor_eqs
+              givens  = red_givens env
+        ; (givens', 
+           wanteds', 
+           tybinds,
+           normalise_binds) <- tcReduceEqs givens wanteds
+	; traceTc $ text "reduceContext: tcReduceEqs result" <+> vcat
+		      [ppr givens', ppr wanteds', ppr tybinds, 
+                       ppr normalise_binds]
+
+          -- Build the Avail mapping from "given_dicts"
+	; (init_state, _) <- getConstraints $ do 
+		{ init_state <- foldlM addGiven emptyAvails givens'
+		; return init_state
+                }
+
+          -- Solve the *wanted* *dictionary* constraints (not implications)
+	  -- This may expose some further equational constraints in the course
+          -- of improvement due to functional dependencies if any of the
+          -- involved unifications gets deferred.
+	; let (wanted_implics, wanted_dicts) = partition isImplicInst wanteds'
+	; (avails, extra_eqs) <- getConstraints (reduceList env wanted_dicts init_state)
+	  	   -- The getConstraints is reqd because reduceList does improvement
+		   -- (via extendAvails) which may in turn do unification
+	; (dict_binds, 
+           bound_dicts, 
+           dict_irreds)       <- extractResults avails wanted_dicts
+	; traceTc $ text "reduceContext: extractResults" <+> vcat
+		      [ppr avails, ppr wanted_dicts, ppr dict_binds]
+
+	  -- Solve the wanted *implications*.  In doing so, we can provide
+	  -- as "given"   all the dicts that were originally given, 
+	  --		  *or* for which we now have bindings, 
+	  --		  *or* which are now irreds
+          -- NB: Equality irreds need to be converted, as the recursive 
+          --     invocation of the solver will still treat them as wanteds
+          --     otherwise.
+	; let implic_env = env { red_givens 
+                                   = givens ++ bound_dicts ++
+                                     map wantedToLocalEqInst dict_irreds }
+	; (implic_binds_s, implic_irreds_s) 
+            <- mapAndUnzipM (reduceImplication implic_env) wanted_implics
+	; let implic_binds  = unionManyBags implic_binds_s
+	      implic_irreds = concat implic_irreds_s
+
+          -- Collect all irreducible instances, and determine whether we should
+          -- go round again.  We do so in either of two cases:
+          -- (1) If dictionary reduction or equality solving led to
+          --     improvement (i.e., bindings for type variables).
+          -- (2) If we reduced dictionaries (i.e., got dictionary bindings),
+          --     they may have exposed further opportunities to normalise
+          --     family applications.  See Note [Dictionary Improvement]
+          --
+          -- NB: We do *not* go around for new extra_eqs.  Morally, we should,
+          --     but we can't without risking non-termination (see #2688).  By
+          --     not going around, we miss some legal programs mixing FDs and
+          --     TFs, but we never claimed to support such programs in the
+          --     current implementation anyway.
+
+	; let all_irreds       = dict_irreds ++ implic_irreds ++ extra_eqs
+      	      avails_improved  = availsImproved avails
+              eq_improved      = anyBag (not . isCoVarBind) tybinds
+              improvedFlexible = avails_improved || eq_improved
+              reduced_dicts    = not (isEmptyBag dict_binds)
+              improved         = improvedFlexible || reduced_dicts
+              --
+              improvedHint  = (if avails_improved then " [AVAILS]" else "") ++
+                              (if eq_improved then " [EQ]" else "")
+
+	; traceTc (text "reduceContext end" <+> (vcat [
+	     text "----------------------",
+	     red_doc env,
+	     text "given" <+> ppr givens,
+	     text "wanted" <+> ppr wanteds0,
+	     text "----",
+	     text "tybinds" <+> ppr tybinds,
+	     text "avails" <+> pprAvails avails,
+	     text "improved =" <+> ppr improved <+> text improvedHint,
+	     text "(all) irreds = " <+> ppr all_irreds,
+	     text "dict-binds = " <+> ppr dict_binds,
+	     text "implic-binds = " <+> ppr implic_binds,
+	     text "----------------------"
+	     ]))
+
+	; return (improved, 
+                  tybinds,
+                  normalise_binds `unionBags` dict_binds 
+                                  `unionBags` implic_binds, 
+                  all_irreds) 
+        }
+  where
+    isCoVarBind (TcTyVarBind tv _) = isCoVar tv
+
+tcImproveOne :: Avails -> Inst -> TcM ImprovementDone
+tcImproveOne avails inst
+  | not (isDict inst) = return False
+  | otherwise
+  = do	{ inst_envs <- tcGetInstEnvs
+	; let eqns = improveOne (classInstances inst_envs)
+				(dictPred inst, pprInstArising inst)
+				[ (dictPred p, pprInstArising p)
+				| p <- availsInsts avails, isDict p ]
+		-- Avails has all the superclasses etc (good)
+		-- It also has all the intermediates of the deduction (good)
+		-- It does not have duplicates (good)
+		-- NB that (?x::t1) and (?x::t2) will be held separately in 
+                --    avails so that improve will see them separate
+	; traceTc (text "improveOne" <+> ppr inst)
+	; unifyEqns eqns }
+
+unifyEqns :: [(Equation, (PredType, SDoc), (PredType, SDoc))] 
+	  -> TcM ImprovementDone
+unifyEqns [] = return False
+unifyEqns eqns
+  = do	{ traceTc (ptext (sLit "Improve:") <+> vcat (map pprEquationDoc eqns))
+        ; improved <- mapM unify eqns
+	; return $ or improved
+        }
+  where
+    unify ((qtvs, pairs), what1, what2)
+         = addErrCtxtM (mkEqnMsg what1 what2) $ 
+             do { let freeTyVars = unionVarSets (map tvs_pr pairs) 
+                                   `minusVarSet` qtvs
+                ; (_, _, tenv) <- tcInstTyVars (varSetElems qtvs)
+                ; mapM_ (unif_pr tenv) pairs
+                ; anyM isFilledMetaTyVar $ varSetElems freeTyVars
+                }
+
+    unif_pr tenv (ty1, ty2) = unifyType (substTy tenv ty1) (substTy tenv ty2)
+
+    tvs_pr (ty1, ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+
+pprEquationDoc :: (Equation, (PredType, SDoc), (PredType, SDoc)) -> SDoc
+pprEquationDoc (eqn, (p1, _), (p2, _)) 
+  = vcat [pprEquation eqn, nest 2 (ppr p1), nest 2 (ppr p2)]
+
+mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv
+         -> TcM (TidyEnv, SDoc)
+mkEqnMsg (pred1,from1) (pred2,from2) tidy_env
+  = do	{ pred1' <- zonkTcPredType pred1
+        ; pred2' <- zonkTcPredType pred2
+	; let { pred1'' = tidyPred tidy_env pred1'
+              ; pred2'' = tidyPred tidy_env pred2' }
+	; let msg = vcat [ptext (sLit "When using functional dependencies to combine"),
+			  nest 2 (sep [ppr pred1'' <> comma, nest 2 from1]), 
+			  nest 2 (sep [ppr pred2'' <> comma, nest 2 from2])]
+	; return (tidy_env, msg) }
+\end{code}
+
+Note [Dictionary Improvement]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In reduceContext, we first reduce equalities and then class constraints.
+However, the letter may expose further opportunities for the former.  Hence,
+we need to go around again if dictionary reduction produced any dictionary
+bindings.  The following example demonstrated the point:
+
+  data EX _x _y (p :: * -> *)
+  data ANY
+
+  class Base p
+
+  class Base (Def p) => Prop p where
+   type Def p
+
+  instance Base ()
+  instance Prop () where
+   type Def () = ()
+
+  instance (Base (Def (p ANY))) => Base (EX _x _y p)
+  instance (Prop (p ANY)) => Prop (EX _x _y p) where
+   type Def (EX _x _y p) = EX _x _y p
+
+  data FOO x
+  instance Prop (FOO x) where
+   type Def (FOO x) = ()
+
+  data BAR
+  instance Prop BAR where
+   type Def BAR = EX () () FOO
+
+During checking the last instance declaration, we need to check the superclass
+cosntraint Base (Def BAR), which family normalisation reduced to 
+Base (EX () () FOO).  Chasing the instance for Base (EX _x _y p), gives us
+Base (Def (FOO ANY)), which again requires family normalisation of Def to
+Base () before we can finish.
+
+
+The main context-reduction function is @reduce@.  Here's its game plan.
+
+\begin{code}
+reduceList :: RedEnv -> [Inst] -> Avails -> TcM Avails
+reduceList env@(RedEnv {red_stack = (n,stk)}) wanteds state
+  = do	{ traceTc (text "reduceList " <+> (ppr wanteds $$ ppr state))
+	; dopts <- getDOpts
+	; when (debugIsOn && (n > 8)) $ do
+		debugDumpTcRn (hang (ptext (sLit "Interesting! Context reduction stack depth") <+> int n) 
+			     2 (ifPprDebug (nest 2 (pprStack stk))))
+	; if n >= ctxtStkDepth dopts then
+	    failWithTc (reduceDepthErr n stk)
+	  else
+	    go wanteds state }
+  where
+    go []     state = return state
+    go (w:ws) state = do { state' <- reduce (env {red_stack = (n+1, w:stk)}) w state
+			 ; go ws state' }
+
+    -- Base case: we're done!
+reduce :: RedEnv -> Inst -> Avails -> TcM Avails
+reduce env wanted avails
+
+    -- We don't reduce equalities here (and they must not end up as irreds
+    -- in the Avails!)
+  | isEqInst wanted
+  = return avails
+
+    -- It's the same as an existing inst, or a superclass thereof
+  | Just _ <- findAvail avails wanted
+  = do { traceTc (text "reduce: found " <+> ppr wanted)
+       ; return avails
+       }
+
+  | otherwise
+  = do	{ traceTc (text "reduce" <+> ppr wanted $$ ppr avails)
+	; case red_try_me env wanted of {
+	    Stop -> try_simple (addIrred NoSCs);
+			-- See Note [No superclasses for Stop]
+
+	    ReduceMe -> do	-- It should be reduced
+		{ (avails, lookup_result) <- reduceInst env avails wanted
+		; case lookup_result of
+		    NoInstance -> addIrred AddSCs avails wanted
+			     -- Add it and its superclasses
+		    	     
+		    GenInst [] rhs -> addWanted AddSCs avails wanted rhs []
+
+		    GenInst wanteds' rhs
+			  -> do	{ avails1 <- addIrred NoSCs avails wanted
+				; avails2 <- reduceList env wanteds' avails1
+				; addWanted AddSCs avails2 wanted rhs wanteds' } }
+		-- Temporarily do addIrred *before* the reduceList, 
+		-- which has the effect of adding the thing we are trying
+		-- to prove to the database before trying to prove the things it
+		-- needs.  See note [RECURSIVE DICTIONARIES]
+		-- NB: we must not do an addWanted before, because that adds the
+		--     superclasses too, and that can lead to a spurious loop; see
+		--     the examples in [SUPERCLASS-LOOP]
+		-- So we do an addIrred before, and then overwrite it afterwards with addWanted
+    } }
+  where
+  	-- First, see if the inst can be reduced to a constant in one step
+	-- Works well for literals (1::Int) and constant dictionaries (d::Num Int)
+	-- Don't bother for implication constraints, which take real work
+    try_simple do_this_otherwise
+      = do { res <- lookupSimpleInst wanted
+	   ; case res of
+	        GenInst [] rhs -> addWanted AddSCs avails wanted rhs []
+	        _              -> do_this_otherwise avails wanted }
+\end{code}
+
+
+Note [RECURSIVE DICTIONARIES]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider 
+    data D r = ZeroD | SuccD (r (D r));
+    
+    instance (Eq (r (D r))) => Eq (D r) where
+        ZeroD     == ZeroD     = True
+        (SuccD a) == (SuccD b) = a == b
+        _         == _         = False;
+    
+    equalDC :: D [] -> D [] -> Bool;
+    equalDC = (==);
+
+We need to prove (Eq (D [])).  Here's how we go:
+
+	d1 : Eq (D [])
+
+by instance decl, holds if
+	d2 : Eq [D []]
+	where 	d1 = dfEqD d2
+
+by instance decl of Eq, holds if
+	d3 : D []
+	where	d2 = dfEqList d3
+		d1 = dfEqD d2
+
+But now we can "tie the knot" to give
+
+	d3 = d1
+	d2 = dfEqList d3
+	d1 = dfEqD d2
+
+and it'll even run!  The trick is to put the thing we are trying to prove
+(in this case Eq (D []) into the database before trying to prove its
+contributing clauses.
+	
+Note [SUPERCLASS-LOOP 2]
+~~~~~~~~~~~~~~~~~~~~~~~~
+We need to be careful when adding "the constaint we are trying to prove".
+Suppose we are *given* d1:Ord a, and want to deduce (d2:C [a]) where
+
+	class Ord a => C a where
+	instance Ord [a] => C [a] where ...
+
+Then we'll use the instance decl to deduce C [a] from Ord [a], and then add the
+superclasses of C [a] to avails.  But we must not overwrite the binding
+for Ord [a] (which is obtained from Ord a) with a superclass selection or we'll just
+build a loop! 
+
+Here's another variant, immortalised in tcrun020
+	class Monad m => C1 m
+	class C1 m => C2 m x
+	instance C2 Maybe Bool
+For the instance decl we need to build (C1 Maybe), and it's no good if
+we run around and add (C2 Maybe Bool) and its superclasses to the avails 
+before we search for C1 Maybe.
+
+Here's another example 
+ 	class Eq b => Foo a b
+	instance Eq a => Foo [a] a
+If we are reducing
+	(Foo [t] t)
+
+we'll first deduce that it holds (via the instance decl).  We must not
+then overwrite the Eq t constraint with a superclass selection!
+
+At first I had a gross hack, whereby I simply did not add superclass constraints
+in addWanted, though I did for addGiven and addIrred.  This was sub-optimal,
+becuase it lost legitimate superclass sharing, and it still didn't do the job:
+I found a very obscure program (now tcrun021) in which improvement meant the
+simplifier got two bites a the cherry... so something seemed to be an Stop
+first time, but reducible next time.
+
+Now we implement the Right Solution, which is to check for loops directly 
+when adding superclasses.  It's a bit like the occurs check in unification.
+
+
+
+%************************************************************************
+%*									*
+		Reducing a single constraint
+%*									*
+%************************************************************************
+
+\begin{code}
+---------------------------------------------
+reduceInst :: RedEnv -> Avails -> Inst -> TcM (Avails, LookupInstResult)
+reduceInst _ avails other_inst
+  = do	{ result <- lookupSimpleInst other_inst
+	; return (avails, result) }
+\end{code}
+
+Note [Equational Constraints in Implication Constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+An implication constraint is of the form 
+	Given => Wanted 
+where Given and Wanted may contain both equational and dictionary
+constraints. The delay and reduction of these two kinds of constraints
+is distinct:
+
+-) In the generated code, wanted Dictionary constraints are wrapped up in an
+   implication constraint that is created at the code site where the wanted
+   dictionaries can be reduced via a let-binding. This let-bound implication
+   constraint is deconstructed at the use-site of the wanted dictionaries.
+
+-) While the reduction of equational constraints is also delayed, the delay
+   is not manifest in the generated code. The required evidence is generated
+   in the code directly at the use-site. There is no let-binding and deconstruction
+   necessary. The main disadvantage is that we cannot exploit sharing as the
+   same evidence may be generated at multiple use-sites. However, this disadvantage
+   is limited because it only concerns coercions which are erased.
+
+The different treatment is motivated by the different in representation. Dictionary
+constraints require manifest runtime dictionaries, while equations require coercions
+which are types.
+
+\begin{code}
+---------------------------------------------
+reduceImplication :: RedEnv
+		  -> Inst
+		  -> TcM (TcDictBinds, [Inst])
+\end{code}
+
+Suppose we are simplifying the constraint
+	forall bs. extras => wanted
+in the context of an overall simplification problem with givens 'givens'.
+
+Note that
+  * The 'givens' need not mention any of the quantified type variables
+	e.g. 	forall {}. Eq a => Eq [a]
+		forall {}. C Int => D (Tree Int)
+
+    This happens when you have something like
+	data T a where
+	  T1 :: Eq a => a -> T a
+
+	f :: T a -> Int
+	f x = ...(case x of { T1 v -> v==v })...
+
+\begin{code}
+	-- ToDo: should we instantiate tvs?  I think it's not necessary
+	--
+	-- Note on coercion variables:
+	--
+	--	The extra given coercion variables are bound at two different 
+        --      sites:
+        --
+	--	-) in the creation context of the implication constraint	
+	--		the solved equational constraints use these binders
+	--
+	--	-) at the solving site of the implication constraint
+	--		the solved dictionaries use these binders;
+	--		these binders are generated by reduceImplication
+	--
+        -- Note [Binders for equalities]
+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+        -- To reuse the binders of local/given equalities in the binders of 
+        -- implication constraints, it is crucial that these given equalities
+        -- always have the form
+        --   cotv :: t1 ~ t2
+        -- where cotv is a simple coercion type variable (and not a more
+        -- complex coercion term).  We require that the extra_givens always
+        -- have this form and exploit the special form when generating binders.
+reduceImplication env
+	orig_implic@(ImplicInst { tci_name = name, tci_loc = inst_loc,
+		      	   	  tci_tyvars = tvs,
+		      	   	  tci_given = extra_givens, tci_wanted = wanteds
+                                 })
+  = do	{ 	-- Solve the sub-problem
+	; let try_me _ = ReduceMe  -- Note [Freeness and implications]
+	      env' = env { red_givens = extra_givens ++ red_givens env
+			 , red_doc = sep [ptext (sLit "reduceImplication for") 
+                                            <+> ppr name,
+					  nest 2 (parens $ ptext (sLit "within")
+                                                           <+> red_doc env)]
+			 , red_try_me = try_me }
+
+	; traceTc (text "reduceImplication" <+> vcat
+			[ ppr (red_givens env), ppr extra_givens, 
+			  ppr wanteds])
+	; (irreds, binds) <- checkLoop env' wanteds
+
+	; traceTc (text "reduceImplication result" <+> vcat
+			[ppr irreds, ppr binds])
+
+	; -- extract superclass binds
+	  --  (sc_binds,_) <- extractResults avails []
+-- 	; traceTc (text "reduceImplication sc_binds" <+> vcat
+--			[ppr sc_binds, ppr avails])
+--  
+
+	-- SLPJ Sept 07: what if improvement happened inside the checkLoop?
+	-- Then we must iterate the outer loop too!
+
+        ; didntSolveWantedEqs <- allM wantedEqInstIsUnsolved wanteds
+                                   -- we solve wanted eqs by side effect!
+
+            -- Progress is no longer measered by the number of bindings
+            -- If there are any irreds, but no bindings and no solved
+            -- equalities, we back off and do nothing
+        ; let backOff = isEmptyLHsBinds binds &&   -- no new bindings
+                        (not $ null irreds)   &&   -- but still some irreds
+                        didntSolveWantedEqs        -- no instantiated cotv
+
+	; if backOff then 	-- No progress
+		return (emptyBag, [orig_implic])
+	  else do
+	{ (simpler_implic_insts, bind) 
+            <- makeImplicationBind inst_loc tvs extra_givens irreds
+		-- This binding is useless if the recursive simplification
+		-- made no progress; but currently we don't try to optimise that
+		-- case.  After all, we only try hard to reduce at top level, or
+		-- when inferring types.
+
+	; let   -- extract Id binders for dicts and CoTyVar binders for eqs;
+                -- see Note [Binders for equalities]
+	      (extra_eq_givens, extra_dict_givens) = partition isEqInst 
+                                                               extra_givens
+              eq_cotvs = map instToVar extra_eq_givens
+	      dict_ids = map instToId  extra_dict_givens 
+
+              co         = mkWpTyLams tvs
+                           <.> mkWpTyLams eq_cotvs
+                           <.> mkWpLams dict_ids
+                           <.> WpLet (binds `unionBags` bind)
+              rhs        = mkLHsWrap co payload
+              loc        = instLocSpan inst_loc
+		             -- wanted equalities are solved by updating their
+                             -- cotv; we don't generate bindings for them
+              dict_bndrs =   map (L loc . HsVar . instToId) 
+                           . filter (not . isEqInst) 
+                           $ wanteds
+              payload    = mkBigLHsTup dict_bndrs
+	
+	; traceTc (vcat [text "reduceImplication" <+> ppr name,
+			 ppr simpler_implic_insts,
+			 text "->" <+> ppr rhs])
+	; return (unitBag (L loc (VarBind { var_id= instToId orig_implic
+					  , var_rhs = rhs
+					  , var_inline = notNull dict_ids }
+				-- See Note [Always inline implication constraints]
+			  )),
+		  simpler_implic_insts)
+  	} 
+    }
+reduceImplication _ i = pprPanic "reduceImplication" (ppr i)
+\end{code}
+
+Note [Always inline implication constraints]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose an implication constraint floats out of an INLINE function.
+Then although the implication has a single call site, it won't be 
+inlined.  And that is bad because it means that even if there is really
+*no* overloading (type signatures specify the exact types) there will
+still be dictionary passing in the resulting code.  To avert this,
+we mark the implication constraints themselves as INLINE, at least when
+there is no loss of sharing as a result.
+
+Note [Freeness and implications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It's hard to say when an implication constraint can be floated out.  Consider
+	forall {} Eq a => Foo [a]
+The (Foo [a]) doesn't mention any of the quantified variables, but it
+still might be partially satisfied by the (Eq a). 
+
+There is a useful special case when it *is* easy to partition the 
+constraints, namely when there are no 'givens'.  Consider
+	forall {a}. () => Bar b
+There are no 'givens', and so there is no reason to capture (Bar b).
+We can let it float out.  But if there is even one constraint we
+must be much more careful:
+	forall {a}. C a b => Bar (m b)
+because (C a b) might have a superclass (D b), from which we might 
+deduce (Bar [b]) when m later gets instantiated to [].  Ha!
+
+Here is an even more exotic example
+	class C a => D a b
+Now consider the constraint
+	forall b. D Int b => C Int
+We can satisfy the (C Int) from the superclass of D, so we don't want
+to float the (C Int) out, even though it mentions no type variable in
+the constraints!
+
+One more example: the constraint
+	class C a => D a b
+	instance (C a, E c) => E (a,c)
+
+	constraint: forall b. D Int b => E (Int,c)
+
+You might think that the (D Int b) can't possibly contribute
+to solving (E (Int,c)), since the latter mentions 'c'.  But 
+in fact it can, because solving the (E (Int,c)) constraint needs 
+dictionaries
+	C Int, E c
+and the (C Int) can be satisfied from the superclass of (D Int b).
+So we must still not float (E (Int,c)) out.
+
+To think about: special cases for unary type classes?
+
+Note [Pruning the givens in an implication constraint]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are about to form the implication constraint
+	forall tvs.  Eq a => Ord b
+The (Eq a) cannot contribute to the (Ord b), because it has no access to
+the type variable 'b'.  So we could filter out the (Eq a) from the givens.
+But BE CAREFUL of the examples above in [Freeness and implications].
+
+Doing so would be a bit tidier, but all the implication constraints get
+simplified away by the optimiser, so it's no great win.   So I don't take
+advantage of that at the moment.
+
+If you do, BE CAREFUL of wobbly type variables.
+
+
+%************************************************************************
+%*									*
+		Avails and AvailHow: the pool of evidence
+%*									*
+%************************************************************************
+
+
+\begin{code}
+data Avails = Avails !ImprovementDone !AvailEnv
+
+type ImprovementDone = Bool	-- True <=> some unification has happened
+				-- so some Irreds might now be reducible
+				-- keys that are now 
+
+type AvailEnv = FiniteMap Inst AvailHow
+data AvailHow
+  = IsIrred 		-- Used for irreducible dictionaries,
+			-- which are going to be lambda bound
+
+  | Given Inst 		-- Used for dictionaries for which we have a binding
+			-- e.g. those "given" in a signature
+
+  | Rhs 		-- Used when there is a RHS
+	(LHsExpr TcId) 	-- The RHS
+	[Inst]		-- Insts free in the RHS; we need these too
+
+instance Outputable Avails where
+  ppr = pprAvails
+
+pprAvails :: Avails -> SDoc
+pprAvails (Avails imp avails)
+  = vcat [ ptext (sLit "Avails") <> (if imp then ptext (sLit "[improved]") else empty)
+	 , nest 2 $ braces $ 
+	   vcat [ sep [ppr inst, nest 2 (equals <+> ppr avail)]
+		| (inst,avail) <- fmToList avails ]]
+
+instance Outputable AvailHow where
+    ppr = pprAvail
+
+-------------------------
+pprAvail :: AvailHow -> SDoc
+pprAvail IsIrred	= text "Irred"
+pprAvail (Given x)   	= text "Given" <+> ppr x
+pprAvail (Rhs rhs bs)   = sep [text "Rhs" <+> ppr bs,
+			       nest 2 (ppr rhs)]
+
+-------------------------
+extendAvailEnv :: AvailEnv -> Inst -> AvailHow -> AvailEnv
+extendAvailEnv env inst avail = addToFM env inst avail
+
+findAvailEnv :: AvailEnv -> Inst -> Maybe AvailHow
+findAvailEnv env wanted = lookupFM env wanted
+	-- NB 1: the Ord instance of Inst compares by the class/type info
+	--  *not* by unique.  So
+	--	d1::C Int ==  d2::C Int
+
+emptyAvails :: Avails
+emptyAvails = Avails False emptyFM
+
+findAvail :: Avails -> Inst -> Maybe AvailHow
+findAvail (Avails _ avails) wanted = findAvailEnv avails wanted
+
+elemAvails :: Inst -> Avails -> Bool
+elemAvails wanted (Avails _ avails) = wanted `elemFM` avails
+
+extendAvails :: Avails -> Inst -> AvailHow -> TcM Avails
+-- Does improvement
+extendAvails avails@(Avails imp env) inst avail
+  = do	{ imp1 <- tcImproveOne avails inst	-- Do any improvement
+	; return (Avails (imp || imp1) (extendAvailEnv env inst avail)) }
+
+availsInsts :: Avails -> [Inst]
+availsInsts (Avails _ avails) = keysFM avails
+
+availsImproved :: Avails -> ImprovementDone
+availsImproved (Avails imp _) = imp
+\end{code}
+
+Extracting the bindings from a bunch of Avails.
+The bindings do *not* come back sorted in dependency order.
+We assume that they'll be wrapped in a big Rec, so that the
+dependency analyser can sort them out later
+
+\begin{code}
+type DoneEnv = FiniteMap Inst [Id]
+-- Tracks which things we have evidence for
+
+extractResults :: Avails
+	       -> [Inst]		-- Wanted
+	       -> TcM (TcDictBinds, 	-- Bindings
+		       [Inst],		-- The insts bound by the bindings
+		       [Inst])		-- Irreducible ones
+			-- Note [Reducing implication constraints]
+
+extractResults (Avails _ avails) wanteds
+  = go emptyBag [] [] emptyFM wanteds
+  where
+    go	:: TcDictBinds 	-- Bindings for dicts
+	-> [Inst]	-- Bound by the bindings
+	-> [Inst]	-- Irreds
+	-> DoneEnv	-- Has an entry for each inst in the above three sets
+	-> [Inst]	-- Wanted
+	-> TcM (TcDictBinds, [Inst], [Inst])
+    go binds bound_dicts irreds _ [] 
+      = return (binds, bound_dicts, irreds)
+
+    go binds bound_dicts irreds done (w:ws)
+      | isEqInst w
+      = go binds bound_dicts (w:irreds) done' ws
+
+      | Just done_ids@(done_id : rest_done_ids) <- lookupFM done w
+      = if w_id `elem` done_ids then
+	   go binds bound_dicts irreds done ws
+	else
+	   go (add_bind (nlHsVar done_id)) bound_dicts irreds
+	      (addToFM done w (done_id : w_id : rest_done_ids)) ws
+
+      | otherwise	-- Not yet done
+      = case findAvailEnv avails w of
+	  Nothing -> pprTrace "Urk: extractResults" (ppr w) $
+		     go binds bound_dicts irreds done ws
+
+	  Just IsIrred -> go binds bound_dicts (w:irreds) done' ws
+
+	  Just (Rhs rhs ws') -> go (add_bind rhs) (w:bound_dicts) irreds done' (ws' ++ ws)
+
+	  Just (Given g) -> go binds' bound_dicts irreds (addToFM done w [g_id]) ws 
+		where
+		  g_id = instToId g
+		  binds' | w_id == g_id = binds
+			 | otherwise    = add_bind (nlHsVar g_id)
+      where
+	w_id  = instToId w	
+	done' = addToFM done w [w_id]
+	add_bind rhs = addInstToDictBind binds w rhs
+\end{code}
+
+
+Note [No superclasses for Stop]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we decide not to reduce an Inst -- the 'WhatToDo' --- we still
+add it to avails, so that any other equal Insts will be commoned up
+right here.  However, we do *not* add superclasses.  If we have
+	df::Floating a
+	dn::Num a
+but a is not bound here, then we *don't* want to derive dn from df
+here lest we lose sharing.
+
+\begin{code}
+addWanted :: WantSCs -> Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails
+addWanted want_scs avails wanted rhs_expr wanteds
+  = addAvailAndSCs want_scs avails wanted avail
+  where
+    avail = Rhs rhs_expr wanteds
+
+addGiven :: Avails -> Inst -> TcM Avails
+addGiven avails given 
+  = addAvailAndSCs want_scs avails given (Given given)
+  where
+    want_scs = case instLocOrigin (instLoc given) of
+    	         NoScOrigin -> NoSCs
+		 _other	    -> AddSCs
+	-- Conditionally add superclasses for 'given'
+	-- See Note [Recursive instances and superclases]
+
+  -- No ASSERT( not (given `elemAvails` avails) ) because in an
+  -- instance decl for Ord t we can add both Ord t and Eq t as
+  -- 'givens', so the assert isn't true
+\end{code}
+
+\begin{code}
+addIrred :: WantSCs -> Avails -> Inst -> TcM Avails
+addIrred want_scs avails irred = ASSERT2( not (irred `elemAvails` avails), ppr irred $$ ppr avails )
+    	      		         addAvailAndSCs want_scs avails irred IsIrred
+
+addAvailAndSCs :: WantSCs -> Avails -> Inst -> AvailHow -> TcM Avails
+addAvailAndSCs want_scs avails inst avail
+  | not (isClassDict inst) = extendAvails avails inst avail
+  | NoSCs <- want_scs	   = extendAvails avails inst avail
+  | otherwise		   = do { traceTc (text "addAvailAndSCs" <+> vcat [ppr inst, ppr deps])
+				; avails' <- extendAvails avails inst avail
+				; addSCs is_loop avails' inst }
+  where
+    is_loop pred = any (`tcEqType` mkPredTy pred) dep_tys
+			-- Note: this compares by *type*, not by Unique
+    deps         = findAllDeps (unitVarSet (instToVar inst)) avail
+    dep_tys	 = map idType (varSetElems deps)
+
+    findAllDeps :: IdSet -> AvailHow -> IdSet
+    -- Find all the Insts that this one depends on
+    -- See Note [SUPERCLASS-LOOP 2]
+    -- Watch out, though.  Since the avails may contain loops 
+    -- (see Note [RECURSIVE DICTIONARIES]), so we need to track the ones we've seen so far
+    findAllDeps so_far (Rhs _ kids) = foldl find_all so_far kids
+    findAllDeps so_far _            = so_far
+
+    find_all :: IdSet -> Inst -> IdSet
+    find_all so_far kid
+      | isEqInst kid                       = so_far
+      | kid_id `elemVarSet` so_far	   = so_far
+      | Just avail <- findAvail avails kid = findAllDeps so_far' avail
+      | otherwise			   = so_far'
+      where
+	so_far' = extendVarSet so_far kid_id	-- Add the new kid to so_far
+	kid_id = instToId kid
+
+addSCs :: (TcPredType -> Bool) -> Avails -> Inst -> TcM Avails
+	-- Add all the superclasses of the Inst to Avails
+	-- The first param says "don't do this because the original thing
+	--	depends on this one, so you'd build a loop"
+	-- Invariant: the Inst is already in Avails.
+
+addSCs is_loop avails dict
+  = ASSERT( isDict dict )
+    do	{ sc_dicts <- newCtGivens (instLoc dict) sc_theta'
+	; foldlM add_sc avails (zipEqual "add_scs" sc_dicts sc_sels) }
+  where
+    (clas, tys) = getDictClassTys dict
+    (tyvars, sc_theta, sc_sels, _) = classBigSig clas
+    sc_theta' = filter (not . isEqPred) $
+                  substTheta (zipTopTvSubst tyvars tys) sc_theta
+
+    add_sc avails (sc_dict, sc_sel)
+      | is_loop (dictPred sc_dict) = return avails 	-- See Note [SUPERCLASS-LOOP 2]
+      | is_given sc_dict 	   = return avails
+      | otherwise		   = do { avails' <- extendAvails avails sc_dict (Rhs sc_sel_rhs [dict])
+					; addSCs is_loop avails' sc_dict }
+      where
+	sc_sel_rhs = L (instSpan dict) (HsWrap co_fn (HsVar sc_sel))
+	co_fn	   = WpApp (instToVar dict) <.> mkWpTyApps tys
+
+    is_given :: Inst -> Bool
+    is_given sc_dict = case findAvail avails sc_dict of
+			  Just (Given _) -> True	-- Given is cheaper than superclass selection
+			  _              -> False
+
+-- From the a set of insts obtain all equalities that (transitively) occur in
+-- superclass contexts of class constraints (aka the ancestor equalities). 
+--
+ancestorEqualities :: [Inst] -> TcM [Inst]
+ancestorEqualities
+  =   mapM mkWantedEqInst               -- turn only equality predicates..
+    . filter isEqPred                   -- ..into wanted equality insts
+    . bagToList 
+    . addAEsToBag emptyBag              -- collect the superclass constraints..
+    . map dictPred                      -- ..of all predicates in a bag
+    . filter isClassDict
+  where
+    addAEsToBag :: Bag PredType -> [PredType] -> Bag PredType
+    addAEsToBag bag []           = bag
+    addAEsToBag bag (pred:preds)
+      | pred `elemBag` bag = addAEsToBag bag         preds
+      | isEqPred pred      = addAEsToBag bagWithPred preds
+      | isClassPred pred   = addAEsToBag bagWithPred predsWithSCs
+      | otherwise          = addAEsToBag bag         preds
+      where
+        bagWithPred  = bag `snocBag` pred
+        predsWithSCs = preds ++ substTheta (zipTopTvSubst tyvars tys) sc_theta
+        --
+        (tyvars, sc_theta, _, _) = classBigSig clas
+        (clas, tys) 		 = getClassPredTys pred 
+\end{code}
+
+
+%************************************************************************
+%*									*
+\section{tcSimplifyTop: defaulting}
+%*									*
+%************************************************************************
+
+
+@tcSimplifyTop@ is called once per module to simplify all the constant
+and ambiguous Insts.
+
+We need to be careful of one case.  Suppose we have
+
+	instance Num a => Num (Foo a b) where ...
+
+and @tcSimplifyTop@ is given a constraint (Num (Foo x y)).  Then it'll simplify
+to (Num x), and default x to Int.  But what about y??
+
+It's OK: the final zonking stage should zap y to (), which is fine.
+
+
+\begin{code}
+tcSimplifyTop, tcSimplifyInteractive :: [Inst] -> TcM TcDictBinds
+tcSimplifyTop wanteds
+  = tc_simplify_top doc False wanteds
+  where 
+    doc = text "tcSimplifyTop"
+
+tcSimplifyInteractive wanteds
+  = tc_simplify_top doc True wanteds
+  where 
+    doc = text "tcSimplifyInteractive"
+
+-- The TcLclEnv should be valid here, solely to improve
+-- error message generation for the monomorphism restriction
+tc_simplify_top :: SDoc -> Bool -> [Inst] -> TcM (Bag (LHsBind TcId))
+tc_simplify_top doc interactive wanteds
+  = do	{ dflags <- getDOpts
+	; wanteds <- zonkInsts wanteds
+	; mapM_ zonkTopTyVar (varSetElems (tyVarsOfInsts wanteds))
+
+	; traceTc (text "tc_simplify_top 0: " <+> ppr wanteds)
+	; (irreds1, binds1) <- tryHardCheckLoop doc1 wanteds
+--	; (irreds1, binds1) <- gentleInferLoop doc1 wanteds
+	; traceTc (text "tc_simplify_top 1: " <+> ppr irreds1)
+	; (irreds2, binds2) <- approximateImplications doc2 (\_ -> True) irreds1
+	; traceTc (text "tc_simplify_top 2: " <+> ppr irreds2)
+
+		-- Use the defaulting rules to do extra unification
+		-- NB: irreds2 are already zonked
+	; (irreds3, binds3) <- disambiguate doc3 interactive dflags irreds2
+
+		-- Deal with implicit parameters
+	; let (bad_ips, non_ips) = partition isIPDict irreds3
+	      (ambigs, others)   = partition isTyVarDict non_ips
+
+	; topIPErrs bad_ips	-- Can arise from   f :: Int -> Int
+				--		    f x = x + ?y
+	; addNoInstanceErrs others
+	; addTopAmbigErrs ambigs	
+
+	; return (binds1 `unionBags` binds2 `unionBags` binds3) }
+  where
+    doc1 = doc <+> ptext (sLit "(first round)")
+    doc2 = doc <+> ptext (sLit "(approximate)")
+    doc3 = doc <+> ptext (sLit "(disambiguate)")
+\end{code}
+
+If a dictionary constrains a type variable which is
+	* not mentioned in the environment
+	* and not mentioned in the type of the expression
+then it is ambiguous. No further information will arise to instantiate
+the type variable; nor will it be generalised and turned into an extra
+parameter to a function.
+
+It is an error for this to occur, except that Haskell provided for
+certain rules to be applied in the special case of numeric types.
+Specifically, if
+	* at least one of its classes is a numeric class, and
+	* all of its classes are numeric or standard
+then the type variable can be defaulted to the first type in the
+default-type list which is an instance of all the offending classes.
+
+So here is the function which does the work.  It takes the ambiguous
+dictionaries and either resolves them (producing bindings) or
+complains.  It works by splitting the dictionary list by type
+variable, and using @disambigOne@ to do the real business.
+
+@disambigOne@ assumes that its arguments dictionaries constrain all
+the same type variable.
+
+ADR Comment 20/6/94: I've changed the @CReturnable@ case to default to
+@()@ instead of @Int@.  I reckon this is the Right Thing to do since
+the most common use of defaulting is code like:
+\begin{verbatim}
+	_ccall_ foo	`seqPrimIO` bar
+\end{verbatim}
+Since we're not using the result of @foo@, the result if (presumably)
+@void@.
+
+\begin{code}
+disambiguate :: SDoc -> Bool -> DynFlags -> [Inst] -> TcM ([Inst], TcDictBinds)
+	-- Just does unification to fix the default types
+	-- The Insts are assumed to be pre-zonked
+disambiguate doc interactive dflags insts
+  | null insts
+  = return (insts, emptyBag)
+
+  | null defaultable_groups
+  = do	{ traceTc (text "disambigutate, no defaultable groups" <+> vcat [ppr unaries, ppr insts, ppr bad_tvs, ppr defaultable_groups])
+	; return (insts, emptyBag) }
+
+  | otherwise
+  = do 	{  	-- Figure out what default types to use
+	  default_tys <- getDefaultTys extended_defaulting ovl_strings
+
+	; traceTc (text "disambiguate1" <+> vcat [ppr insts, ppr unaries, ppr bad_tvs, ppr defaultable_groups])
+	; mapM_ (disambigGroup default_tys) defaultable_groups
+
+	-- disambigGroup does unification, hence try again
+	; tryHardCheckLoop doc insts }
+
+  where
+   extended_defaulting = interactive || dopt Opt_ExtendedDefaultRules dflags
+   		       -- See also Trac #1974
+   ovl_strings = dopt Opt_OverloadedStrings dflags
+
+   unaries :: [(Inst, Class, TcTyVar)]  -- (C tv) constraints
+   bad_tvs :: TcTyVarSet  -- Tyvars mentioned by *other* constraints
+   (unaries, bad_tvs_s) = partitionWith find_unary insts 
+   bad_tvs 		= unionVarSets bad_tvs_s
+
+	-- Finds unary type-class constraints
+   find_unary d@(Dict {tci_pred = ClassP cls [ty]})
+	| Just tv <- tcGetTyVar_maybe ty = Left (d,cls,tv)
+   find_unary inst			 = Right (tyVarsOfInst inst)
+
+		-- Group by type variable
+   defaultable_groups :: [[(Inst,Class,TcTyVar)]]
+   defaultable_groups = filter defaultable_group (equivClasses cmp_tv unaries)
+   cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2
+
+   defaultable_group :: [(Inst,Class,TcTyVar)] -> Bool
+   defaultable_group ds@((_,_,tv):_)
+	=  isTyConableTyVar tv	-- Note [Avoiding spurious errors]
+	&& not (tv `elemVarSet` bad_tvs)
+	&& defaultable_classes [c | (_,c,_) <- ds]
+   defaultable_group [] = panic "defaultable_group"
+
+   defaultable_classes clss 
+	| extended_defaulting = any isInteractiveClass clss
+	| otherwise 	      = all is_std_class clss && (any is_num_class clss)
+
+ 	-- In interactive mode, or with -XExtendedDefaultRules,
+	-- we default Show a to Show () to avoid graututious errors on "show []"
+   isInteractiveClass cls 
+	= is_num_class cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
+
+   is_num_class cls = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))
+	-- is_num_class adds IsString to the standard numeric classes, 
+	-- when -foverloaded-strings is enabled
+
+   is_std_class cls = isStandardClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))
+	-- Similarly is_std_class
+
+-----------------------
+disambigGroup :: [Type]			-- The default types
+	      -> [(Inst,Class,TcTyVar)]	-- All standard classes of form (C a)
+	      -> TcM ()	-- Just does unification, to fix the default types
+
+disambigGroup default_tys dicts
+  = do { mb_chosen_ty <- try_default default_tys
+       ; case mb_chosen_ty of
+            Nothing        -> return ()
+            Just chosen_ty -> do { _ <- unifyType chosen_ty (mkTyVarTy tyvar) 
+	    	 	         ; warnDefault dicts chosen_ty } }
+  where
+    (_,_,tyvar) = ASSERT(not (null dicts)) head dicts	-- Should be non-empty
+    classes = [c | (_,c,_) <- dicts]
+
+    try_default [] = return Nothing
+    try_default (default_ty : default_tys)
+      = tryTcLIE_ (try_default default_tys) $
+    	do { tcSimplifyDefault [mkClassPred clas [default_ty] | clas <- classes]
+		-- This may fail; then the tryTcLIE_ kicks in
+		-- Failure here is caused by there being no type in the
+		-- default list which can satisfy all the ambiguous classes.
+		-- For example, if Real a is reqd, but the only type in the
+		-- default list is Int.
+
+	   ; return (Just default_ty) -- TOMDO: do something with the coercion
+	   }
+
+
+-----------------------
+getDefaultTys :: Bool -> Bool -> TcM [Type]
+getDefaultTys extended_deflts ovl_strings
+  = do	{ mb_defaults <- getDeclaredDefaultTys
+	; case mb_defaults of {
+	   Just tys -> return tys ;	-- User-supplied defaults
+	   Nothing  -> do
+
+	-- No use-supplied default
+	-- Use [Integer, Double], plus modifications
+	{ integer_ty <- tcMetaTy integerTyConName
+	; checkWiredInTyCon doubleTyCon
+	; string_ty <- tcMetaTy stringTyConName
+	; return (opt_deflt extended_deflts unitTy
+			-- Note [Default unitTy]
+			++
+		  [integer_ty,doubleTy]
+			++
+		  opt_deflt ovl_strings string_ty) } } }
+  where
+    opt_deflt True  ty = [ty]
+    opt_deflt False _  = []
+\end{code}
+
+Note [Default unitTy]
+~~~~~~~~~~~~~~~~~~~~~
+In interative mode (or with -XExtendedDefaultRules) we add () as the first type we
+try when defaulting.  This has very little real impact, except in the following case.
+Consider: 
+	Text.Printf.printf "hello"
+This has type (forall a. IO a); it prints "hello", and returns 'undefined'.  We don't
+want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to
+default the 'a' to (), rather than to Integer (which is what would otherwise happen;
+and then GHCi doesn't attempt to print the ().  So in interactive mode, we add
+() to the list of defaulting types.  See Trac #1200.
+
+Note [Avoiding spurious errors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When doing the unification for defaulting, we check for skolem
+type variables, and simply don't default them.  For example:
+   f = (*)	-- Monomorphic
+   g :: Num a => a -> a
+   g x = f x x
+Here, we get a complaint when checking the type signature for g,
+that g isn't polymorphic enough; but then we get another one when
+dealing with the (Num a) context arising from f's definition;
+we try to unify a with Int (to default it), but find that it's
+already been unified with the rigid variable from g's type sig
+
+
+%************************************************************************
+%*									*
+\subsection[simple]{@Simple@ versions}
+%*									*
+%************************************************************************
+
+Much simpler versions when there are no bindings to make!
+
+@tcSimplifyThetas@ simplifies class-type constraints formed by
+@deriving@ declarations and when specialising instances.  We are
+only interested in the simplified bunch of class/type constraints.
+
+It simplifies to constraints of the form (C a b c) where
+a,b,c are type variables.  This is required for the context of
+instance declarations.
+
+\begin{code}
+tcSimplifyDeriv :: InstOrigin
+		-> [TyVar]	
+		-> ThetaType		-- Wanted
+	        -> TcM ThetaType	-- Needed
+-- Given  instance (wanted) => C inst_ty 
+-- Simplify 'wanted' as much as possible
+
+tcSimplifyDeriv orig tyvars theta
+  = do	{ (tvs, _, tenv) <- tcInstTyVars tyvars
+	-- The main loop may do unification, and that may crash if 
+	-- it doesn't see a TcTyVar, so we have to instantiate. Sigh
+	-- ToDo: what if two of them do get unified?
+	; wanteds <- newCtGivensO orig (substTheta tenv theta)
+	; (irreds, _) <- tryHardCheckLoop doc wanteds
+
+	; let (tv_dicts, others) = partition ok irreds
+	      (tidy_env, tidy_insts) = tidyInsts others
+        ; reportNoInstances tidy_env Nothing [alt_fix] tidy_insts
+	-- See Note [Exotic derived instance contexts] in TcMType
+
+	; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
+	      simpl_theta = substTheta rev_env (map dictPred tv_dicts)
+		-- This reverse-mapping is a pain, but the result
+		-- should mention the original TyVars not TcTyVars
+
+	; return simpl_theta }
+  where
+    doc = ptext (sLit "deriving classes for a data type")
+
+    ok dict | isDict dict = validDerivPred (dictPred dict)
+	    | otherwise	  = False
+    alt_fix = vcat [ptext (sLit "use a standalone 'deriving instance' declaration instead,"),
+                    ptext (sLit "so you can specify the instance context yourself")]
+\end{code}
+
+
+@tcSimplifyDefault@ just checks class-type constraints, essentially;
+used with \tr{default} declarations.  We are only interested in
+whether it worked or not.
+
+\begin{code}
+tcSimplifyDefault :: ThetaType	-- Wanted; has no type variables in it
+		  -> TcM ()
+
+tcSimplifyDefault theta = do
+    wanteds <- newCtGivensO DefaultOrigin theta
+    (irreds, _) <- tryHardCheckLoop doc wanteds
+    addNoInstanceErrs irreds
+    if null irreds then
+	return ()
+     else
+	traceTc (ptext (sLit "tcSimplifyDefault failing")) >> failM
+  where
+    doc = ptext (sLit "default declaration")
+\end{code}
+
+
+
+%************************************************************************
+%*									*
+\section{Errors and contexts}
+%*									*
+%************************************************************************
+
+ToDo: for these error messages, should we note the location as coming
+from the insts, or just whatever seems to be around in the monad just
+now?
+
+\begin{code}
+groupErrs :: ([Inst] -> TcM ())	-- Deal with one group
+	  -> [Inst]		-- The offending Insts
+          -> TcM ()
+-- Group together insts with the same origin
+-- We want to report them together in error messages
+
+groupErrs _ [] 
+  = return ()
+groupErrs report_err (inst:insts)
+  = do	{ do_one (inst:friends)
+	; groupErrs report_err others }
+  where
+	-- (It may seem a bit crude to compare the error messages,
+	--  but it makes sure that we combine just what the user sees,
+	--  and it avoids need equality on InstLocs.)
+   (friends, others) = partition is_friend insts
+   loc_msg	     = showSDoc (pprInstLoc (instLoc inst))
+   is_friend friend  = showSDoc (pprInstLoc (instLoc friend)) == loc_msg
+   do_one insts = setInstCtxt (instLoc (head insts)) (report_err insts)
+		-- Add location and context information derived from the Insts
+
+-- Add the "arising from..." part to a message about bunch of dicts
+addInstLoc :: [Inst] -> Message -> Message
+addInstLoc insts msg = msg $$ nest 2 (pprInstArising (head insts))
+
+addTopIPErrs :: [Name] -> [Inst] -> TcM ()
+addTopIPErrs _ [] 
+  = return ()
+addTopIPErrs bndrs ips
+  = do	{ dflags <- getDOpts
+	; addErrTcM (tidy_env, mk_msg dflags tidy_ips) }
+  where
+    (tidy_env, tidy_ips) = tidyInsts ips
+    mk_msg dflags ips 
+	= vcat [sep [ptext (sLit "Implicit parameters escape from"),
+	        nest 2 (ptext (sLit "the monomorphic top-level binding") 
+					    <> plural bndrs <+> ptext (sLit "of")
+					    <+> pprBinders bndrs <> colon)],
+		nest 2 (vcat (map ppr_ip ips)),
+		monomorphism_fix dflags]
+    ppr_ip ip = pprPred (dictPred ip) <+> pprInstArising ip
+
+topIPErrs :: [Inst] -> TcM ()
+topIPErrs dicts
+  = groupErrs report tidy_dicts
+  where
+    (tidy_env, tidy_dicts) = tidyInsts dicts
+    report dicts = addErrTcM (tidy_env, mk_msg dicts)
+    mk_msg dicts = addInstLoc dicts (ptext (sLit "Unbound implicit parameter") <> 
+				     plural tidy_dicts <+> pprDictsTheta tidy_dicts)
+
+addNoInstanceErrs :: [Inst]	-- Wanted (can include implications)
+		  -> TcM ()	
+addNoInstanceErrs insts
+  = do	{ let (tidy_env, tidy_insts) = tidyInsts insts
+	; reportNoInstances tidy_env Nothing [] tidy_insts }
+
+reportNoInstances 
+	:: TidyEnv
+	-> Maybe (InstLoc, [Inst])	-- Context
+			-- Nothing => top level
+			-- Just (d,g) => d describes the construct
+			--		 with givens g
+        -> [SDoc]	-- Alternative fix for no-such-instance
+	-> [Inst]	-- What is wanted (can include implications)
+	-> TcM ()	
+
+reportNoInstances tidy_env mb_what alt_fix insts 
+  = groupErrs (report_no_instances tidy_env mb_what alt_fix) insts
+
+report_no_instances :: TidyEnv -> Maybe (InstLoc, [Inst]) -> [SDoc] -> [Inst] -> TcM ()
+report_no_instances tidy_env mb_what alt_fixes insts
+  = do { inst_envs <- tcGetInstEnvs
+       ; let (implics, insts1)  = partition isImplicInst insts
+	     (insts2, overlaps) = partitionWith (check_overlap inst_envs) insts1
+             (eqInsts, insts3)  = partition isEqInst insts2
+       ; traceTc (text "reportNoInstances" <+> vcat 
+                       [ppr insts, ppr implics, ppr insts1, ppr insts2])
+       ; mapM_ complain_implic implics
+       ; mapM_ (\doc -> addErrTcM (tidy_env, doc)) overlaps
+       ; groupErrs complain_no_inst insts3 
+       ; mapM_ (addErrTcM . mk_eq_err) eqInsts
+       }
+  where
+    complain_no_inst insts = addErrTcM (tidy_env, mk_no_inst_err insts)
+
+    complain_implic inst	-- Recurse!
+      = reportNoInstances tidy_env 
+			  (Just (tci_loc inst, tci_given inst)) 
+			  alt_fixes (tci_wanted inst)
+
+    check_overlap :: (InstEnv,InstEnv) -> Inst -> Either Inst SDoc
+	-- Right msg  => overlap message
+	-- Left  inst => no instance
+    check_overlap inst_envs wanted
+	| not (isClassDict wanted) = Left wanted
+	| otherwise
+	= case lookupInstEnv inst_envs clas tys of
+		([], _) -> Left wanted		-- No match
+		-- The case of exactly one match and no unifiers means a
+		-- successful lookup.  That can't happen here, because dicts
+		-- only end up here if they didn't match in Inst.lookupInst
+		([_],[])
+		 | debugIsOn -> pprPanic "reportNoInstance" (ppr wanted)
+		res -> Right (mk_overlap_msg wanted res)
+	  where
+	    (clas,tys) = getDictClassTys wanted
+
+    mk_overlap_msg dict (matches, unifiers)
+      = ASSERT( not (null matches) )
+        vcat [	addInstLoc [dict] ((ptext (sLit "Overlapping instances for") 
+					<+> pprPred (dictPred dict))),
+    		sep [ptext (sLit "Matching instances") <> colon,
+    		     nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])],
+		if not (isSingleton matches)
+    		then 	-- Two or more matches
+		     empty
+    		else 	-- One match, plus some unifiers
+		ASSERT( not (null unifiers) )
+		parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+>
+	    		         quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))),
+			      ptext (sLit "To pick the first instance above, use -XIncoherentInstances"),
+			      ptext (sLit "when compiling the other instance declarations")])]
+      where
+    	ispecs = [ispec | (ispec, _) <- matches]
+
+    mk_eq_err :: Inst -> (TidyEnv, SDoc)
+    mk_eq_err inst = misMatchMsg tidy_env (eqInstTys inst)
+
+    mk_no_inst_err insts
+      | null insts = empty
+
+      | Just (loc, givens) <- mb_what,   -- Nested (type signatures, instance decls)
+	not (isEmptyVarSet (tyVarsOfInsts insts))
+      = vcat [ addInstLoc insts $
+	       sep [ ptext (sLit "Could not deduce") <+> pprDictsTheta insts
+	           , nest 2 $ ptext (sLit "from the context") <+> pprDictsTheta givens]
+	     , show_fixes (fix1 loc : fixes2 ++ alt_fixes) ]
+
+      | otherwise	-- Top level 
+      = vcat [ addInstLoc insts $
+	       ptext (sLit "No instance") <> plural insts
+		    <+> ptext (sLit "for") <+> pprDictsTheta insts
+	     , show_fixes (fixes2 ++ alt_fixes) ]
+
+      where
+    	fix1 loc = sep [ ptext (sLit "add") <+> pprDictsTheta insts
+				 <+> ptext (sLit "to the context of"),
+			 nest 2 (ppr (instLocOrigin loc)) ]
+			 -- I'm not sure it helps to add the location
+			 -- nest 2 (ptext (sLit "at") <+> ppr (instLocSpan loc)) ]
+
+    	fixes2 | null instance_dicts = []
+	       | otherwise	     = [sep [ptext (sLit "add an instance declaration for"),
+				        pprDictsTheta instance_dicts]]
+	instance_dicts = [d | d <- insts, isClassDict d, not (isTyVarDict d)]
+		-- Insts for which it is worth suggesting an adding an instance declaration
+		-- Exclude implicit parameters, and tyvar dicts
+
+	show_fixes :: [SDoc] -> SDoc
+	show_fixes []     = empty
+	show_fixes (f:fs) = sep [ptext (sLit "Possible fix:"), 
+				 nest 2 (vcat (f : map (ptext (sLit "or") <+>) fs))]
+
+addTopAmbigErrs :: [Inst] -> TcRn ()
+addTopAmbigErrs dicts
+-- Divide into groups that share a common set of ambiguous tyvars
+  = ifErrsM (return ()) $	-- Only report ambiguity if no other errors happened
+				-- See Note [Avoiding spurious errors]
+    mapM_ report (equivClasses cmp [(d, tvs_of d) | d <- tidy_dicts])
+  where
+    (tidy_env, tidy_dicts) = tidyInsts dicts
+
+    tvs_of :: Inst -> [TcTyVar]
+    tvs_of d = varSetElems (tyVarsOfInst d)
+    cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2
+    
+    report :: [(Inst,[TcTyVar])] -> TcM ()
+    report pairs@((inst,tvs) : _) = do	-- The pairs share a common set of ambiguous tyvars
+	  (tidy_env, mono_msg) <- mkMonomorphismMsg tidy_env tvs
+	  setSrcSpan (instSpan inst) $
+		-- the location of the first one will do for the err message
+	   addErrTcM (tidy_env, msg $$ mono_msg)
+	where
+	  dicts = map fst pairs
+	  msg = sep [text "Ambiguous type variable" <> plural tvs <+> 
+			  pprQuotedList tvs <+> in_msg,
+		     nest 2 (pprDictsInFull dicts)]
+	  in_msg = text "in the constraint" <> plural dicts <> colon
+    report [] = panic "addTopAmbigErrs"
+
+
+mkMonomorphismMsg :: TidyEnv -> [TcTyVar] -> TcM (TidyEnv, Message)
+-- There's an error with these Insts; if they have free type variables
+-- it's probably caused by the monomorphism restriction. 
+-- Try to identify the offending variable
+-- ASSUMPTION: the Insts are fully zonked
+mkMonomorphismMsg tidy_env inst_tvs
+  = do	{ dflags <- getDOpts
+	; (tidy_env, docs) <- findGlobals (mkVarSet inst_tvs) tidy_env
+	; return (tidy_env, mk_msg dflags docs) }
+  where
+    mk_msg _ _ | any isRuntimeUnk inst_tvs
+        =  vcat [ptext (sLit "Cannot resolve unknown runtime types:") <+>
+                   (pprWithCommas ppr inst_tvs),
+                ptext (sLit "Use :print or :force to determine these types")]
+    mk_msg _ []   = ptext (sLit "Probable fix: add a type signature that fixes these type variable(s)")
+			-- This happens in things like
+			--	f x = show (read "foo")
+			-- where monomorphism doesn't play any role
+    mk_msg dflags docs 
+	= vcat [ptext (sLit "Possible cause: the monomorphism restriction applied to the following:"),
+		nest 2 (vcat docs),
+		monomorphism_fix dflags]
+
+monomorphism_fix :: DynFlags -> SDoc
+monomorphism_fix dflags
+  = ptext (sLit "Probable fix:") <+> vcat
+	[ptext (sLit "give these definition(s) an explicit type signature"),
+	 if dopt Opt_MonomorphismRestriction dflags
+           then ptext (sLit "or use -XNoMonomorphismRestriction")
+           else empty]	-- Only suggest adding "-XNoMonomorphismRestriction"
+			-- if it is not already set!
+    
+warnDefault :: [(Inst, Class, Var)] -> Type -> TcM ()
+warnDefault ups default_ty = do
+    warn_flag <- doptM Opt_WarnTypeDefaults
+    setInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
+  where
+    dicts = [d | (d,_,_) <- ups]
+
+	-- Tidy them first
+    (_, tidy_dicts) = tidyInsts dicts
+    warn_msg  = vcat [ptext (sLit "Defaulting the following constraint(s) to type") <+>
+				quotes (ppr default_ty),
+		      pprDictsInFull tidy_dicts]
+
+reduceDepthErr :: Int -> [Inst] -> SDoc
+reduceDepthErr n stack
+  = vcat [ptext (sLit "Context reduction stack overflow; size =") <+> int n,
+	  ptext (sLit "Use -fcontext-stack=N to increase stack size to N"),
+	  nest 4 (pprStack stack)]
+
+pprStack :: [Inst] -> SDoc
+pprStack stack = vcat (map pprInstInFull stack)
+\end{code}
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 778f6e2..0744dae 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -285,9 +285,9 @@ The predicate we use is TcEnv.thTopLevelId.
 %************************************************************************
 
 \begin{code}
-tcBracket     :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
+tcBracket     :: HsBracket Name -> TcRhoType -> TcM (LHsExpr TcId)
 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
-tcSpliceExpr  :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
+tcSpliceExpr  :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
 kcSpliceType  :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind)
 	-- None of these functions add constraints to the LIE
 
@@ -339,17 +339,17 @@ tcBracket brack res_ty
 	-- but throw away the results.  We'll type check
 	-- it again when we actually use it.
        ; pending_splices <- newMutVar []
-       ; lie_var <- getLIEVar
+       ; lie_var <- getConstraintVar
        ; let brack_stage = Brack cur_stage pending_splices lie_var
 
        ; (meta_ty, lie) <- setStage brack_stage $
-                           getLIE $
+                           getConstraints $
                            tc_bracket cur_stage brack
 
-       ; tcSimplifyBracket lie
+       ; simplifyBracket lie
 
 	-- Make the expected type have the right shape
-       ; _ <- boxyUnify meta_ty res_ty
+       ; _ <- unifyType meta_ty res_ty
 
 	-- Return the original expression, not the type-decorated one
        ; pendings <- readMutVar pending_splices
@@ -394,7 +394,7 @@ tc_bracket _ (DecBrG decls)
 
 tc_bracket _ (PatBr pat)
   = do	{ any_ty <- newFlexiTyVarTy liftedTypeKind
-	; _ <- tcPat ThPatQuote pat any_ty unitTy $ \_ ->
+	; _ <- tcPat ThPatQuote pat any_ty unitTy $ 
                return ()
 	; tcMetaTy patQTyConName }
 	-- Result type is PatQ (= Q Pat)
@@ -432,10 +432,9 @@ tcSpliceExpr (HsSplice name expr) res_ty
 	-- Here (h 4) :: Q Exp
 	-- but $(h 4) :: forall a.a 	i.e. anything!
 
-     { _ <- unBox res_ty
-     ; meta_exp_ty <- tcMetaTy expQTyConName
+     { meta_exp_ty <- tcMetaTy expQTyConName
      ; expr' <- setStage pop_stage $
-                setLIEVar lie_var    $
+                setConstraintVar lie_var    $
                 tcMonoExpr expr meta_exp_ty
 
 	-- Write the pending splice into the bucket
@@ -445,7 +444,7 @@ tcSpliceExpr (HsSplice name expr) res_ty
      ; return (panic "tcSpliceExpr")	-- The returned expression is ignored
      }}}
 
-tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (HsExpr Id)
+tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id)
 -- Note [How top-level splices are handled]
 tcTopSplice expr res_ty
   = do { meta_exp_ty <- tcMetaTy expQTyConName
@@ -487,13 +486,13 @@ tcTopSpliceExpr tc_action
                    -- if the type checker fails!
     setStage Splice $ 
     do {    -- Typecheck the expression
-         (expr', lie) <- getLIE tc_action
+         (expr', lie) <- getConstraints tc_action
         
 	-- Solve the constraints
-	; const_binds <- tcSimplifyTop lie
+	; const_binds <- simplifyTop lie
 	
           -- Zonk it and tie the knot of dictionary bindings
-       ; zonkTopLExpr (mkHsDictLet const_binds expr') }
+       ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') }
 \end{code}
 
 
@@ -518,7 +517,7 @@ kcSpliceType splice@(HsSplice name hs_expr) fvs
 	   -- A splice inside brackets
     { meta_ty <- tcMetaTy typeQTyConName
     ; expr' <- setStage pop_level $
-    	       setLIEVar lie_var $
+    	       setConstraintVar lie_var $
     	       tcMonoExpr hs_expr meta_ty
 
     	-- Write the pending splice into the bucket
@@ -681,7 +680,7 @@ runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops
         ; let is_local = nameIsLocalOrFrom this_mod quoter'
         ; checkTc (not is_local) (quoteStageError quoter')
 
-	; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
+	; traceTc "runQQ" (ppr quoter <+> ppr is_local)
 
 	  -- Build the expression 
       	; let quoterExpr = L q_span $! HsVar $! quoter'
@@ -757,7 +756,7 @@ runMetaQ (MT { mt_show = show_th, mt_cvt = cvt }) expr
   where
     run_and_cvt expr_span hval
        = do { th_result <- TH.runQ hval
-            ; traceTc (text "Got TH result:" <+> text (show_th th_result))
+            ; traceTc "Got TH result:" (text (show_th th_result))
             ; return (cvt expr_span th_result) }
 
 runMetaE :: LHsExpr Id 		-- Of type (Q Exp)
@@ -779,7 +778,7 @@ runMeta :: (Outputable hs_syn)
 	-> LHsExpr Id 		-- Of type x; typically x = Q TH.Exp, or something like that
 	-> TcM hs_syn		-- Of type t
 runMeta show_code run_and_convert expr
-  = do	{ traceTc (text "About to run" <+> ppr expr)
+  = do	{ traceTc "About to run" (ppr expr)
 
 	-- Desugar
 	; ds_expr <- initDsTc (dsLExpr expr)
@@ -810,7 +809,7 @@ runMeta show_code run_and_convert expr
 	     do	{ mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
 		; case mb_result of
 		    Left err     -> failWithTc err
-		    Right result -> do { traceTc (ptext (sLit "Got HsSyn result:") <+> ppr result) 
+		    Right result -> do { traceTc "Got HsSyn result:" (ppr result) 
                                        ; return $! result } }
 
 	; case either_tval of
@@ -1020,9 +1019,9 @@ reifyThing (AGlobal (ADataCon dc))
                               (reifyName (dataConOrigTyCon dc)) fix) 
         }
 
-reifyThing (ATcId {tct_id = id, tct_type = ty}) 
-  = do	{ ty1 <- zonkTcType ty	-- Make use of all the info we have, even
-				-- though it may be incomplete
+reifyThing (ATcId {tct_id = id}) 
+  = do	{ ty1 <- zonkTcType (idType id)	-- Make use of all the info we have, even
+    					-- though it may be incomplete
 	; ty2 <- reifyType ty1
 	; fix <- reifyFixity (idName id)
 	; return (TH.VarI (reifyName id) ty2 Nothing fix) }
@@ -1041,7 +1040,7 @@ reifyTyCon tc
   = return (TH.PrimTyConI (reifyName tc) 2 		  False)
   | isPrimTyCon tc 
   = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
-  | isOpenTyCon tc
+  | isFamilyTyCon tc
   = let flavour = reifyFamFlavour tc
         tvs     = tyConTyVars tc
         kind    = tyConKind tc
@@ -1152,8 +1151,8 @@ reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
 reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
 
 reifyFamFlavour :: TyCon -> TH.FamFlavour
-reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
-                   | isOpenTyCon    tc = TH.DataFam
+reifyFamFlavour tc | isSynFamilyTyCon tc = TH.TypeFam
+                   | isFamilyTyCon    tc = TH.DataFam
                    | otherwise         
                    = panic "TcSplice.reifyFamFlavour: not a type family"
 
diff --git a/compiler/typecheck/TcSplice.lhs-boot b/compiler/typecheck/TcSplice.lhs-boot
index d8cd81b..a75ab35 100644
--- a/compiler/typecheck/TcSplice.lhs-boot
+++ b/compiler/typecheck/TcSplice.lhs-boot
@@ -6,19 +6,19 @@ import Name	( Name )
 import NameSet	( FreeVars )
 import RdrName	( RdrName )
 import TcRnTypes( TcM, TcId )
-import TcType	( BoxyRhoType, TcKind )
+import TcType	( TcRhoType, TcKind )
 import Annotations ( Annotation, CoreAnnTarget )
 import qualified Language.Haskell.TH as TH
 
 tcSpliceExpr :: HsSplice Name
-	     -> BoxyRhoType
+	     -> TcRhoType
 	     -> TcM (HsExpr TcId)
 
 kcSpliceType :: HsSplice Name -> FreeVars
 	     -> TcM (HsType Name, TcKind)
 
 tcBracket :: HsBracket Name 
-	  -> BoxyRhoType
+	  -> TcRhoType
 	  -> TcM (LHsExpr TcId)
 
 tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 8989d43..6a6304f 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -152,7 +152,7 @@ tcTyAndClassDecls boot_details allDecls
 		-- See notes with checkCycleErrs
 	; checkCycleErrs decls
 	; mod <- getModule
-	; traceTc (text "tcTyAndCl" <+> ppr mod)
+	; traceTc "tcTyAndCl" (ppr mod)
 	; (syn_tycons, alg_tyclss) <- fixM (\ ~(_rec_syn_tycons, rec_alg_tyclss) ->
 	  do	{ let {	-- Seperate ordinary synonyms from all other type and
 			-- class declarations and add all associated type
@@ -193,9 +193,9 @@ tcTyAndClassDecls boot_details allDecls
 	; tcExtendGlobalEnv (syn_tycons ++ alg_tyclss) $ do
 
 	-- Perform the validity check
-	{ traceTc (text "ready for validity check")
+	{ traceTc "ready for validity check" empty
 	; mapM_ (addLocM checkValidTyCl) decls
- 	; traceTc (text "done")
+ 	; traceTc "done" empty
    
 	-- Add the implicit things;
 	-- we want them in the environment because 
@@ -206,8 +206,9 @@ tcTyAndClassDecls boot_details allDecls
 	; let {	implicit_things = concatMap implicitTyThings alg_tyclss
 	      ; rec_sel_binds   = mkRecSelBinds alg_tyclss
               ; dm_ids          = mkDefaultMethodIds alg_tyclss }
-	; traceTc ((text "Adding" <+> ppr alg_tyclss) 
-		   $$ (text "and" <+> ppr implicit_things))
+	; traceTc "Adding types and classes" $ vcat
+                 [ ppr alg_tyclss 
+		 , text "and" <+> ppr implicit_things ]
   	; env <- tcExtendGlobalEnv implicit_things getGblEnv
 	; return (env, rec_sel_binds, dm_ids) }
     }
@@ -289,7 +290,7 @@ tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
 tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind family ->
     do { -- check that the family declaration is for a synonym
-         checkTc (isOpenTyCon family) (notFamily family)
+         checkTc (isFamilyTyCon family) (notFamily family)
        ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
 
        ; -- (1) kind check the right-hand side of the type equation
@@ -313,7 +314,8 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
          -- (4) construct representation tycon
        ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc
        ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) 
-                       (typeKind t_rhs) (Just (family, t_typats))
+                       (typeKind t_rhs) 
+                       NoParentTyCon (Just (family, t_typats))
        }}
 
   -- "newtype instance" and "data instance"
@@ -321,7 +323,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 			     tcdCons = cons})
   = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon ->
     do { -- check that the family declaration is for the right kind
-         checkTc (isOpenTyCon fam_tycon) (notFamily fam_tycon)
+         checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon)
        ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon)
 
        ; -- (1) kind check the data declaration as usual
@@ -367,7 +369,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name,
 		   NewType  -> ASSERT( not (null data_cons) )
 			       mkNewTyConRhs rep_tc_name rep_tycon (head data_cons)
 	     ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive
-			     False h98_syntax (Just (fam_tycon, t_typats))
+			     False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats))
                  -- We always assume that indexed types are recursive.  Why?
                  -- (1) Due to their open nature, we can never be sure that a
                  -- further instance might not introduce a new recursive
@@ -530,10 +532,10 @@ kcSynDecl :: SCC (LTyClDecl Name)
 kcSynDecl (AcyclicSCC (L loc decl))
   = tcAddDeclCtxt decl	$
     kcHsTyVars (tcdTyVars decl) (\ k_tvs ->
-    do { traceTc (text "kcd1" <+> ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) 
+    do { traceTc "kcd1" (ppr (unLoc (tcdLName decl)) <+> brackets (ppr (tcdTyVars decl)) 
 			<+> brackets (ppr k_tvs))
        ; (k_rhs, rhs_kind) <- kcLHsType (tcdSynRhs decl)
-       ; traceTc (text "kcd2" <+> ppr (unLoc (tcdLName decl)))
+       ; traceTc "kcd2" (ppr (unLoc (tcdLName decl)))
        ; let tc_kind = foldr (mkArrowKind . hsTyVarKind . unLoc) rhs_kind k_tvs
        ; return (L loc (decl { tcdTyVars = k_tvs, tcdSynRhs = k_rhs }),
 		 (unLoc (tcdLName decl), tc_kind)) })
@@ -684,10 +686,10 @@ tcSynDecl :: TyClDecl Name -> TcM TyThing
 tcSynDecl
   (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
   = tcTyVarBndrs tvs		$ \ tvs' -> do 
-    { traceTc (text "tcd1" <+> ppr tc_name) 
+    { traceTc "tcd1" (ppr tc_name) 
     ; rhs_ty' <- tcHsKindedType rhs_ty
     ; tycon <- buildSynTyCon tc_name tvs' (SynonymTyCon rhs_ty') 
-      	       		     (typeKind rhs_ty') Nothing
+      	       		     (typeKind rhs_ty') NoParentTyCon  Nothing
     ; return (ATyCon tycon) 
     }
 tcSynDecl d = pprPanic "tcSynDecl" (ppr d)
@@ -696,31 +698,31 @@ tcSynDecl d = pprPanic "tcSynDecl" (ppr d)
 tcTyClDecl :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
 
 tcTyClDecl calc_isrec decl
-  = tcAddDeclCtxt decl (tcTyClDecl1 calc_isrec decl)
+  = tcAddDeclCtxt decl (tcTyClDecl1 NoParentTyCon calc_isrec decl)
 
   -- "type family" declarations
-tcTyClDecl1 :: (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
-tcTyClDecl1 _calc_isrec 
+tcTyClDecl1 :: TyConParent -> (Name -> RecFlag) -> TyClDecl Name -> TcM [TyThing]
+tcTyClDecl1 parent _calc_isrec 
   (TyFamily {tcdFlavour = TypeFamily, 
 	     tcdLName = L _ tc_name, tcdTyVars = tvs,
              tcdKind = Just kind}) -- NB: kind at latest added during kind checking
   = tcTyVarBndrs tvs  $ \ tvs' -> do 
-  { traceTc (text "type family: " <+> ppr tc_name) 
+  { traceTc "type family:" (ppr tc_name) 
 
 	-- Check that we don't use families without -XTypeFamilies
   ; idx_tys <- doptM Opt_TypeFamilies
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
-  ; tycon <- buildSynTyCon tc_name tvs' (OpenSynTyCon kind Nothing) kind Nothing
+  ; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
   ; return [ATyCon tycon]
   }
 
   -- "data family" declaration
-tcTyClDecl1 _calc_isrec 
+tcTyClDecl1 parent _calc_isrec 
   (TyFamily {tcdFlavour = DataFamily, 
 	     tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
   = tcTyVarBndrs tvs  $ \ tvs' -> do 
-  { traceTc (text "data family: " <+> ppr tc_name) 
+  { traceTc "data family:" (ppr tc_name) 
   ; extra_tvs <- tcDataKindSig mb_kind
   ; let final_tvs = tvs' ++ extra_tvs    -- we may not need these
 
@@ -730,13 +732,14 @@ tcTyClDecl1 _calc_isrec
   ; checkTc idx_tys $ badFamInstDecl tc_name
 
   ; tycon <- buildAlgTyCon tc_name final_tvs [] 
-	       mkOpenDataTyConRhs Recursive False True Nothing
+               DataFamilyTyCon Recursive False True 
+               parent Nothing
   ; return [ATyCon tycon]
   }
 
   -- "newtype" and "data"
   -- NB: not used for newtype/data instances (whether associated or not)
-tcTyClDecl1 calc_isrec
+tcTyClDecl1 parent calc_isrec
   (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs,
 	   tcdLName = L _ tc_name, tcdKindSig = mb_ksig, tcdCons = cons})
   = tcTyVarBndrs tvs	$ \ tvs' -> do 
@@ -784,7 +787,8 @@ tcTyClDecl1 calc_isrec
 		   NewType  -> ASSERT( not (null data_cons) )
                                mkNewTyConRhs tc_name tycon (head data_cons)
 	; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
-	    (want_generic && canDoGenerics data_cons) (not h98_syntax) Nothing
+	    (want_generic && canDoGenerics data_cons) (not h98_syntax) 
+            parent Nothing
 	})
   ; return [ATyCon tycon]
   }
@@ -792,29 +796,27 @@ tcTyClDecl1 calc_isrec
     is_rec   = calc_isrec tc_name
     h98_syntax = consUseH98Syntax cons
 
-tcTyClDecl1 calc_isrec 
+tcTyClDecl1 _parent calc_isrec 
   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
 	      tcdCtxt = ctxt, tcdMeths = meths,
 	      tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
   = tcTyVarBndrs tvs		$ \ tvs' -> do 
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mapM (addLocM tc_fundep) fundeps
-  ; atss <- mapM (addLocM (tcTyClDecl1 (const Recursive))) ats
-            -- NB: 'ats' only contains "type family" and "data family"
-            --     declarations as well as type family defaults
-  ; let ats' = map (setAssocFamilyPermutation tvs') (concat atss)
   ; sig_stuff <- tcClassSigs class_name sigs meths
-  ; clas <- fixM (\ clas ->
-		let 	-- This little knot is just so we can get
+  ; clas <- fixM $ \ clas -> do
+	    { let 	-- This little knot is just so we can get
 			-- hold of the name of the class TyCon, which we
 			-- need to look up its recursiveness
 		    tycon_name = tyConName (classTyCon clas)
 		    tc_isrec = calc_isrec tycon_name
-		in
-		buildClass False {- Must include unfoldings for selectors -}
-			   class_name tvs' ctxt' fds' ats'
-			   sig_stuff tc_isrec)
-  ; return (AClass clas : ats')
+	    ; atss' <- mapM (addLocM $ tcTyClDecl1 (AssocFamilyTyCon clas) (const Recursive)) ats
+            -- NB: 'ats' only contains "type family" and "data family"
+            --     declarations as well as type family defaults
+            ; buildClass False {- Must include unfoldings for selectors -}
+			 class_name tvs' ctxt' fds' (concat atss')
+			 sig_stuff tc_isrec }
+  ; return (AClass clas : map ATyCon (classATs clas))
       -- NB: Order is important due to the call to `mkGlobalThings' when
       --     tying the the type and class declaration type checking knot.
   }
@@ -823,11 +825,11 @@ tcTyClDecl1 calc_isrec
 				; tvs2' <- mapM tcLookupTyVar tvs2 ;
 				; return (tvs1', tvs2') }
 
-tcTyClDecl1 _
+tcTyClDecl1 _ _
   (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name})
   = return [ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0)]
 
-tcTyClDecl1 _ d = pprPanic "tcTyClDecl1" (ppr d)
+tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d)
 
 -----------------------------------
 tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type)
@@ -1036,12 +1038,12 @@ checkValidTyCl :: TyClDecl Name -> TcM ()
 checkValidTyCl decl
   = tcAddDeclCtxt decl $
     do	{ thing <- tcLookupLocatedGlobal (tcdLName decl)
-	; traceTc (text "Validity of" <+> ppr thing)	
+	; traceTc "Validity of" (ppr thing)	
 	; case thing of
 	    ATyCon tc -> checkValidTyCon tc
 	    AClass cl -> checkValidClass cl 
             _ -> panic "checkValidTyCl"
-	; traceTc (text "Done validity of" <+> ppr thing)	
+	; traceTc "Done validity of" (ppr thing)	
 	}
 
 -------------------------
@@ -1063,8 +1065,8 @@ checkValidTyCon :: TyCon -> TcM ()
 checkValidTyCon tc 
   | isSynTyCon tc 
   = case synTyConRhs tc of
-      OpenSynTyCon _ _ -> return ()
-      SynonymTyCon ty  -> checkValidType syn_ctxt ty
+      SynFamilyTyCon {} -> return ()
+      SynonymTyCon ty   -> checkValidType syn_ctxt ty
   | otherwise
   = do	-- Check the context on the data decl
     checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)
@@ -1134,7 +1136,7 @@ checkValidDataCon :: TyCon -> DataCon -> TcM ()
 checkValidDataCon tc con
   = setSrcSpan (srcLocSpan (getSrcLoc con))	$
     addErrCtxt (dataConCtxt con)		$ 
-    do	{ traceTc (ptext (sLit "Validity of data con") <+> ppr con)
+    do	{ traceTc "Validity of data con" (ppr con)
         ; let tc_tvs = tyConTyVars tc
 	      res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)
 	      actual_res_ty = dataConOrigResTy con
@@ -1208,7 +1210,7 @@ checkValidClass cls
 		-- The 'tail' removes the initial (C a) from the
 		-- class itself, leaving just the method type
 
-	; traceTc (text "class op type" <+> ppr op_ty <+> ppr tau)
+	; traceTc "class op type" (ppr op_ty <+> ppr tau)
 	; checkValidType (FunSigCtxt op_name) tau
 
 		-- Check that the type mentions at least one of
@@ -1493,7 +1495,7 @@ genericMultiParamErr clas
 badGenericMethodType :: Name -> Kind -> SDoc
 badGenericMethodType op op_ty
   = hang (ptext (sLit "Generic method type is too complex"))
-       4 (vcat [ppr op <+> dcolon <+> ppr op_ty,
+       2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
 		ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
 
 recSynErr :: [LTyClDecl Name] -> TcRn ()
diff --git a/compiler/typecheck/TcTyFuns.lhs b/compiler/typecheck/TcTyFuns.lhs-old
similarity index 99%
rename from compiler/typecheck/TcTyFuns.lhs
rename to compiler/typecheck/TcTyFuns.lhs-old
index 0fe92e0..aa038af 100644
--- a/compiler/typecheck/TcTyFuns.lhs
+++ b/compiler/typecheck/TcTyFuns.lhs-old
@@ -66,7 +66,7 @@ then 'T [Int]' unfolds to (:R42T Int, :Co:R42T Int).
 \begin{code}
 tcUnfoldSynFamInst :: Type -> TcM (Maybe (Type, Coercion))
 tcUnfoldSynFamInst (TyConApp tycon tys)
-  | not (isOpenSynTyCon tycon)     -- unfold *only* _synonym_ family instances
+  | not (isSynFamilyTyCon tycon)     -- unfold *only* _synonym_ family instances
   = return Nothing
   | otherwise
   = do { -- The TyCon might be over-saturated, but that's ok for tcLookupFamInst
@@ -530,12 +530,12 @@ normEqInst inst
 
       -- left-to-right rule with type family head
     go ty1@(TyConApp con args) ty2 co 
-      | isOpenSynTyConApp ty1           -- only if not oversaturated
+      | isSynFamilyTyConApp ty1           -- only if not oversaturated
       = mkRewriteFam False con args ty2 co
 
       -- right-to-left rule with type family head
     go ty1 ty2@(TyConApp con args) co 
-      | isOpenSynTyConApp ty2           -- only if not oversaturated
+      | isSynFamilyTyConApp ty2           -- only if not oversaturated
       = do { co' <- mkSymEqInstCo co (ty2, ty1)
            ; mkRewriteFam True con args ty1 co'
            }
@@ -775,7 +775,7 @@ flattenType inst ty = go ty
       -- type family application & family arity matches number of args
       -- => flatten to "gamma :: F t1'..tn' ~ alpha" (alpha & gamma fresh)
     go ty@(TyConApp con args)
-      | isOpenSynTyConApp ty   -- only if not oversaturated
+      | isSynFamilyTyConApp ty   -- only if not oversaturated
       = do { (args', cargs, args_eqss) <- mapAndUnzip3M go args
            ; alpha <- newFlexiTyVar (typeKind ty)
            ; let alphaTy = mkTyVarTy alpha
@@ -797,7 +797,7 @@ flattenType inst ty = go ty
       -- datatype constructor application => flatten subtypes
       -- NB: Special cased for efficiency - could be handled as type application
     go ty@(TyConApp con args)
-      | not (isOpenSynTyCon con)   -- don't match oversaturated family apps
+      | not (isSynFamilyTyCon con)   -- don't match oversaturated family apps
       = do { (args', cargs, args_eqss) <- mapAndUnzip3M go args
            ; let args_eqs = concat args_eqss
            ; if null args_eqs
@@ -910,7 +910,7 @@ mkDictBind :: Inst                 -- original instance
            -> TcM (Inst,           -- new inst
                    TcDictBinds)    -- binding for coerced dictionary
 mkDictBind dict isWanted rewriteCo pred
-  = do { dict' <- newDictBndr loc pred
+  = do { dict' <- newCtGiven loc pred
          -- relate the old inst to the new one
          -- target_dict = source_dict `cast` st_co
        ; let (target_dict, source_dict, st_co) 
@@ -1636,6 +1636,7 @@ misMatchMsg env0 (ty_act, ty_exp)
                       empty  	              -- it should be a family
           _ -> empty
 
+
     pp_open_tc tc = ptext (sLit "NB:") <+> quotes (ppr tc) 
     	       	    <+> ptext (sLit "is a type function") <> pp_inj
 	where
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 728b0be..0025a5e 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -19,16 +19,15 @@ module TcType (
   --------------------------------
   -- Types 
   TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, 
-  TcTyVar, TcTyVarSet, TcKind, 
-
-  BoxyTyVar, BoxySigmaType, BoxyRhoType, BoxyThetaType, BoxyType,
+  TcTyVar, TcTyVarSet, TcKind, TcCoVar,
 
   --------------------------------
   -- MetaDetails
   UserTypeCtxt(..), pprUserTypeCtxt,
-  TcTyVarDetails(..), BoxInfo(..), pprTcTyVarDetails,
-  MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolTvBinding, pprSkolInfo,
-  isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isBoxyTyVar, 
+  TcTyVarDetails(..), pprTcTyVarDetails,
+  MetaDetails(Flexi, Indirect), MetaInfo(..), 
+  SkolemInfo(..), pprSkolTvBinding, pprSkolInfo,
+  isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy,
   isSigTyVar, isExistentialTyVar,  isTyConableTyVar,
   metaTvRef, 
   isFlexi, isIndirect, isRuntimeUnk, isUnk,
@@ -47,18 +46,18 @@ module TcType (
   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
   tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars,
   tcGetTyVar_maybe, tcGetTyVar,
-  tcSplitSigmaTy, tcMultiSplitSigmaTy, 
+  tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe, 
 
   ---------------------------------
   -- Predicates. 
   -- Again, newtypes are opaque
   tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
   eqKind, 
-  isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy,
+  isSigmaTy, isOverloadedTy, isRigidTy, 
   isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
   isIntegerTy, isBoolTy, isUnitTy, isCharTy,
   isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, 
-  isOpenSynTyConApp,
+  isSynFamilyTyConApp,
 
   ---------------------------------
   -- Misc type manipulators
@@ -70,12 +69,21 @@ module TcType (
   -- Predicate types  
   getClassPredTys_maybe, getClassPredTys, 
   isClassPred, isTyVarClassPred, isEqPred, 
-  mkDictTy, tcSplitPredTy_maybe, 
+  mkClassPred, mkIPPred, tcSplitPredTy_maybe, 
+  mkDictTy, evVarPred,
   isPredTy, isDictTy, isDictLikeTy,
   tcSplitDFunTy, tcSplitDFunHead, predTyUnique, 
-  mkClassPred, isInheritablePred, isIPPred, 
+  isIPPred, 
   isRefineableTy, isRefineablePred,
 
+  -- * Tidying type related things up for printing
+  tidyType,      tidyTypes,
+  tidyOpenType,  tidyOpenTypes,
+  tidyTyVarBndr, tidyFreeTyVars,
+  tidyOpenTyVar, tidyOpenTyVars,
+  tidyTopType,   tidyPred,
+  tidyKind, tidySkolemTyVar,
+
   ---------------------------------
   -- Foreign import and export
   isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool
@@ -94,6 +102,10 @@ module TcType (
   tcSplitIOType_maybe, -- :: Type -> Maybe Type  
 
   --------------------------------
+  -- Rexported from Coercion
+  typeKind,
+
+  --------------------------------
   -- Rexported from Type
   Kind, 	-- Stuff to do with kinds is insensitive to pre/post Tc
   unliftedTypeKind, liftedTypeKind, argTypeKind,
@@ -120,10 +132,6 @@ module TcType (
   isUnboxedTupleType,	-- Ditto
   isPrimitiveType, 
 
-  tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
-  tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, tidySkolemTyVar,
-  typeKind, tidyKind,
-
   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
   tcTyVarsOfType, tcTyVarsOfTypes, tcTyVarsOfPred, exactTyVarsOfType,
   exactTyVarsOfTypes, 
@@ -146,6 +154,7 @@ import VarSet
 import Type
 import Coercion
 import TyCon
+import HsExpr( HsMatchContext )
 
 -- others:
 import DynFlags
@@ -161,6 +170,7 @@ import ListSetOps
 import Outputable
 import FastString
 
+import Data.List( mapAccumL )
 import Data.IORef
 \end{code}
 
@@ -201,6 +211,7 @@ tau ::= tyvar
 
 \begin{code}
 type TcTyVar = TyVar  	-- Used only during type inference
+type TcCoVar = CoVar  	-- Used only during type inference; mutable
 type TcType = Type 	-- A TcType can have mutable type variables
 	-- Invariant on ForAllTy in TcTypes:
 	-- 	forall a. T
@@ -215,13 +226,6 @@ type TcRhoType      = TcType
 type TcTauType      = TcType
 type TcKind         = Kind
 type TcTyVarSet     = TyVarSet
-
--- These types may have boxy type variables in them
-type BoxyTyVar	    = TcTyVar
-type BoxyRhoType    = TcType	
-type BoxyThetaType  = TcThetaType	
-type BoxySigmaType  = TcType		
-type BoxyType       = TcType		
 \end{code}
 
 
@@ -268,43 +272,39 @@ TcBinds.tcInstSig, and its use_skols parameter.
 \begin{code}
 -- A TyVarDetails is inside a TyVar
 data TcTyVarDetails
-  = SkolemTv SkolemInfo			-- A skolem constant
+  = SkolemTv SkolemInfo	  -- A skolem constant
 
-  | MetaTv BoxInfo (IORef MetaDetails)
+  | FlatSkol TcType	  -- The "skolem" obtained by flattening during
+    	                  -- constraint simplification
+    
+                          -- In comments we will use the notation alpha[flat = ty]
+                          -- to represent a flattening skolem variable alpha
+                          -- identified with type ty.
 
-data BoxInfo 
-   = BoxTv	-- The contents is a (non-boxy) sigma-type
-		-- That is, this MetaTv is a "box"
-
-   | TauTv	-- The contents is a (non-boxy) tau-type
-		-- That is, this MetaTv is an ordinary unification variable
-
-   | SigTv SkolemInfo	-- A variant of TauTv, except that it should not be
-			-- unified with a type, only with a type variable
-			-- SigTvs are only distinguished to improve error messages
-			--      see Note [Signature skolems]        
-			--      The MetaDetails, if filled in, will 
-			--      always be another SigTv or a SkolemTv
-
--- INVARIANTS:
---  	A TauTv is always filled in with a tau-type, which
---	never contains any BoxTvs, nor any ForAlls 
---
---	However, a BoxTv can contain a type that contains further BoxTvs
---	Notably, when typechecking an explicit list, say [e1,e2], with
---	expected type being a box b1, we fill in b1 with (List b2), where
---	b2 is another (currently empty) box.
+  | MetaTv MetaInfo (IORef MetaDetails)
 
 data MetaDetails
-  = Flexi	        -- Flexi type variables unify to become 
-                   	-- Indirects.  
-
-  | Indirect TcType  	-- INVARIANT:
-		     	--   For a BoxTv, this type must be non-boxy
-                     	--   For a TauTv, this type must be a tau-type
-
--- Generally speaking, SkolemInfo should not contain location info
--- that is contained in the Name of the tyvar with this SkolemInfo
+  = Flexi	-- Flexi type variables unify to become Indirects  
+  | Indirect TcType
+
+data MetaInfo 
+   = TauTv	   -- This MetaTv is an ordinary unification variable
+     		   -- A TauTv is always filled in with a tau-type, which
+		   -- never contains any ForAlls 
+
+   | SigTv Name	   -- A variant of TauTv, except that it should not be
+		   -- unified with a type, only with a type variable
+		   -- SigTvs are only distinguished to improve error messages
+		   --      see Note [Signature skolems]        
+		   --      The MetaDetails, if filled in, will 
+		   --      always be another SigTv or a SkolemTv
+		   -- The Name is the name of the function from whose
+		   -- type signature we got this skolem
+
+----------------------------------
+-- SkolemInfo describes a site where 
+--   a) type variables are skolemised
+--   b) an implication constraint is generated
 data SkolemInfo
   = SigSkol UserTypeCtxt	-- A skolem that is created by instantiating
 				-- a programmer-supplied type signature
@@ -314,21 +314,26 @@ data SkolemInfo
   | ClsSkol Class	-- Bound at a class decl
   | InstSkol 		-- Bound at an instance decl
   | FamInstSkol 	-- Bound at a family instance decl
-  | PatSkol DataCon	-- An existential type variable bound by a pattern for
-	    		-- a data constructor with an existential type. E.g.
-			--	data T = forall a. Eq a => MkT a
-			-- 	f (MkT x) = ...
-			-- The pattern MkT x will allocate an existential type
-			-- variable for 'a'.  
-  | ArrowSkol 		-- An arrow form (see TcArrows)
+  | PatSkol 	        -- An existential type variable bound by a pattern for
+      DataCon           -- a data constructor with an existential type.
+      (HsMatchContext Name)	
+	     --	e.g.   data T = forall a. Eq a => MkT a
+	     --        f (MkT x) = ...
+	     -- The pattern MkT x will allocate an existential type
+	     -- variable for 'a'.  
 
-  | RuleSkol RuleName	-- The LHS of a RULE
-  | GenSkol [TcTyVar]	-- Bound when doing a subsumption check for 
-	    TcType	-- 	(forall tvs. ty)
+  | ArrowSkol 	  	-- An arrow form (see TcArrows)
+
+  | IPSkol [IPName Name]  -- Binding site of an implicit parameter
 
+  | RuleSkol RuleName	-- The LHS of a RULE
+  | GenSkol TcType	-- Bound when doing a subsumption check for ty
   | RuntimeUnkSkol      -- a type variable used to represent an unknown
                         -- runtime type (used in the GHCi debugger)
 
+  | NoScSkol		-- Used for the "self" superclass when solving
+    			-- superclasses; don't generate superclasses of me
+
   | UnkSkol		-- Unhelpful info (until I improve it)
 
 -------------------------------------
@@ -400,7 +405,7 @@ kind_var_occ = mkOccName tvName "k"
 pprTcTyVarDetails :: TcTyVarDetails -> SDoc
 -- For debugging
 pprTcTyVarDetails (SkolemTv _)         = ptext (sLit "sk")
-pprTcTyVarDetails (MetaTv BoxTv _)     = ptext (sLit "box")
+pprTcTyVarDetails (FlatSkol _)         = ptext (sLit "fsk")
 pprTcTyVarDetails (MetaTv TauTv _)     = ptext (sLit "tau")
 pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig")
 
@@ -418,29 +423,6 @@ pprUserTypeCtxt (ForSigCtxt n)  = ptext (sLit "the foreign declaration for") <+>
 pprUserTypeCtxt DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration")
 pprUserTypeCtxt SpecInstCtxt    = ptext (sLit "a SPECIALISE instance pragma")
 
-
---------------------------------
-tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar)
--- Tidy the type inside a GenSkol, preparatory to printing it
-tidySkolemTyVar env tv
-  = ASSERT( isTcTyVar tv && (isSkolemTyVar tv || isSigTyVar tv ) )
-    (env1, mkTcTyVar (tyVarName tv) (tyVarKind tv) info1)
-  where
-    (env1, info1) = case tcTyVarDetails tv of
-			SkolemTv info -> (env1, SkolemTv info')
-				where
-				  (env1, info') = tidy_skol_info env info
-			MetaTv (SigTv info) box -> (env1, MetaTv (SigTv info') box)
-				where
-				  (env1, info') = tidy_skol_info env info
-			info -> (env, info)
-
-    tidy_skol_info env (GenSkol tvs ty) = (env2, GenSkol tvs1 ty1)
-			    where
-			      (env1, tvs1) = tidyOpenTyVars env tvs
-			      (env2, ty1)  = tidyOpenType env1 ty
-    tidy_skol_info env info = (env, info)
-		     
 pprSkolTvBinding :: TcTyVar -> SDoc
 -- Print info about the binding of a skolem tyvar, 
 -- or nothing if we don't have anything useful to say
@@ -448,33 +430,38 @@ pprSkolTvBinding tv
   = ASSERT ( isTcTyVar tv )
     quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
   where
-    ppr_details (MetaTv TauTv _)   	= ptext (sLit "is a meta type variable")
-    ppr_details (MetaTv BoxTv _)   	= ptext (sLit "is a boxy type variable")
-    ppr_details (MetaTv (SigTv info) _) = ppr_skol info
-    ppr_details (SkolemTv info)		= ppr_skol info
+    ppr_details (SkolemTv info)      = ppr_skol info
+    ppr_details (FlatSkol _) 	     = ptext (sLit "is a flattening type variable")
+    ppr_details (MetaTv TauTv _)     = ptext (sLit "is a meta type variable")
+    ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for") <+> quotes (ppr n)
 
     ppr_skol UnkSkol	    = ptext (sLit "is an unknown type variable")	-- Unhelpful
     ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type")
     ppr_skol info           = sep [ptext (sLit "is a rigid type variable bound by"),
 				   sep [pprSkolInfo info, 
-					 nest 2 (ptext (sLit "at") <+> ppr (getSrcLoc tv))]]
+					nest 2 (ptext (sLit "at") <+> ppr (getSrcLoc tv))]]
  
 pprSkolInfo :: SkolemInfo -> SDoc
-pprSkolInfo (SigSkol ctxt)   = pprUserTypeCtxt ctxt
-pprSkolInfo (ClsSkol cls)    = ptext (sLit "the class declaration for") <+> quotes (ppr cls)
-pprSkolInfo InstSkol         = ptext (sLit "the instance declaration")
-pprSkolInfo FamInstSkol      = ptext (sLit "the family instance declaration")
-pprSkolInfo (RuleSkol name)  = ptext (sLit "the RULE") <+> doubleQuotes (ftext name)
-pprSkolInfo ArrowSkol        = ptext (sLit "the arrow form")
-pprSkolInfo (PatSkol dc)     = sep [ptext (sLit "the constructor") <+> quotes (ppr dc)]
-pprSkolInfo (GenSkol tvs ty) = sep [ptext (sLit "the polymorphic type"), 
-				    nest 2 (quotes (ppr (mkForAllTys tvs ty)))]
+-- Complete the sentence "is a rigid type variable bound by..."
+pprSkolInfo (SigSkol ctxt)  = pprUserTypeCtxt ctxt
+pprSkolInfo (IPSkol ips)    = ptext (sLit "the implicit-parameter bindings for")
+                              <+> pprWithCommas ppr ips
+pprSkolInfo (ClsSkol cls)   = ptext (sLit "the class declaration for") <+> quotes (ppr cls)
+pprSkolInfo InstSkol        = ptext (sLit "the instance declaration")
+pprSkolInfo NoScSkol        = ptext (sLit "the instance declaration (self)")
+pprSkolInfo FamInstSkol     = ptext (sLit "the family instance declaration")
+pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> doubleQuotes (ftext name)
+pprSkolInfo ArrowSkol       = ptext (sLit "the arrow form")
+pprSkolInfo (PatSkol dc _)  = sep [ ptext (sLit "a pattern with constructor")
+                                    , ppr dc <+> dcolon <+> ppr (dataConUserType dc) ]
+pprSkolInfo (GenSkol ty)    = sep [ ptext (sLit "the polymorphic type")
+			    	  , quotes (ppr ty) ]
 
 -- UnkSkol
 -- For type variables the others are dealt with by pprSkolTvBinding.  
 -- For Insts, these cases should not happen
-pprSkolInfo UnkSkol = panic "UnkSkol"
-pprSkolInfo RuntimeUnkSkol = panic "RuntimeUnkSkol"
+pprSkolInfo UnkSkol        = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol")
+pprSkolInfo RuntimeUnkSkol = WARN( True, text "pprSkolInfo: RuntimeUnkSkol" ) ptext (sLit "RuntimeUnkSkol")
 
 instance Outputable MetaDetails where
   ppr Flexi         = ptext (sLit "Flexi")
@@ -484,6 +471,129 @@ instance Outputable MetaDetails where
 
 %************************************************************************
 %*									*
+\subsection{TidyType}
+%*									*
+%************************************************************************
+
+\begin{code}
+-- | This tidies up a type for printing in an error message, or in
+-- an interface file.
+-- 
+-- It doesn't change the uniques at all, just the print names.
+tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
+tidyTyVarBndr env@(tidy_env, subst) tyvar
+  = case tidyOccName tidy_env (getOccName name) of
+      (tidy', occ') -> ((tidy', subst'), tyvar'')
+	where
+	  subst' = extendVarEnv subst tyvar tyvar''
+	  tyvar' = setTyVarName tyvar name'
+	  name'  = tidyNameOcc name occ'
+		-- Don't forget to tidy the kind for coercions!
+	  tyvar'' | isCoVar tyvar = setTyVarKind tyvar' kind'
+		  | otherwise	  = tyvar'
+	  kind'  = tidyType env (tyVarKind tyvar)
+  where
+    name = tyVarName tyvar
+
+---------------
+tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
+-- ^ Add the free 'TyVar's to the env in tidy form,
+-- so that we can tidy the type they are free in
+tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars))
+
+---------------
+tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
+tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars
+
+---------------
+tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
+-- ^ Treat a new 'TyVar' as a binder, and give it a fresh tidy name
+-- using the environment if one has not already been allocated. See
+-- also 'tidyTyVarBndr'
+tidyOpenTyVar env@(_, subst) tyvar
+  = case lookupVarEnv subst tyvar of
+	Just tyvar' -> (env, tyvar')		-- Already substituted
+	Nothing	    -> tidyTyVarBndr env tyvar	-- Treat it as a binder
+
+---------------
+tidyType :: TidyEnv -> Type -> Type
+tidyType env@(_, subst) ty
+  = go ty
+  where
+    go (TyVarTy tv)	    = case lookupVarEnv subst tv of
+				Nothing  -> expand tv
+				Just tv' -> expand tv'
+    go (TyConApp tycon tys) = let args = map go tys
+			      in args `seqList` TyConApp tycon args
+    go (PredTy sty)	    = PredTy (tidyPred env sty)
+    go (AppTy fun arg)	    = (AppTy $! (go fun)) $! (go arg)
+    go (FunTy fun arg)	    = (FunTy $! (go fun)) $! (go arg)
+    go (ForAllTy tv ty)	    = ForAllTy tvp $! (tidyType envp ty)
+			      where
+			        (envp, tvp) = tidyTyVarBndr env tv
+
+    -- Expand FlatSkols, the skolems introduced by flattening process
+    -- We don't want to show them in type error messages
+    expand tv | isTcTyVar tv
+              , FlatSkol ty <- tcTyVarDetails tv
+              = go ty
+              | otherwise
+              = TyVarTy tv
+
+---------------
+tidyTypes :: TidyEnv -> [Type] -> [Type]
+tidyTypes env tys = map (tidyType env) tys
+
+---------------
+tidyPred :: TidyEnv -> PredType -> PredType
+tidyPred env (IParam n ty)     = IParam n (tidyType env ty)
+tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
+tidyPred env (EqPred ty1 ty2)  = EqPred (tidyType env ty1) (tidyType env ty2)
+
+---------------
+-- | Grabs the free type variables, tidies them
+-- and then uses 'tidyType' to work over the type itself
+tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
+tidyOpenType env ty
+  = (env', tidyType env' ty)
+  where
+    env' = tidyFreeTyVars env (tyVarsOfType ty)
+
+---------------
+tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
+tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
+
+---------------
+-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)
+tidyTopType :: Type -> Type
+tidyTopType ty = tidyType emptyTidyEnv ty
+
+---------------
+tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar)
+-- Tidy the type inside a GenSkol, preparatory to printing it
+tidySkolemTyVar env tv
+  = ASSERT( isTcTyVar tv && (isSkolemTyVar tv || isSigTyVar tv ) )
+    (env1, mkTcTyVar (tyVarName tv) (tyVarKind tv) info1)
+  where
+    (env1, info1) = case tcTyVarDetails tv of
+			SkolemTv info -> (env1, SkolemTv info')
+				where
+				  (env1, info') = tidy_skol_info env info
+			info -> (env, info)
+
+    tidy_skol_info env (GenSkol ty) = (env1, GenSkol ty1)
+			    where
+			      (env1, ty1)  = tidyOpenType env ty
+    tidy_skol_info env info = (env, info)
+
+---------------
+tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
+tidyKind env k = tidyOpenType env k
+\end{code}
+
+
+%************************************************************************
+%*									*
 		Predicates
 %*									*
 %************************************************************************
@@ -496,7 +606,7 @@ isImmutableTyVar tv
   | otherwise    = True
 
 isTyConableTyVar, isSkolemTyVar, isExistentialTyVar, 
-  isBoxyTyVar, isMetaTyVar :: TcTyVar -> Bool 
+  isMetaTyVar :: TcTyVar -> Bool 
 
 isTyConableTyVar tv	
 	-- True of a meta-type variable that can be filled in 
@@ -504,16 +614,15 @@ isTyConableTyVar tv
 	-- not a SigTv
   = ASSERT( isTcTyVar tv) 
     case tcTyVarDetails tv of
-	MetaTv BoxTv      _ -> True
-	MetaTv TauTv      _ -> True
-	MetaTv (SigTv {}) _ -> False
-	SkolemTv {}	    -> False
+	MetaTv TauTv _ -> True
+	_              -> False
 	
 isSkolemTyVar tv 
   = ASSERT2( isTcTyVar tv, ppr tv )
     case tcTyVarDetails tv of
-	SkolemTv _         -> True
- 	MetaTv _ _         -> False
+	SkolemTv {} -> True
+        FlatSkol {} -> True
+ 	MetaTv {}   -> False
 
 isExistentialTyVar tv 	-- Existential type variable, bound by a pattern
   = ASSERT( isTcTyVar tv )
@@ -527,11 +636,9 @@ isMetaTyVar tv
 	MetaTv _ _ -> True
 	_          -> False
 
-isBoxyTyVar tv 
-  = ASSERT( isTcTyVar tv )
-    case tcTyVarDetails tv of
-	MetaTv BoxTv _ -> True
-	_              -> False
+isMetaTyVarTy :: TcType -> Bool
+isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv
+isMetaTyVarTy _            = False
 
 isSigTyVar :: Var -> Bool
 isSigTyVar tv 
@@ -585,8 +692,7 @@ mkPhiTy theta ty = foldr (\p r -> mkFunTy (mkPredTy p) r) ty theta
 \begin{code}
 isTauTy :: Type -> Bool
 isTauTy ty | Just ty' <- tcView ty = isTauTy ty'
-isTauTy (TyVarTy tv)	 = ASSERT( not (isTcTyVar tv && isBoxyTyVar tv) )
-			   True
+isTauTy (TyVarTy _)	  = True
 isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc
 isTauTy (AppTy a b)	  = isTauTy a && isTauTy b
 isTauTy (FunTy a b)	  = isTauTy a && isTauTy b
@@ -601,9 +707,6 @@ isTauTyCon tc
   | otherwise           = True
 
 ---------------
-isBoxyTy :: TcType -> Bool
-isBoxyTy ty = any isBoxyTyVar (varSetElems (tcTyVarsOfType ty))
-
 isRigidTy :: TcType -> Bool
 -- A type is rigid if it has no meta type variables in it
 isRigidTy ty = all isImmutableTyVar (varSetElems (tcTyVarsOfType ty))
@@ -686,22 +789,21 @@ tcSplitSigmaTy ty = case tcSplitForAllTys ty of
 					(theta, tau) -> (tvs, theta, tau)
 
 -----------------------
-tcMultiSplitSigmaTy
-	:: TcSigmaType
-	-> ( [([TyVar], ThetaType)],	-- forall as.C => forall bs.D
-	     TcSigmaType)		-- The rest of the type
-
--- We need a loop here because we are now prepared to entertain
--- types like
--- 	f:: forall a. Eq a => forall b. Baz b => tau
--- We want to instantiate this to
--- 	f2::tau		{f2 = f1 b (Baz b), f1 = f a (Eq a)}
-
-tcMultiSplitSigmaTy sigma
-  = case (tcSplitSigmaTy sigma) of
-	([], [], _) -> ([], sigma)
-	(tvs, theta, ty) -> case tcMultiSplitSigmaTy ty of
-				(pairs, rest) -> ((tvs,theta):pairs, rest)
+tcDeepSplitSigmaTy_maybe
+  :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType)
+-- Looks for a *non-trivial* quantified type, under zero or more function arrows
+-- By "non-trivial" we mean either tyvars or constraints are non-empty
+
+tcDeepSplitSigmaTy_maybe ty
+  | Just (arg_ty, res_ty)           <- tcSplitFunTy_maybe ty
+  , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty
+  = Just (arg_ty:arg_tys, tvs, theta, rho)
+
+  | (tvs, theta, rho) <- tcSplitSigmaTy ty
+  , not (null tvs && null theta)
+  = Just ([], tvs, theta, rho)
+
+  | otherwise = Nothing
 
 -----------------------
 tcTyConAppTyCon :: Type -> TyCon
@@ -864,6 +966,12 @@ tcInstHeadTyAppAllTyVars ty
 %************************************************************************
 
 \begin{code}
+evVarPred :: EvVar -> PredType
+evVarPred var
+  = case tcSplitPredTy_maybe (varType var) of
+      Just pred -> pred
+      Nothing   -> pprPanic "evVarPred" (ppr var <+> ppr (varType var))
+
 tcSplitPredTy_maybe :: Type -> Maybe PredType
    -- Returns Just for predicates only
 tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty'
@@ -902,6 +1010,8 @@ getClassPredTys _ = panic "getClassPredTys"
 mkDictTy :: Class -> [Type] -> Type
 mkDictTy clas tys = mkPredTy (ClassP clas tys)
 
+
+
 isDictLikeTy :: Type -> Bool
 -- Note [Dictionary-like types]
 isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty'
@@ -943,22 +1053,12 @@ constraints build tuples.
 --------------------- Implicit parameters ---------------------------------
 
 \begin{code}
+mkIPPred :: IPName Name -> Type -> PredType
+mkIPPred ip ty = IParam ip ty
+
 isIPPred :: PredType -> Bool
 isIPPred (IParam _ _) = True
 isIPPred _            = False
-
-isInheritablePred :: PredType -> Bool
--- Can be inherited by a context.  For example, consider
---	f x = let g y = (?v, y+x)
---	      in (g 3 with ?v = 8, 
---		  g 4 with ?v = 9)
--- The point is that g's type must be quantifed over ?v:
---	g :: (?v :: a) => a -> a
--- but it doesn't need to be quantified over the Num a dictionary
--- which can be free in g's rhs, and shared by both calls to g
-isInheritablePred (ClassP _ _) = True
-isInheritablePred (EqPred _ _) = True
-isInheritablePred _            = False
 \end{code}
 
 --------------------- Equality predicates ---------------------------------
@@ -988,7 +1088,7 @@ isSigmaTy _              = False
 
 isOverloadedTy :: Type -> Bool
 -- Yes for a type of a function that might require evidence-passing
--- Used only by bindInstsOfLocalFuns/Pats
+-- Used only by bindLocalMethods
 -- NB: be sure to check for type with an equality predicate; hence isCoVar
 isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
 isOverloadedTy (ForAllTy tv ty) = isCoVar tv || isOverloadedTy ty
@@ -1031,10 +1131,10 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of
 -- NB: Currently used in places where we have already expanded type synonyms;
 --     hence no 'coreView'.  This could, however, be changed without breaking
 --     any code.
-isOpenSynTyConApp :: TcTauType -> Bool
-isOpenSynTyConApp (TyConApp tc tys) = isOpenSynTyCon tc && 
+isSynFamilyTyConApp :: TcTauType -> Bool
+isSynFamilyTyConApp (TyConApp tc tys) = isSynFamilyTyCon tc && 
                                       length tys == tyConArity tc 
-isOpenSynTyConApp _other            = False
+isSynFamilyTyConApp _other            = False
 \end{code}
 
 
@@ -1185,7 +1285,7 @@ tcSplitIOType_maybe ty
 
 	Just (io_tycon, [io_res_ty]) 
 	   |  io_tycon `hasKey` ioTyConKey 
-	   -> Just (io_tycon, io_res_ty, IdCo)
+	   -> Just (io_tycon, io_res_ty, IdCo ty)
 
 	Just (tc, tys)
 	   | not (isRecursiveTyCon tc)
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index d1ea6c0..3360f5d 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -8,19 +8,21 @@ Type subsumption and unification
 \begin{code}
 module TcUnify (
         -- Full-blown subsumption
-  tcSubExp, tcGen,
-  checkSigTyVars, checkSigTyVarsWrt, bleatEscapedTvs, sigCtxt,
+  tcWrapResult, tcSubType, tcGen, 
+  checkConstraints, newImplication, sigCtxt,
 
         -- Various unifications
-  unifyType, unifyTypeList, unifyTheta,
-  unifyKind, unifyKinds, unifyFunKind,
-  preSubType, boxyMatchTypes,
+  unifyType, unifyTypeList, unifyTheta, unifyKind, 
+
+        -- Occurs check error 
+  typeExtraInfoMsg, emitMisMatchErr,
 
   --------------------------------
   -- Holes
-  tcInfer, subFunTys, unBox, refineBox, refineBoxToTau, withBox,
-  boxyUnify, boxyUnifyList, zapToMonotype,
-  boxySplitListTy, boxySplitPArrTy, boxySplitTyConApp, boxySplitAppTy,
+  tcInfer, 
+  matchExpectedListTy, matchExpectedPArrTy, 
+  matchExpectedTyConApp, matchExpectedAppTy, 
+  matchExpectedFunTys, matchExpectedFunKind,
   wrapFunResCoercion
   ) where
 
@@ -29,16 +31,14 @@ module TcUnify (
 import HsSyn
 import TypeRep
 
+import TcErrors	( typeExtraInfoMsg )
 import TcMType
-import TcSimplify
 import TcEnv
-import TcTyFuns
 import TcIface
-import TcRnMonad         -- TcType, amongst others
+import TcRnMonad
 import TcType
 import Type
 import Coercion
-import TysPrim
 import Inst
 import TyCon
 import TysWiredIn
@@ -47,8 +47,8 @@ import VarSet
 import VarEnv
 import Name
 import ErrUtils
-import Maybes
 import BasicTypes
+import Bag
 import Util
 import Outputable
 import FastString
@@ -56,46 +56,24 @@ import FastString
 import Control.Monad
 \end{code}
 
-%************************************************************************
-%*                                                                      *
-\subsection{'hole' type variables}
-%*                                                                      *
-%************************************************************************
-
-\begin{code}
-tcInfer :: (BoxyType -> TcM a) -> TcM (a, TcType)
-tcInfer tc_infer = withBox openTypeKind tc_infer
-\end{code}
-
 
 %************************************************************************
 %*                                                                      *
-        subFunTys
+             matchExpected functions
 %*                                                                      *
 %************************************************************************
 
-\begin{code}
-subFunTys :: SDoc  -- Something like "The function f has 3 arguments"
-                   -- or "The abstraction (\x.e) takes 1 argument"
-          -> Arity              -- Expected # of args
-          -> BoxySigmaType      -- res_ty
-	  -> Maybe UserTypeCtxt	-- Whether res_ty arises from a user signature
-	     	   		-- Only relevant if we encounter a sigma-type
-          -> ([BoxySigmaType] -> BoxyRhoType -> TcM a)
-          -> TcM (HsWrapper, a)
--- Attempt to decompse res_ty to have enough top-level arrows to
--- match the number of patterns in the match group
---
--- If (subFunTys n_args res_ty thing_inside) = (co_fn, res)
--- and the inner call to thing_inside passes args: [a1,...,an], b
--- then co_fn :: (a1 -> ... -> an -> b) ~ res_ty
---
--- Note that it takes a BoxyRho type, and guarantees to return a BoxyRhoType
-
+Note [Herald for matchExpectedFunTys]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The 'herald' always looks like:
+   "The equation(s) for 'f' have"
+   "The abstraction (\x.e) takes"
+   "The section (+ x) expects"
+   "The function 'f' is applied to"
 
-{-      Error messages from subFunTys
+This is used to construct a message of form
 
-   The abstraction `\Just 1 -> ...' has two arguments
+   The abstraction `\Just 1 -> ...' takes two arguments
    but its type `Maybe a -> a' has only one
 
    The equation(s) for `f' have two arguments
@@ -106,573 +84,200 @@ subFunTys :: SDoc  -- Something like "The function f has 3 arguments"
 
    The function 'f' is applied to two arguments
    but its type `Int -> Int' has only one
--}
 
+Note [matchExpectedFunTys]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+matchExpectedFunTys checks that an (Expected rho) has the form
+of an n-ary function.  It passes the decomposed type to the
+thing_inside, and returns a wrapper to coerce between the two types
+
+It's used wherever a language construct must have a functional type,
+namely:
+	A lambda expression
+	A function definition
+     An operator section
+
+This is not (currently) where deep skolemisation occurs;
+matchExpectedFunTys does not skolmise nested foralls in the 
+expected type, becuase it expects that to have been done already
 
-subFunTys error_herald n_pats res_ty mb_ctxt thing_inside
-  = loop n_pats [] res_ty
-  where
-        -- In 'loop', the parameter 'arg_tys' accumulates
-        -- the arg types so far, in *reverse order*
-        -- INVARIANT:   res_ty :: *
-    loop n args_so_far res_ty
-        | Just res_ty' <- tcView res_ty  = loop n args_so_far res_ty'
-
-    loop n args_so_far res_ty
-        | isSigmaTy res_ty      -- Do this before checking n==0, because we
-                                -- guarantee to return a BoxyRhoType, not a
-                                -- BoxySigmaType
-        = do { (gen_fn, (co_fn, res)) <- tcGen res_ty emptyVarSet mb_ctxt $ \ _ res_ty ->
-                                         loop n args_so_far res_ty
-             ; return (gen_fn <.> co_fn, res) }
-
-    loop 0 args_so_far res_ty
-        = do { res <- thing_inside (reverse args_so_far) res_ty
-             ; return (idHsWrapper, res) }
-
-    loop n args_so_far (FunTy arg_ty res_ty)
-        = do { (co_fn, res) <- loop (n-1) (arg_ty:args_so_far) res_ty
-             ; co_fn' <- wrapFunResCoercion [arg_ty] co_fn
-             ; return (co_fn', res) }
-
-        -- Try to normalise synonym families and defer if that's not possible
-    loop n args_so_far ty@(TyConApp tc _)
-        | isOpenSynTyCon tc
-        = do { (coi1, ty') <- tcNormaliseFamInst ty
-             ; case coi1 of
-                 IdCo   -> defer n args_so_far ty
-                                    -- no progress, but maybe solvable => defer
-                 ACo _  ->          -- progress: so lets try again
-                   do { (co_fn, res) <- loop n args_so_far ty'
-                      ; return $ (co_fn <.> coiToHsWrapper (mkSymCoI coi1), res)
-                      }
-             }
-
-        -- res_ty might have a type variable at the head, such as (a b c),
-        -- in which case we must fill in with (->).  Simplest thing to do
-        -- is to use boxyUnify, but we catch failure and generate our own
-        -- error message on failure
-    loop n args_so_far res_ty@(AppTy _ _)
-        = do { [arg_ty',res_ty'] <- newBoxyTyVarTys [argTypeKind, openTypeKind]
-             ; (_, mb_coi) <- tryTcErrs $
-                                boxyUnify res_ty (FunTy arg_ty' res_ty')
-             ; if isNothing mb_coi then bale_out args_so_far
-               else do { let coi = expectJust "subFunTys" mb_coi
-                       ; (co_fn, res) <- loop n args_so_far (FunTy arg_ty'
-                                                                   res_ty')
-                       ; return (co_fn <.> coiToHsWrapper coi, res)
-                       }
-             }
-
-    loop n args_so_far ty@(TyVarTy tv)
-        | isTyConableTyVar tv
-        = do { cts <- readMetaTyVar tv
-             ; case cts of
-                 Indirect ty -> loop n args_so_far ty
-                 Flexi ->
-                   do { (res_ty:arg_tys) <- withMetaTvs tv kinds mk_res_ty
-                      ; res <- thing_inside (reverse args_so_far ++ arg_tys)
-                                            res_ty
-                      ; return (idHsWrapper, res) } }
-        | otherwise             -- defer as tyvar may be refined by equalities
-        = defer n args_so_far ty
-        where
-          mk_res_ty (res_ty' : arg_tys') = mkFunTys arg_tys' res_ty'
-          mk_res_ty [] = panic "TcUnify.mk_res_ty1"
-          kinds = openTypeKind : take n (repeat argTypeKind)
-                -- Note argTypeKind: the args can have an unboxed type,
-                -- but not an unboxed tuple.
-
-    loop _ args_so_far _ = bale_out args_so_far
-
-         -- Build a template type a1 -> ... -> an -> b and defer an equality
-         -- between that template and the expected result type res_ty; then,
-         -- use the template to type the thing_inside
-    defer n args_so_far ty
-      = do { arg_tys <- newFlexiTyVarTys n argTypeKind
-           ; res_ty' <- newFlexiTyVarTy openTypeKind
-           ; let fun_ty = mkFunTys arg_tys res_ty'
-                 err    = error_herald <> comma $$
-                          text "which does not match its type"
-           ; coi <- addErrCtxt err $
-                    defer_unification (Unify False fun_ty ty) False fun_ty ty
-           ; res <- thing_inside (reverse args_so_far ++ arg_tys) res_ty'
-           ; return (coiToHsWrapper coi, res)
-           }
-
-    bale_out args_so_far
-        = do { env0 <- tcInitTidyEnv
-             ; res_ty' <- zonkTcType res_ty
-             ; let (env1, res_ty'') = tidyOpenType env0 res_ty'
-             ; failWithTcM (env1, mk_msg res_ty'' (length args_so_far)) }
-
-    mk_msg res_ty n_actual
-      = error_herald <> comma $$
-        sep [ptext (sLit "but its type") <+> quotes (pprType res_ty),
-             if n_actual == 0 then ptext (sLit "has none")
-             else ptext (sLit "has only") <+> speakN n_actual]
-\end{code}
 
 \begin{code}
-----------------------
-boxySplitTyConApp :: TyCon                      -- T :: k1 -> ... -> kn -> *
-                  -> BoxyRhoType                -- Expected type (T a b c)
-                  -> TcM ([BoxySigmaType],      -- Element types, a b c
-                          CoercionI)            -- T a b c ~ orig_ty
-  -- It's used for wired-in tycons, so we call checkWiredInTyCon
-  -- Precondition: never called with FunTyCon
-  -- Precondition: input type :: *
-
-boxySplitTyConApp tc orig_ty
-  = do  { checkWiredInTyCon tc
-        ; loop (tyConArity tc) [] orig_ty }
+matchExpectedFunTys :: SDoc 	-- See Note [Herald for matchExpectedFunTys]
+            	    -> Arity
+            	    -> TcRhoType 
+            	    -> TcM (CoercionI, [TcSigmaType], TcRhoType)	 		
+
+-- If    matchExpectFunTys n ty = (co, [t1,..,tn], ty_r)
+-- then  co : ty ~ (t1 -> ... -> tn -> ty_r)
+--
+-- Does not allocate unnecessary meta variables: if the input already is 
+-- a function, we just take it apart.  Not only is this efficient, 
+-- it's important for higher rank: the argument might be of form
+--		(forall a. ty) -> other
+-- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd
+-- hide the forall inside a meta-variable
+
+matchExpectedFunTys herald arity orig_ty 
+  = go arity orig_ty
   where
-    loop n_req args_so_far ty
-      | Just ty' <- tcView ty = loop n_req args_so_far ty'
+    -- If     go n ty = (co, [t1,..,tn], ty_r)
+    -- then   co : ty ~ t1 -> .. -> tn -> ty_r
 
-    loop n_req args_so_far ty@(TyConApp tycon args)
-      | tc == tycon
-      = ASSERT( n_req == length args)   -- ty::*
-        return (args ++ args_so_far, IdCo)
-
-      | isOpenSynTyCon tycon        -- try to normalise type family application
-      = do { (coi1, ty') <- tcNormaliseFamInst ty
-           ; traceTc $ text "boxySplitTyConApp:" <+>
-                       ppr ty <+> text "==>" <+> ppr ty'
-           ; case coi1 of
-               IdCo   -> defer    -- no progress, but maybe solvable => defer
-               ACo _  ->          -- progress: so lets try again
-                 do { (args, coi2) <- loop n_req args_so_far ty'
-                    ; return $ (args, coi2 `mkTransCoI` mkSymCoI coi1)
-                    }
-           }
-
-    loop n_req args_so_far (AppTy fun arg)
-      | n_req > 0
-      = do { (args, coi) <- loop (n_req - 1) (arg:args_so_far) fun
-           ; return (args, mkAppTyCoI fun coi arg IdCo)
-           }
+    go n_req ty
+      | n_req == 0 = return (IdCo ty, [], ty)
 
-    loop n_req args_so_far (TyVarTy tv)
-      | isTyConableTyVar tv
-      , res_kind `isSubKind` tyVarKind tv
-      = do { cts <- readMetaTyVar tv
-           ; case cts of
-               Indirect ty -> loop n_req args_so_far ty
-               Flexi       -> do { arg_tys <- withMetaTvs tv arg_kinds mk_res_ty
-                                 ; return (arg_tys ++ args_so_far, IdCo) }
-           }
-      | otherwise             -- defer as tyvar may be refined by equalities
-      = defer
-      where
-        (arg_kinds, res_kind) = splitKindFunTysN n_req (tyConKind tc)
+    go n_req ty
+      | Just ty' <- tcView ty = go n_req ty'
 
-    loop _ _ _ = boxySplitFailure (mkTyConApp tc (mkTyVarTys (tyConTyVars tc)))
-                                  orig_ty
+    go n_req (FunTy arg_ty res_ty)
+      | not (isPredTy arg_ty) 
+      = do { (coi, tys, ty_r) <- go (n_req-1) res_ty
+           ; return (mkFunTyCoI (IdCo arg_ty) coi, arg_ty:tys, ty_r) }
 
-    -- defer splitting by generating an equality constraint
-    defer = boxySplitDefer arg_kinds mk_res_ty orig_ty
-      where
-        (arg_kinds, _) = splitKindFunTys (tyConKind tc)
+    go _ (TyConApp tc _)	      -- A common case
+      | not (isSynFamilyTyCon tc)
+      = do { (env,msg) <- mk_ctxt emptyTidyEnv
+           ; failWithTcM (env,msg) }
+
+    go n_req ty@(TyVarTy tv)
+      | ASSERT( isTcTyVar tv) isMetaTyVar tv
+      = do { cts <- readMetaTyVar tv
+	   ; case cts of
+	       Indirect ty' -> go n_req ty'
+	       Flexi        -> defer n_req ty }
+
+       -- In all other cases we bale out into ordinary unification
+    go n_req ty = defer n_req ty
+
+    ------------
+    defer n_req fun_ty 
+      = addErrCtxtM mk_ctxt $
+        do { arg_tys <- newFlexiTyVarTys n_req argTypeKind
+           ; res_ty  <- newFlexiTyVarTy openTypeKind
+           ; coi     <- unifyType fun_ty (mkFunTys arg_tys res_ty)
+           ; return (coi, arg_tys, res_ty) }
+
+    ------------
+    mk_ctxt :: TidyEnv -> TcM (TidyEnv, Message)
+    mk_ctxt env = do { orig_ty1 <- zonkTcType orig_ty
+                     ; let (env', orig_ty2) = tidyOpenType env orig_ty1
+                           (args, _) = tcSplitFunTys orig_ty2
+                           n_actual = length args
+                     ; return (env', mk_msg orig_ty2 n_actual) }
+
+    mk_msg ty n_args
+      = herald <+> speakNOf arity (ptext (sLit "argument")) <> comma $$ 
+	sep [ptext (sLit "but its type") <+> quotes (pprType ty), 
+	     if n_args == 0 then ptext (sLit "has none") 
+	     else ptext (sLit "has only") <+> speakN n_args]
+\end{code}
 
-    -- apply splitted tycon to arguments
-    mk_res_ty = mkTyConApp tc
 
+\begin{code}
 ----------------------
-boxySplitListTy :: BoxyRhoType -> TcM (BoxySigmaType, CoercionI)
+matchExpectedListTy :: TcRhoType -> TcM (CoercionI, TcRhoType)
 -- Special case for lists
-boxySplitListTy exp_ty
- = do { ([elt_ty], coi) <- boxySplitTyConApp listTyCon exp_ty
-      ; return (elt_ty, coi) }
+matchExpectedListTy exp_ty
+ = do { (coi, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty
+      ; return (coi, elt_ty) }
 
 ----------------------
-boxySplitPArrTy :: BoxyRhoType -> TcM (BoxySigmaType, CoercionI)
+matchExpectedPArrTy :: TcRhoType -> TcM (CoercionI, TcRhoType)
 -- Special case for parrs
-boxySplitPArrTy exp_ty
-  = do { ([elt_ty], coi) <- boxySplitTyConApp parrTyCon exp_ty
-       ; return (elt_ty, coi) }
+matchExpectedPArrTy exp_ty
+  = do { (coi, [elt_ty]) <- matchExpectedTyConApp parrTyCon exp_ty
+       ; return (coi, elt_ty) }
 
 ----------------------
-boxySplitAppTy :: BoxyRhoType                           -- Type to split: m a
-               -> TcM ((BoxySigmaType, BoxySigmaType),  -- Returns m, a
-                       CoercionI)
--- If the incoming type is a mutable type variable of kind k, then
--- boxySplitAppTy returns a new type variable (m: * -> k); note the *.
--- If the incoming type is boxy, then so are the result types; and vice versa
-
-boxySplitAppTy orig_ty
-  = loop orig_ty
+matchExpectedTyConApp :: TyCon                -- T :: k1 -> ... -> kn -> *
+                      -> TcRhoType 	      -- orig_ty
+                      -> TcM (CoercionI,      -- T a b c ~ orig_ty
+                              [TcSigmaType])  -- Element types, a b c
+                              
+-- It's used for wired-in tycons, so we call checkWiredInTyCon
+-- Precondition: never called with FunTyCon
+-- Precondition: input type :: *
+
+matchExpectedTyConApp tc orig_ty
+  = do  { checkWiredInTyCon tc
+        ; go (tyConArity tc) orig_ty [] }
   where
-    loop ty
-      | Just ty' <- tcView ty = loop ty'
+    go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (CoercionI, [TcSigmaType])
+    -- If     go n ty tys = (co, [t1..tn] ++ tys)
+    -- then   co : T t1..tn ~ ty
 
-    loop ty
-      | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
-      = return ((fun_ty, arg_ty), IdCo)
-
-    loop ty@(TyConApp tycon _args)
-      | isOpenSynTyCon tycon        -- try to normalise type family application
-      = do { (coi1, ty') <- tcNormaliseFamInst ty
-           ; case coi1 of
-               IdCo   -> defer    -- no progress, but maybe solvable => defer
-               ACo _ ->          -- progress: so lets try again
-                 do { (args, coi2) <- loop ty'
-                    ; return $ (args, coi2 `mkTransCoI` mkSymCoI coi1)
-                    }
-           }
-
-    loop (TyVarTy tv)
-      | isTyConableTyVar tv
+    go n_req ty tys
+      | Just ty' <- tcView ty = go n_req ty' tys
+
+    go n_req ty@(TyVarTy tv) tys
+      | ASSERT( isTcTyVar tv) isMetaTyVar tv
       = do { cts <- readMetaTyVar tv
            ; case cts of
-               Indirect ty -> loop ty
-               Flexi -> do { [fun_ty, arg_ty] <- withMetaTvs tv kinds mk_res_ty
-                           ; return ((fun_ty, arg_ty), IdCo) } }
-      | otherwise             -- defer as tyvar may be refined by equalities
-      = defer
-      where
-        tv_kind = tyVarKind tv
-        kinds = [mkArrowKind liftedTypeKind (defaultKind tv_kind),
-                                                -- m :: * -> k
-                 liftedTypeKind]                -- arg type :: *
-        -- The defaultKind is a bit smelly.  If you remove it,
-        -- try compiling        f x = do { x }
-        -- and you'll get a kind mis-match.  It smells, but
-        -- not enough to lose sleep over.
-
-    loop _ = boxySplitFailure (mkAppTy alphaTy betaTy) orig_ty
+               Indirect ty -> go n_req ty tys
+               Flexi       -> defer n_req ty tys }
 
-    -- defer splitting by generating an equality constraint
-    defer = do { ([ty1, ty2], coi) <- boxySplitDefer arg_kinds mk_res_ty orig_ty
-               ; return ((ty1, ty2), coi)
-               }
-      where
-        orig_kind = typeKind orig_ty
-        arg_kinds = [mkArrowKind liftedTypeKind (defaultKind orig_kind),
-                                                -- m :: * -> k
-                     liftedTypeKind]            -- arg type :: *
-
-    -- build type application
-    mk_res_ty [fun_ty', arg_ty'] = mkAppTy fun_ty' arg_ty'
-    mk_res_ty _other             = panic "TcUnify.mk_res_ty2"
-
-------------------
-boxySplitFailure :: TcType -> TcType -> TcM (a, CoercionI)
-boxySplitFailure actual_ty expected_ty = failWithMisMatch actual_ty expected_ty
-
-------------------
-boxySplitDefer :: [Kind]                   -- kinds of required arguments
-               -> ([TcType] -> TcTauType)  -- construct lhs from argument tyvars
-               -> BoxyRhoType              -- type to split
-               -> TcM ([TcType], CoercionI)
-boxySplitDefer kinds mk_ty orig_ty
-  = do { tau_tys <- mapM newFlexiTyVarTy kinds
-       ; let ty1 = mk_ty tau_tys
-       ; coi <- defer_unification (Unify False ty1 orig_ty) False ty1 orig_ty
-       ; return (tau_tys, coi)
-       }
-\end{code}
-
-
---------------------------------
--- withBoxes: the key utility function
---------------------------------
+    go n_req ty@(TyConApp tycon args) tys
+      | tc == tycon
+      = ASSERT( n_req == length args)   -- ty::*
+        return (IdCo ty, args ++ tys)
 
-\begin{code}
-withMetaTvs :: TcTyVar  -- An unfilled-in, non-skolem, meta type variable
-            -> [Kind]   -- Make fresh boxes (with the same BoxTv/TauTv setting as tv)
-            -> ([BoxySigmaType] -> BoxySigmaType)
-                                        -- Constructs the type to assign
-                                        -- to the original var
-            -> TcM [BoxySigmaType]      -- Return the fresh boxes
-
--- It's entirely possible for the [kind] to be empty.
--- For example, when pattern-matching on True,
--- we call boxySplitTyConApp passing a boolTyCon
-
--- Invariant: tv is still Flexi
-
-withMetaTvs tv kinds mk_res_ty
-  | isBoxyTyVar tv
-  = do  { box_tvs <- mapM (newMetaTyVar BoxTv) kinds
-        ; let box_tys = mkTyVarTys box_tvs
-        ; writeMetaTyVar tv (mk_res_ty box_tys)
-        ; return box_tys }
-
-  | otherwise                   -- Non-boxy meta type variable
-  = do  { tau_tys <- mapM newFlexiTyVarTy kinds
-        ; writeMetaTyVar tv (mk_res_ty tau_tys) -- Write it *first*
-                                                -- Sure to be a tau-type
-        ; return tau_tys }
-
-withBox :: Kind -> (BoxySigmaType -> TcM a) -> TcM (a, TcType)
--- Allocate a *boxy* tyvar
-withBox kind thing_inside
-  = do  { box_tv <- newBoxyTyVar kind
-        ; res <- thing_inside (mkTyVarTy box_tv)
-        ; ty  <- {- pprTrace "with_box" (ppr (mkTyVarTy box_tv)) $ -} readFilledBox box_tv
-        ; return (res, ty) }
-\end{code}
+    go n_req (AppTy fun arg) tys
+      | n_req > 0
+      = do { (coi, args) <- go (n_req - 1) fun (arg : tys) 
+           ; return (mkAppTyCoI coi (IdCo arg), args) }
 
+    go n_req ty tys = defer n_req ty tys
 
-%************************************************************************
-%*                                                                      *
-                Approximate boxy matching
-%*                                                                      *
-%************************************************************************
+    ----------
+    defer n_req ty tys
+      = do { tau_tys <- mapM newFlexiTyVarTy arg_kinds
+           ; coi <- unifyType (mkTyConApp tc tau_tys) ty
+           ; return (coi, tau_tys ++ tys) }
+      where
+        (arg_kinds, _) = splitKindFunTysN n_req (tyConKind tc)
 
-\begin{code}
-preSubType :: [TcTyVar]         -- Quantified type variables
-           -> TcTyVarSet        -- Subset of quantified type variables
-                                --   see Note [Pre-sub boxy]
-            -> TcType           -- The rho-type part; quantified tyvars scopes over this
-            -> BoxySigmaType    -- Matching type from the context
-            -> TcM [TcType]     -- Types to instantiate the tyvars
--- Perform pre-subsumption, and return suitable types
--- to instantiate the quantified type varibles:
---      info from the pre-subsumption, if there is any
---      a boxy type variable otherwise
---
--- Note [Pre-sub boxy]
---   The 'btvs' are a subset of 'qtvs'.  They are the ones we can
---   instantiate to a boxy type variable, because they'll definitely be
---   filled in later.  This isn't always the case; sometimes we have type
---   variables mentioned in the context of the type, but not the body;
---                f :: forall a b. C a b => a -> a
---   Then we may land up with an unconstrained 'b', so we want to
---   instantiate it to a monotype (non-boxy) type variable
---
--- The 'qtvs' that are *neither* fixed by the pre-subsumption, *nor* are in 'btvs',
--- are instantiated to TauTv meta variables.
+----------------------
+matchExpectedAppTy :: TcRhoType                         -- orig_ty
+                   -> TcM (CoercionI,                   -- m a ~ orig_ty
+                           (TcSigmaType, TcSigmaType))  -- Returns m, a
+-- If the incoming type is a mutable type variable of kind k, then
+-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.
 
-preSubType qtvs btvs qty expected_ty
-  = do { tys <- mapM inst_tv qtvs
-        ; traceTc (text "preSubType" <+> (ppr qtvs $$ ppr btvs $$ ppr qty $$ ppr expected_ty $$ ppr pre_subst $$ ppr tys))
-        ; return tys }
+matchExpectedAppTy orig_ty
+  = go orig_ty
   where
-    pre_subst = boxySubMatchType (mkVarSet qtvs) qty expected_ty
-    inst_tv tv
-        | Just boxy_ty <- lookupTyVar pre_subst tv = return boxy_ty
-        | tv `elemVarSet` btvs = do { tv' <- tcInstBoxyTyVar tv
-                                    ; return (mkTyVarTy tv') }
-        | otherwise            = do { tv' <- tcInstTyVar tv
-                                    ; return (mkTyVarTy tv') }
-
-boxySubMatchType
-        :: TcTyVarSet -> TcType -- The "template"; the tyvars are skolems
-        -> BoxyRhoType          -- Type to match (note a *Rho* type)
-        -> TvSubst              -- Substitution of the [TcTyVar] to BoxySigmaTypes
-
--- boxySubMatchType implements the Pre-subsumption judgement, in Fig 5 of the paper
--- "Boxy types: inference for higher rank types and impredicativity"
-
-boxySubMatchType tmpl_tvs tmpl_ty boxy_ty
-  = go tmpl_tvs tmpl_ty emptyVarSet boxy_ty
-  where
-    go t_tvs t_ty b_tvs b_ty
-        | Just t_ty' <- tcView t_ty = go t_tvs t_ty' b_tvs b_ty
-        | Just b_ty' <- tcView b_ty = go t_tvs t_ty b_tvs b_ty'
-
-    go _ (TyVarTy _) _ _ = emptyTvSubst      -- Rule S-ANY; no bindings
-        -- Rule S-ANY covers (a) type variables and (b) boxy types
-        -- in the template.  Both look like a TyVarTy.
-        -- See Note [Sub-match] below
-
-    go t_tvs t_ty b_tvs b_ty
-        | isSigmaTy t_ty, (tvs, _, t_tau) <- tcSplitSigmaTy t_ty
-        = go (t_tvs `delVarSetList` tvs) t_tau b_tvs b_ty       -- Rule S-SPEC
-                -- Under a forall on the left, if there is shadowing,
-                -- do not bind! Hence the delVarSetList.
-        | isSigmaTy b_ty, (tvs, _, b_tau) <- tcSplitSigmaTy b_ty
-        = go t_tvs t_ty (extendVarSetList b_tvs tvs) b_tau      -- Rule S-SKOL
-                -- Add to the variables we must not bind to
-        -- NB: it's *important* to discard the theta part. Otherwise
-        -- consider (forall a. Eq a => a -> b) ~<~ (Int -> Int -> Bool)
-        -- and end up with a completely bogus binding (b |-> Bool), by lining
-        -- up the (Eq a) with the Int, whereas it should be (b |-> (Int->Bool)).
-        -- This pre-subsumption stuff can return too few bindings, but it
-        -- must *never* return bogus info.
-
-    go t_tvs (FunTy arg1 res1) b_tvs (FunTy arg2 res2)  -- Rule S-FUN
-        = boxy_match t_tvs arg1 b_tvs arg2 (go t_tvs res1 b_tvs res2)
-        -- Match the args, and sub-match the results
-
-    go t_tvs t_ty b_tvs b_ty = boxy_match t_tvs t_ty b_tvs b_ty emptyTvSubst
-        -- Otherwise defer to boxy matching
-        -- This covers TyConApp, AppTy, PredTy
-\end{code}
-
-Note [Sub-match]
-~~~~~~~~~~~~~~~~
-Consider this
-        head :: [a] -> a
-        |- head xs : <rhobox>
-We will do a boxySubMatchType between   a ~ <rhobox>
-But we *don't* want to match [a |-> <rhobox>] because
-    (a) The box should be filled in with a rho-type, but
-           but the returned substitution maps TyVars to boxy
-           *sigma* types
-    (b) In any case, the right final answer might be *either*
-           instantiate 'a' with a rho-type or a sigma type
-           head xs : Int   vs   head xs : forall b. b->b
-So the matcher MUST NOT make a choice here.   In general, we only
-bind a template type variable in boxyMatchType, not in boxySubMatchType.
+    go ty
+      | Just ty' <- tcView ty = go ty'
 
+      | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
+      = return (IdCo orig_ty, (fun_ty, arg_ty))
 
-\begin{code}
-boxyMatchTypes
-        :: TcTyVarSet -> [TcType] -- The "template"; the tyvars are skolems
-        -> [BoxySigmaType]        -- Type to match
-        -> TvSubst                -- Substitution of the [TcTyVar] to BoxySigmaTypes
-
--- boxyMatchTypes implements the Pre-matching judgement, in Fig 5 of the paper
--- "Boxy types: inference for higher rank types and impredicativity"
-
--- Find a *boxy* substitution that makes the template look as much
---      like the BoxySigmaType as possible.
--- It's always ok to return an empty substitution;
---      anything more is jam on the pudding
---
--- NB1: This is a pure, non-monadic function.
---      It does no unification, and cannot fail
---
--- Precondition: the arg lengths are equal
--- Precondition: none of the template type variables appear anywhere in the [BoxySigmaType]
---
+    go (TyVarTy tv)
+      | ASSERT( isTcTyVar tv) isMetaTyVar tv
+      = do { cts <- readMetaTyVar tv
+           ; case cts of
+               Indirect ty -> go ty
+               Flexi       -> defer }
 
-------------
-boxyMatchTypes tmpl_tvs tmpl_tys boxy_tys
-  = ASSERT( length tmpl_tys == length boxy_tys )
-    boxy_match_s tmpl_tvs tmpl_tys emptyVarSet boxy_tys emptyTvSubst
-        -- ToDo: add error context?
-
-boxy_match_s :: TcTyVarSet -> [TcType] -> TcTyVarSet -> [BoxySigmaType]
-             -> TvSubst -> TvSubst
-boxy_match_s _ [] _ [] subst
-  = subst
-boxy_match_s tmpl_tvs (t_ty:t_tys) boxy_tvs (b_ty:b_tys) subst
-  = boxy_match tmpl_tvs t_ty boxy_tvs b_ty $
-    boxy_match_s tmpl_tvs t_tys boxy_tvs b_tys subst
-boxy_match_s _ _ _ _ _
-  = panic "boxy_match_s"        -- Lengths do not match
+    go _ = defer
 
+    -- Defer splitting by generating an equality constraint
+    defer = do { ty1 <- newFlexiTyVarTy kind1
+               ; ty2 <- newFlexiTyVarTy kind2
+               ; coi <- unifyType (mkAppTy ty1 ty2) orig_ty
+               ; return (coi, (ty1, ty2)) }
 
-------------
-boxy_match :: TcTyVarSet -> TcType      -- Template
-           -> TcTyVarSet                -- boxy_tvs: do not bind template tyvars to any of these
-           -> BoxySigmaType             -- Match against this type
-           -> TvSubst
-           -> TvSubst
-
--- The boxy_tvs argument prevents this match:
---      [a]  forall b. a  ~  forall b. b
--- We don't want to bind the template variable 'a'
--- to the quantified type variable 'b'!
-
-boxy_match tmpl_tvs orig_tmpl_ty boxy_tvs orig_boxy_ty subst
-  = go orig_tmpl_ty orig_boxy_ty
-  where
-    go t_ty b_ty
-        | Just t_ty' <- tcView t_ty = go t_ty' b_ty
-        | Just b_ty' <- tcView b_ty = go t_ty b_ty'
-
-    go ty1 ty2          -- C.f. the isSigmaTy case for boxySubMatchType
-        | isSigmaTy ty1
-        , (tvs1, ps1, tau1) <- tcSplitSigmaTy ty1
-        , (tvs2, ps2, tau2) <- tcSplitSigmaTy ty2
-        , equalLength tvs1 tvs2
-        , equalLength ps1  ps2
-        = boxy_match (tmpl_tvs `delVarSetList` tvs1)    tau1
-                     (boxy_tvs `extendVarSetList` tvs2) tau2 subst
-
-    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
-        | tc1 == tc2
-        , not $ isOpenSynTyCon tc1
-        = go_s tys1 tys2
-
-    go (FunTy arg1 res1) (FunTy arg2 res2)
-        = go_s [arg1,res1] [arg2,res2]
-
-    go t_ty b_ty
-        | Just (s1,t1) <- tcSplitAppTy_maybe t_ty,
-          Just (s2,t2) <- tcSplitAppTy_maybe b_ty,
-          typeKind t2 `isSubKind` typeKind t1   -- Maintain invariant
-        = go_s [s1,t1] [s2,t2]
-
-    go (TyVarTy tv) b_ty
-        | tv `elemVarSet` tmpl_tvs      -- Template type variable in the template
-        , boxy_tvs `disjointVarSet` tyVarsOfType orig_boxy_ty
-        , typeKind b_ty `isSubKind` tyVarKind tv  -- See Note [Matching kinds]
-        = extendTvSubst subst tv boxy_ty'
-        | otherwise
-        = subst                         -- Ignore others
-        where
-          boxy_ty' = case lookupTyVar subst tv of
-                        Nothing -> orig_boxy_ty
-                        Just ty -> ty `boxyLub` orig_boxy_ty
-
-    go _ (TyVarTy tv) | isTcTyVar tv && isMetaTyVar tv
-				-- NB: A TyVar (not TcTyVar) is possible here, representing
-				--     a skolem, because in this pure boxy_match function 
-				--     we don't instantiate foralls to TcTyVars; cf Trac #2714
-        = subst         -- Don't fail if the template has more info than the target!
-                        -- Otherwise, with tmpl_tvs = [a], matching (a -> Int) ~ (Bool -> beta)
-                        -- would fail to instantiate 'a', because the meta-type-variable
-                        -- beta is as yet un-filled-in
-
-    go _ _ = emptyTvSubst       -- It's important to *fail* by returning the empty substitution
-        -- Example:  Tree a ~ Maybe Int
-        -- We do not want to bind (a |-> Int) in pre-matching, because that can give very
-        -- misleading error messages.  An even more confusing case is
-        --           a -> b ~ Maybe Int
-        -- Then we do not want to bind (b |-> Int)!  It's always safe to discard bindings
-        -- from this pre-matching phase.
-
-    --------
-    go_s tys1 tys2 = boxy_match_s tmpl_tvs tys1 boxy_tvs tys2 subst
-
-
-boxyLub :: BoxySigmaType -> BoxySigmaType -> BoxySigmaType
--- Combine boxy information from the two types
--- If there is a conflict, return the first
-boxyLub orig_ty1 orig_ty2
-  = go orig_ty1 orig_ty2
-  where
-    go (AppTy f1 a1) (AppTy f2 a2) = AppTy (boxyLub f1 f2) (boxyLub a1 a2)
-    go (FunTy f1 a1) (FunTy f2 a2) = FunTy (boxyLub f1 f2) (boxyLub a1 a2)
-    go (TyConApp tc1 ts1) (TyConApp tc2 ts2)
-      | tc1 == tc2, length ts1 == length ts2
-      = TyConApp tc1 (zipWith boxyLub ts1 ts2)
-
-    go (TyVarTy tv1) _                  -- This is the whole point;
-      | isTcTyVar tv1, isBoxyTyVar tv1  -- choose ty2 if ty2 is a box
-      = orig_ty2
-
-    go _ (TyVarTy tv2)                -- Symmetrical case
-      | isTcTyVar tv2, isBoxyTyVar tv2
-      = orig_ty1
-
-        -- Look inside type synonyms, but only if the naive version fails
-    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2
-               | Just ty2' <- tcView ty1 = go ty1 ty2'
-
-    -- For now, we don't look inside ForAlls, PredTys
-    go _ _ = orig_ty1       -- Default
+    orig_kind = typeKind orig_ty
+    kind1 = mkArrowKind liftedTypeKind (defaultKind orig_kind)
+    kind2 = liftedTypeKind    -- m :: * -> k
+                              -- arg type :: *
+        -- The defaultKind is a bit smelly.  If you remove it,
+        -- try compiling        f x = do { x }
+        -- and you'll get a kind mis-match.  It smells, but
+        -- not enough to lose sleep over.
 \end{code}
 
-Note [Matching kinds]
-~~~~~~~~~~~~~~~~~~~~~
-The target type might legitimately not be a sub-kind of template.
-For example, suppose the target is simply a box with an OpenTypeKind,
-and the template is a type variable with LiftedTypeKind.
-Then it's ok (because the target type will later be refined).
-We simply don't bind the template type variable.
-
-It might also be that the kind mis-match is an error. For example,
-suppose we match the template (a -> Int) against (Int# -> Int),
-where the template type variable 'a' has LiftedTypeKind.  This
-matching function does not fail; it simply doesn't bind the template.
-Later stuff will fail.
 
 %************************************************************************
 %*                                                                      *
@@ -695,185 +300,37 @@ which takes an HsExpr of type actual_ty into one of type
 expected_ty.
 
 \begin{code}
------------------
-tcSubExp :: InstOrigin -> BoxySigmaType -> BoxySigmaType -> TcM HsWrapper
-        -- (tcSub act exp) checks that
-        --      act <= exp
-tcSubExp orig actual_ty expected_ty
-  = -- addErrCtxtM (unifyCtxt actual_ty expected_ty) $
-    -- Adding the error context here leads to some very confusing error
-    -- messages, such as "can't match forall a. a->a with forall a. a->a"
-    -- Example is tcfail165:
-    --      do var <- newEmptyMVar :: IO (MVar (forall a. Show a => a -> String))
-    --         putMVar var (show :: forall a. Show a => a -> String)
-    -- Here the info does not flow from the 'var' arg of putMVar to its 'show' arg
-    -- but after zonking it looks as if it does!
-    --
-    -- So instead I'm adding the error context when moving from tc_sub to u_tys
-
-    traceTc (text "tcSubExp" <+> ppr actual_ty <+> ppr expected_ty) >>
-    tc_sub orig actual_ty actual_ty False expected_ty expected_ty
+tcSubType :: CtOrigin -> SkolemInfo -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
+-- Check that ty_actual is more polymorphic than ty_expected
+-- Both arguments might be polytypes, so we must instantiate and skolemise
+-- Returns a wrapper of shape   ty_actual ~ ty_expected
+tcSubType origin skol_info ty_actual ty_expected 
+  | isSigmaTy ty_actual
+  = do { let extra_tvs = tyVarsOfType ty_actual
+       ; (sk_wrap, inst_wrap) 
+            <- tcGen skol_info extra_tvs ty_expected $ \ _ sk_rho -> do 
+            { (in_wrap, in_rho) <- deeplyInstantiate origin ty_actual
+            ; coi <- unifyType in_rho sk_rho
+            ; return (coiToHsWrapper coi <.> in_wrap) }
+       ; return (sk_wrap <.> inst_wrap) }
+
+  | otherwise	-- Urgh!  It seems deeply weird to have equality
+    		-- when actual is not a polytype, and it makes a big 
+		-- difference e.g. tcfail104
+  = do { coi <- unifyType ty_actual ty_expected
+       ; return (coiToHsWrapper coi) }
+  
+tcInfer :: (TcType -> TcM a) -> TcM (a, TcType)
+tcInfer tc_infer = do { ty  <- newFlexiTyVarTy openTypeKind
+                      ; res <- tc_infer ty
+		      ; return (res, ty) }
 
 -----------------
-tc_sub :: InstOrigin
-       -> BoxySigmaType         -- actual_ty, before expanding synonyms
-       -> BoxySigmaType         --              ..and after
-       -> InBox                 -- True <=> expected_ty is inside a box
-       -> BoxySigmaType         -- expected_ty, before
-       -> BoxySigmaType         --              ..and after
-       -> TcM HsWrapper
-                                -- The acual_ty is never inside a box
--- IMPORTANT pre-condition: if the args contain foralls, the bound type
---                          variables are visible non-monadically
---                          (i.e. tha args are sufficiently zonked)
--- This invariant is needed so that we can "see" the foralls, ad
--- e.g. in the SPEC rule where we just use splitSigmaTy
-
-tc_sub orig act_sty act_ty exp_ib exp_sty exp_ty
-  = traceTc (text "tc_sub" <+> ppr act_ty $$ ppr exp_ty) >>
-    tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty
-        -- This indirection is just here to make
-        -- it easy to insert a debug trace!
-
-tc_sub1 :: InstOrigin -> BoxySigmaType -> BoxySigmaType -> InBox
-        -> BoxySigmaType -> Type -> TcM HsWrapper
-tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty
-  | Just exp_ty' <- tcView exp_ty = tc_sub orig act_sty act_ty exp_ib exp_sty exp_ty'
-tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty
-  | Just act_ty' <- tcView act_ty = tc_sub orig act_sty act_ty' exp_ib exp_sty exp_ty
-
------------------------------------
--- Rule SBOXY, plus other cases when act_ty is a type variable
--- Just defer to boxy matching
--- This rule takes precedence over SKOL!
-tc_sub1 orig act_sty (TyVarTy tv) exp_ib exp_sty exp_ty
-  = do  { traceTc (text "tc_sub1 - case 1")
-        ; coi <- addSubCtxt orig act_sty exp_sty $
-                 uVar (Unify True act_sty exp_sty) False tv exp_ib exp_sty exp_ty
-        ; traceTc (case coi of
-                        IdCo   -> text "tc_sub1 (Rule SBOXY) IdCo"
-                        ACo co -> text "tc_sub1 (Rule SBOXY) ACo" <+> ppr co)
-        ; return $ coiToHsWrapper coi
-        }
-
------------------------------------
--- Skolemisation case (rule SKOL)
---      actual_ty:   d:Eq b => b->b
---      expected_ty: forall a. Ord a => a->a
---      co_fn e      /\a. \d2:Ord a. let d = eqFromOrd d2 in e
-
--- It is essential to do this *before* the specialisation case
--- Example:  f :: (Eq a => a->a) -> ...
---           g :: Ord b => b->b
--- Consider  f g !
-
-tc_sub1 orig act_sty act_ty exp_ib exp_sty exp_ty
-  | isSigmaTy exp_ty = do
-    { traceTc (text "tc_sub1 - case 2") ;
-    if exp_ib then      -- SKOL does not apply if exp_ty is inside a box
-        defer_to_boxy_matching orig act_sty act_ty exp_ib exp_sty exp_ty
-    else do
-        { (gen_fn, co_fn) <- tcGen exp_ty act_tvs Nothing $ \ _ body_exp_ty ->
-                             tc_sub orig act_sty act_ty False body_exp_ty body_exp_ty
-        ; return (gen_fn <.> co_fn) }
-    }
-  where
-    act_tvs = tyVarsOfType act_ty
-                -- It's really important to check for escape wrt
-                -- the free vars of both expected_ty *and* actual_ty
-
------------------------------------
--- Specialisation case (rule ASPEC):
---      actual_ty:   forall a. Ord a => a->a
---      expected_ty: Int -> Int
---      co_fn e =    e Int dOrdInt
-
-tc_sub1 orig _ actual_ty exp_ib exp_sty expected_ty
--- Implements the new SPEC rule in the Appendix of the paper
--- "Boxy types: inference for higher rank types and impredicativity"
--- (This appendix isn't in the published version.)
--- The idea is to *first* do pre-subsumption, and then full subsumption
--- Example:     forall a. a->a  <=  Int -> (forall b. Int)
---   Pre-subsumpion finds a|->Int, and that works fine, whereas
---   just running full subsumption would fail.
-  | isSigmaTy actual_ty
-  = do  { traceTc (text "tc_sub1 - case 3")
-        ;       -- Perform pre-subsumption, and instantiate
-                -- the type with info from the pre-subsumption;
-                -- boxy tyvars if pre-subsumption gives no info
-          let (tyvars, theta, tau) = tcSplitSigmaTy actual_ty
-              tau_tvs = exactTyVarsOfType tau
-        ; inst_tys <- if exp_ib then    -- Inside a box, do not do clever stuff
-                        do { tyvars' <- mapM tcInstBoxyTyVar tyvars
-                           ; return (mkTyVarTys tyvars') }
-                      else              -- Outside, do clever stuff
-                        preSubType tyvars tau_tvs tau expected_ty
-        ; let subst' = zipOpenTvSubst tyvars inst_tys
-              tau'   = substTy subst' tau
-
-                -- Perform a full subsumption check
-        ; traceTc (text "tc_sub_spec" <+> vcat [ppr actual_ty,
-                                                ppr tyvars <+> ppr theta <+> ppr tau,
-                                                ppr tau'])
-        ; co_fn2 <- tc_sub orig tau' tau' exp_ib exp_sty expected_ty
-
-                -- Deal with the dictionaries
-        ; co_fn1 <- instCall orig inst_tys (substTheta subst' theta)
-        ; return (co_fn2 <.> co_fn1) }
-
------------------------------------
--- Function case (rule F1)
-tc_sub1 orig _ (FunTy act_arg act_res) exp_ib _ (FunTy exp_arg exp_res)
-  = do { traceTc (text "tc_sub1 - case 4")
-       ; tc_sub_funs orig act_arg act_res exp_ib exp_arg exp_res
-       }
-
--- Function case (rule F2)
-tc_sub1 orig act_sty act_ty@(FunTy act_arg act_res) _ exp_sty (TyVarTy exp_tv)
-  | isBoxyTyVar exp_tv
-  = do  { traceTc (text "tc_sub1 - case 5")
-        ; cts <- readMetaTyVar exp_tv
-        ; case cts of
-            Indirect ty -> tc_sub orig act_sty act_ty True exp_sty ty
-            Flexi -> do { [arg_ty,res_ty] <- withMetaTvs exp_tv fun_kinds mk_res_ty
-                        ; tc_sub_funs orig act_arg act_res True arg_ty res_ty } }
- where
-    mk_res_ty [arg_ty', res_ty'] = mkFunTy arg_ty' res_ty'
-    mk_res_ty _ = panic "TcUnify.mk_res_ty3"
-    fun_kinds = [argTypeKind, openTypeKind]
-
--- Everything else: defer to boxy matching
-tc_sub1 orig act_sty actual_ty exp_ib exp_sty expected_ty@(TyVarTy exp_tv)
-  = do { traceTc (text "tc_sub1 - case 6a" <+> ppr [isBoxyTyVar exp_tv, isMetaTyVar exp_tv, isSkolemTyVar exp_tv, isExistentialTyVar exp_tv,isSigTyVar exp_tv] )
-       ; defer_to_boxy_matching orig act_sty actual_ty exp_ib exp_sty expected_ty
-       }
-
-tc_sub1 orig act_sty actual_ty exp_ib exp_sty expected_ty
-  = do { traceTc (text "tc_sub1 - case 6")
-       ; defer_to_boxy_matching orig act_sty actual_ty exp_ib exp_sty expected_ty
-       }
-
------------------------------------
-defer_to_boxy_matching :: InstOrigin -> TcType -> TcType -> InBox
-                       -> TcType -> TcType -> TcM HsWrapper
-defer_to_boxy_matching orig act_sty actual_ty exp_ib exp_sty expected_ty
-  = do  { coi <- addSubCtxt orig act_sty exp_sty $
-                 u_tys (Unify True act_sty exp_sty)
-                       False act_sty actual_ty exp_ib exp_sty expected_ty
-        ; return $ coiToHsWrapper coi }
-
------------------------------------
-tc_sub_funs :: InstOrigin -> TcType -> BoxySigmaType -> InBox
-            -> TcType -> BoxySigmaType -> TcM HsWrapper
-tc_sub_funs orig act_arg act_res exp_ib exp_arg exp_res
-  = do  { arg_coi   <- addSubCtxt orig act_arg exp_arg $
-                       uTysOuter False act_arg exp_ib exp_arg
-        ; co_fn_res <- tc_sub orig act_res act_res exp_ib exp_res exp_res
-        ; wrapper1  <- wrapFunResCoercion [exp_arg] co_fn_res
-        ; let wrapper2 = case arg_coi of
-                                IdCo   -> idHsWrapper
-                                ACo co -> WpCast $ FunTy co act_res
-        ; return (wrapper1 <.> wrapper2) }
+tcWrapResult :: HsExpr TcId -> TcRhoType -> TcRhoType -> TcM (HsExpr TcId)
+tcWrapResult expr actual_ty res_ty
+  = do { coi <- unifyType actual_ty res_ty
+       	        -- Both types are deeply skolemised
+       ; return (mkHsWrapCoI coi expr) }
 
 -----------------------------------
 wrapFunResCoercion
@@ -887,7 +344,7 @@ wrapFunResCoercion arg_tys co_fn_res
   = return co_fn_res
   | otherwise
   = do  { arg_ids <- newSysLocalIds (fsLit "sub") arg_tys
-        ; return (mkWpLams arg_ids <.> co_fn_res <.> mkWpApps arg_ids) }
+        ; return (mkWpLams arg_ids <.> co_fn_res <.> mkWpEvVarApps arg_ids) }
 \end{code}
 
 
@@ -899,35 +356,23 @@ wrapFunResCoercion arg_tys co_fn_res
 %************************************************************************
 
 \begin{code}
-tcGen :: BoxySigmaType                -- expected_ty
-      -> TcTyVarSet                   -- Extra tyvars that the universally
-                                      --      quantified tyvars of expected_ty
-                                      --      must not be unified
-      -> Maybe UserTypeCtxt	      -- Just ctxt => this polytype arose directly
-      	       			      -- 	        from a user type sig
-				      -- Nothing => a higher order situation
-      -> ([TcTyVar] -> BoxyRhoType -> TcM result)
+tcGen :: SkolemInfo -> TcTyVarSet -> TcType  
+      -> ([TcTyVar] -> TcRhoType -> TcM result)
       -> TcM (HsWrapper, result)
         -- The expression has type: spec_ty -> expected_ty
 
-tcGen expected_ty extra_tvs mb_ctxt thing_inside        -- We expect expected_ty to be a forall-type
-                                          		-- If not, the call is a no-op
-  = do  { traceTc (text "tcGen")
-        ; ((tvs', theta', rho'), skol_info) <- instantiate expected_ty
+tcGen skol_info extra_tvs 
+       expected_ty thing_inside    -- We expect expected_ty to be a forall-type
+                            	   -- If not, the call is a no-op
+  = do  { traceTc "tcGen" empty
+        ; (wrap, tvs', given, rho') <- deeplySkolemise skol_info expected_ty
 
         ; when debugIsOn $
-              traceTc (text "tcGen" <+> vcat [
-                           text "extra_tvs" <+> ppr extra_tvs,
+              traceTc "tcGen" $ vcat [
                            text "expected_ty" <+> ppr expected_ty,
-                           text "inst ty" <+> ppr tvs' <+> ppr theta'
-                               <+> ppr rho',
-                           text "free_tvs" <+> ppr free_tvs])
+                           text "inst ty" <+> ppr tvs' <+> ppr rho' ]
 
-        -- Type-check the arg and unify with poly type
-        ; (result, lie) <- getLIE $ 
-			   thing_inside tvs' rho'
-
-        -- Check that the "forall_tvs" havn't been constrained
+	-- In 'free_tvs' we must check that the "forall_tvs" havn't been constrained
         -- The interesting bit here is that we must include the free variables
         -- of the expected_ty.  Here's an example:
         --       runST (newVar True)
@@ -935,44 +380,74 @@ tcGen expected_ty extra_tvs mb_ctxt thing_inside        -- We expect expected_ty
         -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
         -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
         -- So now s' isn't unconstrained because it's linked to a.
-        -- Conclusion: include the free vars of the expected_ty in the
-        -- list of "free vars" for the signature check.
-
-        ; loc <- getInstLoc (SigOrigin skol_info)
-        ; dicts <- newDictBndrs loc theta'      -- Includes equalities
-        ; inst_binds <- tcSimplifyCheck loc tvs' dicts lie
+        -- Conclusion: pass the free vars of the expected_ty to checkConsraints
+        ; let free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
+
+        ; (ev_binds, result) <- checkConstraints skol_info free_tvs tvs' given $
+                                thing_inside tvs' rho'
+
+        ; return (wrap <.> mkWpLet ev_binds, result) }
+	  -- The ev_binds returned by checkConstraints is very
+	  -- often empty, in which case mkWpLet is a no-op
+
+checkConstraints :: SkolemInfo
+                 -> TcTyVarSet		-- Free variables (other than the type envt)
+					-- for the skolem escape check
+		 -> [TcTyVar]		-- Skolems
+		 -> [EvVar]             -- Given
+		 -> TcM result
+		 -> TcM (TcEvBinds, result)
+
+checkConstraints skol_info free_tvs skol_tvs given thing_inside
+  | null skol_tvs && null given
+  = do { res <- thing_inside; return (emptyTcEvBinds, res) }
+      -- Just for efficiency.  We check every function argument with
+      -- tcPolyExpr, which uses tcGen and hence checkConstraints.
 
-        ; checkSigTyVarsWrt free_tvs tvs'
-        ; traceTc (text "tcGen:done")
-
-        ; let
-            -- The WpLet binds any Insts which came out of the simplification.
-            dict_vars = map instToVar dicts
-            co_fn = mkWpTyLams tvs' <.> mkWpLams dict_vars <.> WpLet inst_binds
-        ; return (co_fn, result) }
-  where
-    free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs
-
-    instantiate :: TcType -> TcM (([TcTyVar],ThetaType,TcRhoType), SkolemInfo)
-    instantiate expected_ty
-      | Just ctxt <- mb_ctxt	-- This case split is the wohle reason for mb_ctxt
-      = do { let skol_info = SigSkol ctxt
-           ; stuff <- tcInstSigType True skol_info expected_ty
-	   ; return (stuff, skol_info) }
-
-      | otherwise   -- We want the GenSkol info in the skolemised type variables to
-                    -- mention the *instantiated* tyvar names, so that we get a
-		    -- good error message "Rigid variable 'a' is bound by (forall a. a->a)"
-		    -- Hence the tiresome but innocuous fixM
-      = fixM $ \ ~(_, skol_info) ->
-        do { stuff@(forall_tvs, theta, rho_ty) <- tcInstSkolType skol_info expected_ty
-                -- Get loation from *monad*, not from expected_ty
-           ; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty)
-           ; return (stuff, skol_info) }
+  | otherwise
+  = do { (ev_binds, wanted, result) <- newImplication skol_info free_tvs 
+                                             skol_tvs given thing_inside
+       ; emitConstraints wanted
+       ; return (ev_binds, result) }
+
+newImplication :: SkolemInfo -> TcTyVarSet -> [TcTyVar]
+	       -> [EvVar] -> TcM result
+               -> TcM (TcEvBinds, WantedConstraints, result)
+newImplication skol_info free_tvs skol_tvs given thing_inside
+  = ASSERT2( all isTcTyVar skol_tvs, ppr skol_tvs )
+    ASSERT2( all isSkolemTyVar skol_tvs, ppr skol_tvs )
+    do { gbl_tvs <- tcGetGlobalTyVars
+       ; lcl_env <- getLclTypeEnv
+       ; let all_free_tvs = gbl_tvs `unionVarSet` free_tvs
+
+       ; (result, wanted) <- getConstraints               $ 
+                             setUntouchables all_free_tvs $
+                             thing_inside
+
+       ; if isEmptyBag wanted && not (hasEqualities given) 
+       	    -- Optimisation : if there are no wanteds, and the givens
+       	    -- are sufficiently simple, don't generate an implication
+       	    -- at all.  Reason for the hasEqualities test:
+	    -- we don't want to lose the "inaccessible alternative"
+	    -- error check
+         then 
+            return (emptyTcEvBinds, emptyWanteds, result)
+         else do
+       { ev_binds_var <- newTcEvBinds
+       ; loc <- getCtLoc skol_info
+       ; let implic = Implic { ic_env_tvs = all_free_tvs
+             		     , ic_env = lcl_env
+             		     , ic_skols = mkVarSet skol_tvs
+             		     , ic_scoped = panic "emitImplication"
+             		     , ic_given = given
+             		     , ic_wanted = wanted
+             		     , ic_binds = ev_binds_var
+             		     , ic_loc = loc }
+
+       ; return (TcEvBinds ev_binds_var, unitBag (WcImplic implic), result) } }
 \end{code}
 
 
-
 %************************************************************************
 %*                                                                      *
                 Boxy unification
@@ -983,53 +458,25 @@ The exported functions are all defined as versions of some
 non-exported generic functions.
 
 \begin{code}
-boxyUnify :: BoxyType -> BoxyType -> TcM CoercionI
--- Acutal and expected, respectively
-boxyUnify ty1 ty2 = addErrCtxtM (unifyCtxt ty1 ty2) $
-                    uTysOuter False ty1 False ty2
-
----------------
-boxyUnifyList :: [BoxyType] -> [BoxyType] -> TcM [CoercionI]
--- Arguments should have equal length
--- Acutal and expected types
-boxyUnifyList tys1 tys2 = uList boxyUnify tys1 tys2
-
 ---------------
 unifyType :: TcTauType -> TcTauType -> TcM CoercionI
--- No boxes expected inside these types
--- Acutal and expected types
-unifyType ty1 ty2       -- ty1 expected, ty2 inferred
-  = ASSERT2( not (isBoxyTy ty1), ppr ty1 )
-    ASSERT2( not (isBoxyTy ty2), ppr ty2 )
-    addErrCtxtM (unifyCtxt ty1 ty2) $
-    uTysOuter True ty1 True ty2
+-- Actual and expected types
+-- Returns a coercion : ty1 ~ ty2
+unifyType ty1 ty2 = uType [] ty1 ty2
 
 ---------------
 unifyPred :: PredType -> PredType -> TcM CoercionI
--- Acutal and expected types
-unifyPred p1 p2 = uPred (Unify False (mkPredTy p1) (mkPredTy p2)) True p1 True p2
+-- Actual and expected types
+unifyPred p1 p2 = uPred [UnifyOrigin (mkPredTy p1) (mkPredTy p2)] p1 p2
 
+---------------
 unifyTheta :: TcThetaType -> TcThetaType -> TcM [CoercionI]
--- Acutal and expected types
+-- Actual and expected types
 unifyTheta theta1 theta2
   = do  { checkTc (equalLength theta1 theta2)
                   (vcat [ptext (sLit "Contexts differ in length"),
                          nest 2 $ parens $ ptext (sLit "Use -XRelaxedPolyRec to allow this")])
-        ; uList unifyPred theta1 theta2
-        }
-
----------------
-uList :: (a -> a -> TcM b)
-       -> [a] -> [a] -> TcM [b]
--- Unify corresponding elements of two lists of types, which
--- should be of equal length.  We charge down the list explicitly so that
--- we can complain if their lengths differ.
-uList _     []         []         = return []
-uList unify (ty1:tys1) (ty2:tys2) = do { x  <- unify ty1 ty2;
-                                       ; xs <- uList unify tys1 tys2
-                                       ; return (x:xs)
-                                       }
-uList _ _ _ = panic "Unify.uList: mismatched type lists!"
+        ; zipWithM unifyPred theta1 theta2 }
 \end{code}
 
 @unifyTypeList@ takes a single list of @TauType@s and unifies them
@@ -1046,265 +493,214 @@ unifyTypeList (ty1:tys@(ty2:_)) = do { _ <- unifyType ty1 ty2
 
 %************************************************************************
 %*                                                                      *
-\subsection[Unify-uTys]{@uTys@: getting down to business}
+                 uType and friends									
 %*                                                                      *
 %************************************************************************
 
-@uTys@ is the heart of the unifier.  Each arg occurs twice, because
+uType is the heart of the unifier.  Each arg occurs twice, because
 we want to report errors in terms of synomyms if possible.  The first of
 the pair is used in error messages only; it is always the same as the
 second, except that if the first is a synonym then the second may be a
 de-synonym'd version.  This way we get better error messages.
 
-We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''.
-
 \begin{code}
-type SwapFlag = Bool
-        -- False <=> the two args are (actual, expected) respectively
-        -- True  <=> the two args are (expected, actual) respectively
-
-type InBox = Bool       -- True  <=> we are inside a box
-                        -- False <=> we are outside a box
-        -- The importance of this is that if we get "filled-box meets
-        -- filled-box", we'll look into the boxes and unify... but
-        -- we must not allow polytypes.  But if we are in a box on
-        -- just one side, then we can allow polytypes
-
-data Outer = Unify Bool TcType TcType
-        -- If there is a unification error, report these types as mis-matching
-        -- Bool = True <=> the context says "Expected = ty1, Acutal = ty2"
-        --                 for this particular ty1,ty2
-
-instance Outputable Outer where
-  ppr (Unify c ty1 ty2) = pp_c <+> pprParendType ty1 <+> ptext (sLit "~")
-                               <+> pprParendType ty2
-        where
-          pp_c = if c then ptext (sLit "Top") else ptext (sLit "NonTop")
-
-
--------------------------
-uTysOuter :: InBox -> TcType    -- ty1 is the *actual*   type
-          -> InBox -> TcType    -- ty2 is the *expected* type
-          -> TcM CoercionI
--- We've just pushed a context describing ty1,ty2
-uTysOuter nb1 ty1 nb2 ty2
-        = do { traceTc (text "uTysOuter" <+> sep [ppr ty1, ppr ty2])
-             ; u_tys (Unify True ty1 ty2) nb1 ty1 ty1 nb2 ty2 ty2 }
-
-uTys :: InBox -> TcType -> InBox -> TcType -> TcM CoercionI
--- The context does not describe ty1,ty2
-uTys nb1 ty1 nb2 ty2
-  = do { traceTc (text "uTys" <+> ppr ty1 <+> ppr ty2)
-       ; u_tys (Unify False ty1 ty2) nb1 ty1 ty1 nb2 ty2 ty2 }
+data SwapFlag 
+  = NotSwapped	-- Args are: actual,   expected
+  | IsSwapped   -- Args are: expected, actual
 
+instance Outputable SwapFlag where
+  ppr IsSwapped  = ptext (sLit "Is-swapped")
+  ppr NotSwapped = ptext (sLit "Not-swapped")
+
+unSwap :: SwapFlag -> (a->a->b) -> a -> a -> b
+unSwap NotSwapped f a b = f a b
+unSwap IsSwapped  f a b = f b a
+
+------------
+uType, uType_np, uType_defer
+  :: [EqOrigin]
+  -> TcType    -- ty1 is the *actual* type
+  -> TcType    -- ty2 is the *expected* type
+  -> TcM CoercionI
 
 --------------
-uTys_s :: Outer		
-       -> InBox -> [TcType]     -- tys1 are the *actual*   types
-       -> InBox -> [TcType]     -- tys2 are the *expected* types
-       -> TcM [CoercionI]
-uTys_s outer nb1 tys1 nb2 tys2
-  = go tys1 tys2
-  where
-    go []         []         = return []
-    go (ty1:tys1) (ty2:tys2) = do { coi <- uTys nb1 ty1 nb2 ty2
-                                  ; cois <- go tys1 tys2
-                                  ; return (coi:cois) }
-    go _ _ = unifyMisMatch outer
-       -- See Note [Mismatched type lists and application decomposition]
+-- It is always safe to defer unification to the main constraint solver
+-- See Note [Deferred unification]
+uType_defer origin ty1 ty2
+  = do { co_var <- newWantedCoVar ty1 ty2
+       ; traceTc "utype_defer" (vcat [ppr co_var, ppr ty1, ppr ty2, ppr origin])
+       ; loc <- getCtLoc TypeEqOrigin
+       ; wrapEqCtxt origin $
+         emitConstraint (WcEvVar (WantedEvVar co_var loc)) 
+       ; return $ ACo $ mkTyVarTy co_var }
+
+--------------
+-- Push a new item on the origin stack (the most common case)
+uType origin ty1 ty2  -- Push a new item on the origin stack
+  = uType_np (pushOrigin ty1 ty2 origin) ty1 ty2
 
 --------------
-u_tys :: Outer
-      -> InBox -> TcType -> TcType      -- ty1 is the *actual* type
-      -> InBox -> TcType -> TcType      -- ty2 is the *expected* type
-      -> TcM CoercionI
-
-u_tys outer nb1 orig_ty1 ty1 nb2 orig_ty2 ty2
-  = do { traceTc (text "u_tys " <+> vcat [sep [ braces (ppr orig_ty1 <+> text "/" <+> ppr ty1),
-                                          text "~",
-                                          braces (ppr orig_ty2 <+> text "/" <+> ppr ty2)],
-                                          ppr outer])
-       ; coi <- go outer orig_ty1 ty1 orig_ty2 ty2
-       ; traceTc (case coi of
-                        ACo co -> text "u_tys yields coercion:" <+> ppr co
-                        IdCo   -> text "u_tys yields no coercion")
-       ; return coi
-       }
+-- unify_np (short for "no push" on the origin stack) does the work
+uType_np origin orig_ty1 orig_ty2
+  = do { traceTc "u_tys " $ vcat 
+              [ sep [ ppr orig_ty1, text "~", ppr orig_ty2]
+              , ppr origin]
+       ; coi <- go origin orig_ty1 orig_ty2
+       ; case coi of
+            ACo co -> traceTc "u_tys yields coercion:" (ppr co)
+            IdCo _ -> traceTc "u_tys yields no coercion" empty
+       ; return coi }
   where
-    bale_out :: Outer -> TcM a
-    bale_out outer = unifyMisMatch outer
-        -- We report a mis-match in terms of the original arugments to
-        -- u_tys, even though 'go' has recursed inwards somewhat
-        --
-        -- Note [Unifying AppTy]
-        -- A case in point is unifying  (m Int) ~ (IO Int)
-        -- where m is a unification variable that is now bound to (say) (Bool ->)
-        -- Then we want to report "Can't unify (Bool -> Int) with (IO Int)
-        -- and not "Can't unify ((->) Bool) with IO"
-
-    go :: Outer -> TcType -> TcType -> TcType -> TcType -> TcM CoercionI
-        -- Always expand synonyms: see Note [Unification and synonyms]
-        -- (this also throws away FTVs)
-    go _ sty1 ty1 sty2 ty2
-      | Just ty1' <- tcView ty1 = go (Unify False ty1' ty2 ) sty1 ty1' sty2 ty2
-      | Just ty2' <- tcView ty2 = go (Unify False ty1  ty2') sty1 ty1  sty2 ty2'
+    bale_out :: [EqOrigin] -> TcM a
+    bale_out origin = failWithMisMatch origin
+
+    go :: [EqOrigin] -> TcType -> TcType -> TcM CoercionI
+	-- The arguments to 'go' are always semantically identical 
+	-- to orig_ty{1,2} except for looking through type synonyms
 
         -- Variables; go for uVar
-    go outer _ (TyVarTy tyvar1) sty2 ty2 = uVar outer False tyvar1 nb2 sty2 ty2
-    go outer sty1 ty1 _ (TyVarTy tyvar2) = uVar outer True  tyvar2 nb1 sty1 ty1
-                                -- "True" means args swapped
-
-        -- The case for sigma-types must *follow* the variable cases
-        -- because a boxy variable can be filed with a polytype;
-        -- but must precede FunTy, because ((?x::Int) => ty) look
-        -- like a FunTy; there isn't necy a forall at the top
-    go _ _ ty1 _ ty2
-      | isSigmaTy ty1 || isSigmaTy ty2
-      = do   { traceTc (text "We have sigma types: equalLength" <+> ppr tvs1 <+> ppr tvs2)
-             ; unless (equalLength tvs1 tvs2) (bale_out outer)
-             ; traceTc (text "We're past the first length test")
-             ; tvs <- tcInstSkolTyVars UnkSkol tvs1     -- Not a helpful SkolemInfo
-                        -- Get location from monad, not from tvs1
-             ; let tys      = mkTyVarTys tvs
-                   in_scope = mkInScopeSet (mkVarSet tvs)
-                   phi1   = substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1
-                   phi2   = substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2
-                   (theta1,tau1) = tcSplitPhiTy phi1
-                   (theta2,tau2) = tcSplitPhiTy phi2
-
-             ; addErrCtxtM (unifyForAllCtxt tvs phi1 phi2) $ do
-             { unless (equalLength theta1 theta2) (bale_out outer)
-             ; cois <- uPreds outer nb1 theta1 nb2 theta2
-             ; coi <- uTys nb1 tau1 nb2 tau2
-
-                -- Check for escape; e.g. (forall a. a->b) ~ (forall a. a->a)
-             ; free_tvs <- zonkTcTyVarsAndFV (varSetElems (tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2))
-             ; when (any (`elemVarSet` free_tvs) tvs)
-                   (bleatEscapedTvs free_tvs tvs tvs)
-
-                -- If both sides are inside a box, we are in a "box-meets-box"
-                -- situation, and we should not have a polytype at all.
-                -- If we get here we have two boxes, already filled with
-                -- the same polytype... but it should be a monotype.
-                -- This check comes last, because the error message is
-                -- extremely unhelpful.
-             ; when (nb1 && nb2) (notMonoType ty1)
-             ; let mk_fun (pred, coi_pred) (ty, coi) 
-                       = (mkFunTy pred_ty ty, mkFunTyCoI pred_ty coi_pred ty coi)
-                       where
-                         pred_ty = mkPredTy pred
-             ; return (foldr mkForAllTyCoI 
-                             (snd (foldr mk_fun (tau1,coi) (theta1 `zip` cois)))
-                             tvs)
-             }}
-      where
-        (tvs1, body1) = tcSplitForAllTys ty1
-        (tvs2, body2) = tcSplitForAllTys ty2
+	-- Note that we pass in *original* (before synonym expansion), 
+        -- so that type variables tend to get filled in with 
+        -- the most informative version of the type
+    go origin (TyVarTy tyvar1) ty2 = uVar origin NotSwapped tyvar1 ty2
+    go origin ty1 (TyVarTy tyvar2) = uVar origin IsSwapped  tyvar2 ty1
+
+        -- Expand synonyms: 
+	--      see Note [Unification and synonyms]
+	-- Do this after the variable case so that we tend to unify
+	-- variables with un-expended type synonym
+    go origin ty1 ty2
+      | Just ty1' <- tcView ty1 = uType origin ty1' ty2
+      | Just ty2' <- tcView ty2 = uType origin ty1  ty2'
 
         -- Predicates
-    go outer _ (PredTy p1) _ (PredTy p2)
-        = uPred outer nb1 p1 nb2 p2
-
-        -- Non-synonym type constructors must match
-    go outer _ (TyConApp con1 tys1) _ (TyConApp con2 tys2)
-      | con1 == con2 && not (isOpenSynTyCon con1)
-      = do { traceTc (text "utys1" <+> ppr con1 <+> (ppr tys1 $$ ppr tys2))
-           ; cois <- uTys_s outer nb1 tys1 nb2 tys2
-           ; return $ mkTyConAppCoI con1 tys1 cois
-           }
-        -- Family synonyms See Note [TyCon app]
-      | con1 == con2 && identicalOpenSynTyConApp
-      = do { traceTc (text "utys2" <+> ppr con1 <+> (ppr tys1' $$ ppr tys2'))
-           ; cois <- uTys_s outer nb1 tys1' nb2 tys2'
-           ; return $ mkTyConAppCoI con1 tys1 (replicate n IdCo ++ cois)
-           }
-      where
-        n                        = tyConArity con1
-        (idxTys1, tys1')         = splitAt n tys1
-        (idxTys2, tys2')         = splitAt n tys2
-        identicalOpenSynTyConApp = idxTys1 `tcEqTypes` idxTys2
-        -- See Note [OpenSynTyCon app]
+    go origin (PredTy p1) (PredTy p2) = uPred origin p1 p2
 
         -- Functions; just check the two parts
-    go _ _ (FunTy fun1 arg1) _ (FunTy fun2 arg2)
-      = do { coi_l <- uTys nb1 fun1 nb2 fun2
-           ; coi_r <- uTys nb1 arg1 nb2 arg2
-           ; return $ mkFunTyCoI fun1 coi_l arg1 coi_r
-           }
-
-        -- Applications need a bit of care!
-        -- They can match FunTy and TyConApp, so use splitAppTy_maybe
-        -- NB: we've already dealt with type variables and Notes,
-        -- so if one type is an App the other one jolly well better be too
-        -- See Note [Mismatched type lists and application decomposition]
-    go outer _ (AppTy s1 t1) _ ty2
+    go origin (FunTy fun1 arg1) (FunTy fun2 arg2)
+      = do { coi_l <- uType origin fun1 fun2
+           ; coi_r <- uType origin arg1 arg2
+           ; return $ mkFunTyCoI coi_l coi_r }
+
+        -- Always defer if a type synonym family (type function)
+      	-- is involved.  (Data families behave rigidly.)
+    go origin ty1@(TyConApp tc1 _) ty2
+      | isSynFamilyTyCon tc1 = uType_defer origin ty1 ty2   
+    go origin ty1 ty2@(TyConApp tc2 _)
+      | isSynFamilyTyCon tc2 = uType_defer origin ty1 ty2   
+
+    go origin (TyConApp tc1 tys1) (TyConApp tc2 tys2)
+      | tc1 == tc2	   -- See Note [TyCon app]
+      = do { cois <- uList origin uType tys1 tys2
+           ; return $ mkTyConAppCoI tc1 cois }
+     
+	-- See Note [Care with type applications]
+    go origin (AppTy s1 t1) ty2
       | Just (s2,t2) <- tcSplitAppTy_maybe ty2
-      = do { coi_s <- go outer s1 s1 s2 s2      -- NB recurse into go...
-           ; coi_t <- uTys nb1 t1 nb2 t2        -- See Note [Unifying AppTy]
-           ; return $ mkAppTyCoI s1 coi_s t1 coi_t }
+      = do { coi_s <- uType_np origin s1 s2  -- See Note [Unifying AppTy]
+           ; coi_t <- uType origin t1 t2        
+           ; return $ mkAppTyCoI coi_s coi_t }
 
-        -- Now the same, but the other way round
-        -- Don't swap the types, because the error messages get worse
-    go outer _ ty1 _ (AppTy s2 t2)
+    go origin ty1 (AppTy s2 t2)
       | Just (s1,t1) <- tcSplitAppTy_maybe ty1
-      = do { coi_s <- go outer s1 s1 s2 s2
-           ; coi_t <- uTys nb1 t1 nb2 t2
-           ; return $ mkAppTyCoI s1 coi_s t1 coi_t }
-
-        -- If we can reduce a family app => proceed with reduct
-        -- NB1: We use isOpenSynTyCon, not isOpenSynTyConApp as we also must
-        --      defer oversaturated applications!
-	-- 
-	-- NB2: Do this *after* trying decomposing applications, so that decompose
-	--     	  (m a) ~ (F Int b)
-	--      where F has arity 1
-    go _ _ ty1@(TyConApp con1 _) _ ty2
-      | isOpenSynTyCon con1
-      = do { (coi1, ty1') <- tcNormaliseFamInst ty1
-           ; case coi1 of
-               IdCo -> defer    -- no reduction, see [Deferred Unification]
-               _    -> liftM (coi1 `mkTransCoI`) $ uTys nb1 ty1' nb2 ty2
-           }
-
-    go _ _ ty1 _ ty2@(TyConApp con2 _)
-      | isOpenSynTyCon con2
-      = do { (coi2, ty2') <- tcNormaliseFamInst ty2
-           ; case coi2 of
-               IdCo -> defer    -- no reduction, see [Deferred Unification]
-               _    -> liftM (`mkTransCoI` mkSymCoI coi2) $ 
-                       uTys nb1 ty1 nb2 ty2'
-           }
-
-        -- Anything else fails
-    go outer _ _ _ _ = bale_out outer
+      = do { coi_s <- uType_np origin s1 s2
+           ; coi_t <- uType origin t1 t2
+           ; return $ mkAppTyCoI coi_s coi_t }
 
-    defer = defer_unification outer False orig_ty1 orig_ty2
+    go _ ty1 ty2
+      | isSigmaTy ty1 || isSigmaTy ty2
+      = unifySigmaTy origin ty1 ty2
 
+        -- Anything else fails
+    go origin _ _ = bale_out origin
+
+unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM CoercionI
+unifySigmaTy origin ty1 ty2
+  = do { let (tvs1, body1) = tcSplitForAllTys ty1
+             (tvs2, body2) = tcSplitForAllTys ty2
+       ; unless (equalLength tvs1 tvs2) (failWithMisMatch origin)
+       ; skol_tvs <- tcInstSkolTyVars UnkSkol tvs1     -- Not a helpful SkolemInfo
+                  -- Get location from monad, not from tvs1
+       ; let tys      = mkTyVarTys skol_tvs
+             in_scope = mkInScopeSet (mkVarSet skol_tvs)
+             phi1     = substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1
+             phi2     = substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2
+             untch = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+
+       ; (coi, lie) <- getConstraints $ 
+                       setUntouchables untch $ 
+                       uType origin phi1 phi2
+
+          -- Check for escape; e.g. (forall a. a->b) ~ (forall a. a->a)
+       ; let bad_lie  = filterBag is_bad lie
+             is_bad w = any (`elemVarSet` tyVarsOfWanted w) skol_tvs
+       ; when (not (isEmptyBag bad_lie))
+              (failWithMisMatch origin)	-- ToDo: give details from bad_lie
+
+       ; emitConstraints lie
+       ; return (foldr mkForAllTyCoI coi skol_tvs) }
 
 ----------
-uPred :: Outer -> InBox -> PredType -> InBox -> PredType -> TcM CoercionI
-uPred _ nb1 (IParam n1 t1) nb2 (IParam n2 t2)
+uPred :: [EqOrigin] -> PredType -> PredType -> TcM CoercionI
+uPred origin (IParam n1 t1) (IParam n2 t2)
   | n1 == n2
-  = do { coi <- uTys nb1 t1 nb2 t2
+  = do { coi <- uType origin t1 t2
        ; return $ mkIParamPredCoI n1 coi }
-uPred outer nb1 (ClassP c1 tys1) nb2 (ClassP c2 tys2)
-  | c1 == c2
-  = do { traceTc (text "utys3" <+> ppr c1 <+> (ppr tys2 $$ ppr tys2))
-       ; cois <- uTys_s outer nb1 tys1 nb2 tys2
-       ; return $ mkClassPPredCoI c1 tys1 cois }
-uPred outer _ _ _ _ = unifyMisMatch outer
-
-uPreds :: Outer -> InBox -> [PredType] -> InBox -> [PredType]
-       -> TcM [CoercionI]
-uPreds _     _   []       _   []       = return []
-uPreds outer nb1 (p1:ps1) nb2 (p2:ps2) =
-        do { coi  <- uPred  outer nb1 p1 nb2 p2
-           ; cois <- uPreds outer nb1 ps1 nb2 ps2
-           ; return (coi:cois)
-           }
-uPreds _ _ _ _ _ = panic "uPreds"
+uPred origin (ClassP c1 tys1) (ClassP c2 tys2)
+  | c1 == c2 
+  = do { cois <- uList origin uType tys1 tys2
+          -- Guaranteed equal lengths because the kinds check
+       ; return $ mkClassPPredCoI c1 cois }
+uPred origin (EqPred ty1a ty1b) (EqPred ty2a ty2b)
+  = do { coia <- uType origin ty1a ty2a
+       ; coib <- uType origin ty1b ty2b
+       ; return $ mkEqPredCoI coia coib }
+
+uPred origin _ _ = failWithMisMatch origin
+
+---------------
+uList :: [EqOrigin] 
+      -> ([EqOrigin] -> a -> a -> TcM b)
+      -> [a] -> [a] -> TcM [b]
+-- Unify corresponding elements of two lists of types, which
+-- should be of equal length.  We charge down the list explicitly so that
+-- we can complain if their lengths differ.
+uList _       _     []         []        = return []
+uList origin unify (ty1:tys1) (ty2:tys2) = do { x  <- unify origin ty1 ty2;
+                                              ; xs <- uList origin unify tys1 tys2
+                                              ; return (x:xs) }
+uList origin _ _ _ = failWithMisMatch origin
+       -- See Note [Mismatched type lists and application decomposition]
+
 \end{code}
 
+Note [Care with type applications]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note: type applications need a bit of care!
+They can match FunTy and TyConApp, so use splitAppTy_maybe
+NB: we've already dealt with type variables and Notes,
+so if one type is an App the other one jolly well better be too
+
+Note [Unifying AppTy]
+~~~~~~~~~~~~~~~~~~~~~
+Considerm unifying  (m Int) ~ (IO Int) where m is a unification variable 
+that is now bound to (say) (Bool ->).  Then we want to report 
+     "Can't unify (Bool -> Int) with (IO Int)
+and not 
+     "Can't unify ((->) Bool) with IO"
+That is why we use the "_np" variant of uType, which does not alter the error
+message.
+
+Note [TyCon app]
+~~~~~~~~~~~~~~~~
+When we find two TyConApps, the argument lists are guaranteed equal
+length.  Reason: intially the kinds of the two types to be unified is
+the same. The only way it can become not the same is when unifying two
+AppTys (f1 a1)~(f2 a2).  In that case there can't be a TyConApp in
+the f1,f2 (because it'd absorb the app).  If we unify f1~f2 first,
+which we do, that ensures that f1,f2 have the same kind; and that
+means a1,a2 have the same kind.  And now the argument repeats.
+
 Note [Mismatched type lists and application decomposition]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When we find two TyConApps, you might think that the argument lists 
@@ -1323,173 +719,52 @@ So either
 Currently we adopt (b) since it seems more robust -- no need to maintain
 a global invariant.
 
-Note [OpenSynTyCon app]
-~~~~~~~~~~~~~~~~~~~~~~~
-Given
-
-  type family T a :: * -> *
-
-the two types (T () a) and (T () Int) must unify, even if there are
-no type instances for T at all.  Should we just turn them into an
-equality (T () a ~ T () Int)?  I don't think so.  We currently try to
-eagerly unify everything we can before generating equalities; otherwise,
-we could turn the unification of [Int] with [a] into an equality, too.
-
 Note [Unification and synonyms]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 If you are tempted to make a short cut on synonyms, as in this
 pseudocode...
 
-\begin{verbatim}
--- NO   uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2)
--- NO     = if (con1 == con2) then
--- NO   -- Good news!  Same synonym constructors, so we can shortcut
--- NO   -- by unifying their arguments and ignoring their expansions.
--- NO   unifyTypepeLists args1 args2
--- NO    else
--- NO   -- Never mind.  Just expand them and try again
--- NO   uTys ty1 ty2
-\end{verbatim}
+   uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2)
+     = if (con1 == con2) then
+   -- Good news!  Same synonym constructors, so we can shortcut
+   -- by unifying their arguments and ignoring their expansions.
+   unifyTypepeLists args1 args2
+    else
+   -- Never mind.  Just expand them and try again
+   uTys ty1 ty2
 
 then THINK AGAIN.  Here is the whole story, as detected and reported
-by Chris Okasaki \tr{<Chris_Okasaki@loch.mess.cs.cmu.edu>}:
-\begin{quotation}
+by Chris Okasaki:
+
 Here's a test program that should detect the problem:
 
-\begin{verbatim}
         type Bogus a = Int
         x = (1 :: Bogus Char) :: Bogus Bool
-\end{verbatim}
 
 The problem with [the attempted shortcut code] is that
-\begin{verbatim}
+
         con1 == con2
-\end{verbatim}
+
 is not a sufficient condition to be able to use the shortcut!
 You also need to know that the type synonym actually USES all
 its arguments.  For example, consider the following type synonym
 which does not use all its arguments.
-\begin{verbatim}
-        type Bogus a = Int
-\end{verbatim}
 
-If you ever tried unifying, say, \tr{Bogus Char} with \tr{Bogus Bool},
-the unifier would blithely try to unify \tr{Char} with \tr{Bool} and
-would fail, even though the expanded forms (both \tr{Int}) should
-match.
+        type Bogus a = Int
 
-Similarly, unifying \tr{Bogus Char} with \tr{Bogus t} would
-unnecessarily bind \tr{t} to \tr{Char}.
+If you ever tried unifying, say, (Bogus Char) with )Bogus Bool), the
+unifier would blithely try to unify Char with Bool and would fail,
+even though the expanded forms (both Int) should match. Similarly,
+unifying (Bogus Char) with (Bogus t) would unnecessarily bind t to
+Char.
 
 ... You could explicitly test for the problem synonyms and mark them
 somehow as needing expansion, perhaps also issuing a warning to the
 user.
-\end{quotation}
-
-
-%************************************************************************
-%*                                                                      *
-\subsection[Unify-uVar]{@uVar@: unifying with a type variable}
-%*                                                                      *
-%************************************************************************
-
-@uVar@ is called when at least one of the types being unified is a
-variable.  It does {\em not} assume that the variable is a fixed point
-of the substitution; rather, notice that @uVar@ (defined below) nips
-back into @uTys@ if it turns out that the variable is already bound.
-
-\begin{code}
-uVar :: Outer
-     -> SwapFlag        -- False => tyvar is the "actual" (ty is "expected")
-                        -- True  => ty is the "actual" (tyvar is "expected")
-     -> TcTyVar
-     -> InBox           -- True <=> definitely no boxes in t2
-     -> TcTauType -> TcTauType  -- printing and real versions
-     -> TcM CoercionI
-
-uVar outer swapped tv1 nb2 ps_ty2 ty2
-  = do  { let expansion | showSDoc (ppr ty2) == showSDoc (ppr ps_ty2) = empty
-                        | otherwise = brackets (equals <+> ppr ty2)
-        ; traceTc (text "uVar" <+> ppr outer <+> ppr swapped <+>
-                        sep [ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1 ),
-                                nest 2 (ptext (sLit " <-> ")),
-                             ppr ps_ty2 <+> dcolon <+> ppr (typeKind ty2) <+> expansion])
-        ; details <- lookupTcTyVar tv1
-        ; case details of
-            IndirectTv ty1
-                | swapped   -> u_tys outer nb2  ps_ty2 ty2 True ty1    ty1      -- Swap back
-                | otherwise -> u_tys outer True ty1    ty1 nb2  ps_ty2 ty2      -- Same order
-                        -- The 'True' here says that ty1 is now inside a box
-            DoneTv details1 -> uUnfilledVar outer swapped tv1 details1 ps_ty2 ty2
-        }
-
-----------------
-uUnfilledVar :: Outer
-             -> SwapFlag
-             -> TcTyVar -> TcTyVarDetails       -- Tyvar 1
-             -> TcTauType -> TcTauType          -- Type 2
-             -> TcM CoercionI
--- Invariant: tyvar 1 is not unified with anything
-
-uUnfilledVar _ swapped tv1 details1 ps_ty2 ty2
-  | Just ty2' <- tcView ty2
-  =     -- Expand synonyms; ignore FTVs
-    let outer' | swapped   = Unify False ty2' (mkTyVarTy tv1)
-               | otherwise = Unify False (mkTyVarTy tv1) ty2'
-    in uUnfilledVar outer' swapped tv1 details1 ps_ty2 ty2'
-
-uUnfilledVar outer swapped tv1 details1 _ (TyVarTy tv2)
-  | tv1 == tv2  -- Same type variable => no-op (but watch out for the boxy case)
-  = case details1 of
-        MetaTv BoxTv ref1  -- A boxy type variable meets itself;
-                           -- this is box-meets-box, so fill in with a tau-type
-              -> do { tau_tv <- tcInstTyVar tv1
-                    ; updateMeta tv1 ref1 (mkTyVarTy tau_tv)
-                    ; return IdCo
-                    }
-        _ -> return IdCo    -- No-op
-
-  | otherwise  -- Distinct type variables
-  = do  { lookup2 <- lookupTcTyVar tv2
-        ; case lookup2 of
-            IndirectTv ty2' -> uUnfilledVar outer swapped tv1 details1 ty2' ty2'
-            DoneTv details2 -> uUnfilledVars outer swapped tv1 details1 tv2 details2
-        }
-
-uUnfilledVar outer swapped tv1 details1 ps_ty2 non_var_ty2
-  =     -- ty2 is not a type variable
-    case details1 of
-      MetaTv (SigTv _) _ -> rigid_variable
-      MetaTv info ref1   -> uMetaVar outer swapped tv1 info ref1 ps_ty2 non_var_ty2
-      SkolemTv _         -> rigid_variable
-  where
-    rigid_variable
-      | isOpenSynTyConApp non_var_ty2
-      =           -- 'non_var_ty2's outermost constructor is a type family,
-                  -- which we may may be able to normalise
-        do { (coi2, ty2') <- tcNormaliseFamInst non_var_ty2
-           ; case coi2 of
-               IdCo   ->   -- no progress, but maybe after other instantiations
-                         defer_unification outer swapped (TyVarTy tv1) ps_ty2
-               ACo co ->   -- progress: so lets try again
-                 do { traceTc $
-                        ppr co <+> text "::"<+> ppr non_var_ty2 <+> text "~" <+>
-                        ppr ty2'
-                    ; coi <- uUnfilledVar outer swapped tv1 details1 ps_ty2 ty2'
-                    ; let coi2' = (if swapped then id else mkSymCoI) coi2
-                    ; return $ coi2' `mkTransCoI` coi
-                    }
-           }
-      | SkolemTv RuntimeUnkSkol <- details1
-                   -- runtime unknown will never match
-      = unifyMisMatch outer
-      | otherwise  -- defer as a given equality may still resolve this
-      = defer_unification outer swapped (TyVarTy tv1) ps_ty2
-\end{code}
 
 Note [Deferred Unification]
-~~~~~~~~~~~~~~~~~~~~
-We may encounter a unification ty1 = ty2 that cannot be performed syntactically,
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically,
 and yet its consistency is undetermined. Previously, there was no way to still
 make it consistent. So a mismatch error was issued.
 
@@ -1510,241 +785,171 @@ If available, we defer original types (rather than those where closed type
 synonyms have already been expanded via tcCoreView).  This is, as usual, to
 improve error messages.
 
-We need to both 'unBox' and zonk deferred types.  We need to unBox as
-functions, such as TcExpr.tcMonoExpr promise to fill boxes in the expected
-type.  We need to zonk as the types go into the kind of the coercion variable
-`cotv' and those are not zonked in Inst.zonkInst.  (Maybe it would be better
-to zonk in zonInst instead.  Would that be sufficient?)
+
+%************************************************************************
+%*                                                                      *
+                 uVar and friends
+%*                                                                      *
+%************************************************************************
+
+@uVar@ is called when at least one of the types being unified is a
+variable.  It does {\em not} assume that the variable is a fixed point
+of the substitution; rather, notice that @uVar@ (defined below) nips
+back into @uTys@ if it turns out that the variable is already bound.
 
 \begin{code}
-defer_unification :: Outer
-                  -> SwapFlag
-                  -> TcType
-                  -> TcType
-                  -> TcM CoercionI
-defer_unification outer True ty1 ty2
-  = defer_unification outer False ty2 ty1
-defer_unification outer False ty1 ty2
-  = do  { ty1' <- unBox ty1 >>= zonkTcType      -- unbox *and* zonk..
-        ; ty2' <- unBox ty2 >>= zonkTcType      -- ..see preceding note
-        ; traceTc $ text "deferring:" <+> ppr ty1 <+> text "~" <+> ppr ty2
-        ; cotv <- newMetaCoVar ty1' ty2'
-                -- put ty1 ~ ty2 in LIE
-                -- Left means "wanted"
-        ; inst <- popUnifyCtxt outer $
-                  mkEqInst (EqPred ty1' ty2') (Left cotv)
-        ; extendLIE inst
-        ; return $ ACo $ TyVarTy cotv  }
+uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM CoercionI
+uVar origin swapped tv1 ty2
+  = do  { traceTc "uVar" (vcat [ ppr origin
+                                , ppr swapped
+                                , ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)
+                       		, nest 2 (ptext (sLit " ~ "))
+                       		, ppr ty2 <+> dcolon <+> ppr (typeKind ty2)])
+        ; details <- lookupTcTyVar tv1
+        ; case details of
+            Filled ty1  -> unSwap swapped (uType_np origin) ty1 ty2
+            Unfilled details1 -> uUnfilledVar origin swapped tv1 details1 ty2
+        }
 
 ----------------
-uMetaVar :: Outer
-         -> SwapFlag
-         -> TcTyVar -> BoxInfo -> IORef MetaDetails
-         -> TcType -> TcType
-         -> TcM CoercionI
--- tv1 is an un-filled-in meta type variable (maybe boxy, maybe tau)
--- ty2 is not a type variable
-
-uMetaVar outer swapped tv1 BoxTv ref1 ps_ty2 ty2
-  =     -- tv1 is a BoxTv.  So we must unbox ty2, to ensure
-        -- that any boxes in ty2 are filled with monotypes
-        --
-        -- It should not be the case that tv1 occurs in ty2
-        -- (i.e. no occurs check should be needed), but if perchance
-        -- it does, the unbox operation will fill it, and the debug code
-        -- checks for that.
-    do { final_ty <- unBox ps_ty2
-       ; meta_details <- readMutVar ref1
-       ; case meta_details of
-                 Indirect _ ->   -- This *can* happen due to an occurs check,
-			    -- just as it can in checkTauTvUpdate in the next
-			    -- equation of uMetaVar; see Trac #2414
-			    -- Note [Occurs check]
-			-- Go round again.  Probably there's an immediate
-			-- error, but maybe not (a type function might discard
-			-- its argument).  Next time round we'll end up in the
-			-- TauTv case of uMetaVar.
-		   uVar outer swapped tv1 False ps_ty2 ty2
-			-- Setting for nb2::InBox is irrelevant
-
-                 Flexi -> do { checkUpdateMeta swapped tv1 ref1 final_ty
-			; return IdCo }
-        }
+uUnfilledVar :: [EqOrigin]
+             -> SwapFlag
+             -> TcTyVar -> TcTyVarDetails       -- Tyvar 1
+             -> TcTauType  			-- Type 2
+             -> TcM CoercionI
+-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar
+--            It might be a skolem, or untouchable, or meta
+
+uUnfilledVar origin swapped tv1 details1 (TyVarTy tv2)
+  | tv1 == tv2  -- Same type variable => no-op
+  = return (IdCo (mkTyVarTy tv1))
 
-uMetaVar outer swapped tv1 _ ref1 ps_ty2 _
-  = do  { -- Occurs check + monotype check
-        ; mb_final_ty <- checkTauTvUpdate tv1 ps_ty2
-        ; case mb_final_ty of
-            Nothing       ->    -- tv1 occured in type family parameter
-              defer_unification outer swapped (mkTyVarTy tv1) ps_ty2
-            Just final_ty ->
-              do { checkUpdateMeta swapped tv1 ref1 final_ty
-                 ; return IdCo
-                 }
+  | otherwise  -- Distinct type variables
+  = do  { lookup2 <- lookupTcTyVar tv2
+        ; case lookup2 of
+            Filled ty2'       -> uUnfilledVar origin swapped tv1 details1 ty2' 
+            Unfilled details2 -> uUnfilledVars origin swapped tv1 details1 tv2 details2
         }
 
-{- Note [Occurs check]
-   ~~~~~~~~~~~~~~~~~~~
-An eager occurs check is made in checkTauTvUpdate, deferring tricky
-cases by calling defer_unification (see notes with
-checkTauTvUpdate). An occurs check can also (and does) happen in the
-BoxTv case, but unBox doesn't check for occurrences, and in any case
-doesn't have the type-function-related complexity that
-checkTauTvUpdate has.  So we content ourselves with spotting the potential
-occur check (by the fact that tv1 is now filled), and going round again.
-Next time round we'll get the TauTv case of uMetaVar.
--}
+uUnfilledVar origin swapped tv1 details1 non_var_ty2  -- ty2 is not a type variable
+  = case details1 of
+      MetaTv TauTv ref1 
+        -> do { mb_ty2' <- checkTauTvUpdate tv1 non_var_ty2
+              ; case mb_ty2' of
+                  Nothing   -> do { traceTc "Occ/kind defer" (ppr tv1); defer }
+                  Just ty2' -> updateMeta tv1 ref1 ty2'
+              }
+
+      _other -> do { traceTc "Skolem defer" (ppr tv1); defer }		-- Skolems of all sorts
+  where
+    defer = unSwap swapped (uType_defer origin) (mkTyVarTy tv1) non_var_ty2
+          -- Occurs check or an untouchable: just defer
+	  -- NB: occurs check isn't necessarily fatal: 
+	  --     eg tv1 occured in type family parameter
 
 ----------------
-uUnfilledVars :: Outer
+uUnfilledVars :: [EqOrigin]
               -> SwapFlag
               -> TcTyVar -> TcTyVarDetails      -- Tyvar 1
               -> TcTyVar -> TcTyVarDetails      -- Tyvar 2
               -> TcM CoercionI
 -- Invarant: The type variables are distinct,
 --           Neither is filled in yet
---           They might be boxy or not
-
-uUnfilledVars outer swapped tv1 (SkolemTv _) tv2 (SkolemTv _)
-  = -- see [Deferred Unification]
-    defer_unification outer swapped (mkTyVarTy tv1) (mkTyVarTy tv2)
-
-uUnfilledVars _ swapped tv1 (MetaTv _ ref1) tv2 (SkolemTv _)
-  = checkUpdateMeta swapped tv1 ref1 (mkTyVarTy tv2) >> return IdCo
-uUnfilledVars _ swapped tv1 (SkolemTv _) tv2 (MetaTv _ ref2)
-  = checkUpdateMeta (not swapped) tv2 ref2 (mkTyVarTy tv1) >> return IdCo
-
--- ToDo: this function seems too long for what it acutally does!
-uUnfilledVars _ swapped tv1 (MetaTv info1 ref1) tv2 (MetaTv info2 ref2)
-  = case (info1, info2) of
-        (BoxTv,   BoxTv)   -> box_meets_box >> return IdCo
-
-        -- If a box meets a TauTv, but the fomer has the smaller kind
-        -- then we must create a fresh TauTv with the smaller kind
-        (_,       BoxTv)   | k1_sub_k2 -> update_tv2 >> return IdCo
-                           | otherwise -> box_meets_box >> return IdCo
-        (BoxTv,   _    )   | k2_sub_k1 -> update_tv1 >> return IdCo
-                           | otherwise -> box_meets_box >> return IdCo
-
-        -- Avoid SigTvs if poss
-        (SigTv _, _      ) | k1_sub_k2 -> update_tv2 >> return IdCo
-        (_,       SigTv _) | k2_sub_k1 -> update_tv1 >> return IdCo
-
-        (_,   _) | k1_sub_k2 -> if k2_sub_k1 && nicer_to_update_tv1
-                                then update_tv1 >> return IdCo  -- Same kinds
-                                else update_tv2 >> return IdCo
-                 | k2_sub_k1 -> update_tv1 >> return IdCo
-                 | otherwise -> kind_err >> return IdCo
-
-        -- Update the variable with least kind info
-        -- See notes on type inference in Kind.lhs
-        -- The "nicer to" part only applies if the two kinds are the same,
-        -- so we can choose which to do.
+
+uUnfilledVars origin swapped tv1 details1 tv2 details2
+  = case (details1, details2) of
+      (MetaTv i1 ref1, MetaTv i2 ref2)
+          | k1_sub_k2 -> if k2_sub_k1 && nicer_to_update_tv1 i1 i2
+                         then updateMeta tv1 ref1 ty2
+                         else updateMeta tv2 ref2 ty1
+          | k2_sub_k1 -> updateMeta tv1 ref1 ty2
+
+      (_, MetaTv _ ref2) | k1_sub_k2 -> updateMeta tv2 ref2 ty1
+      (MetaTv _ ref1, _) | k2_sub_k1 -> updateMeta tv1 ref1 ty2
+
+      (_, _) -> unSwap swapped (uType_defer origin) ty1 ty2
+      	        -- Defer for skolems of all sorts
   where
-        -- Kinds should be guaranteed ok at this point
-    update_tv1 = updateMeta tv1 ref1 (mkTyVarTy tv2)
-    update_tv2 = updateMeta tv2 ref2 (mkTyVarTy tv1)
-
-    box_meets_box | k1_sub_k2 = if k2_sub_k1 && nicer_to_update_tv1
-                                then fill_from tv2
-                                else fill_from tv1
-                  | k2_sub_k1 = fill_from tv2
-                  | otherwise = kind_err
-
-        -- Update *both* tyvars with a TauTv whose name and kind
-        -- are gotten from tv (avoid losing nice names is poss)
-    fill_from tv = do { tv' <- tcInstTyVar tv
-                      ; let tau_ty = mkTyVarTy tv'
-                      ; updateMeta tv1 ref1 tau_ty
-                      ; updateMeta tv2 ref2 tau_ty }
-
-    kind_err = addErrCtxtM (unifyKindCtxt swapped tv1 (mkTyVarTy tv2))  $
-               unifyKindMisMatch k1 k2
-
-    k1 = tyVarKind tv1
-    k2 = tyVarKind tv2
+    k1 	      = tyVarKind tv1
+    k2 	      = tyVarKind tv2
     k1_sub_k2 = k1 `isSubKind` k2
     k2_sub_k1 = k2 `isSubKind` k1
+    ty1       = mkTyVarTy tv1
+    ty2       = mkTyVarTy tv2
+
+    nicer_to_update_tv1 _         (SigTv _) = True
+    nicer_to_update_tv1 (SigTv _) _         = False
+    nicer_to_update_tv1 _         _         = isSystemName (Var.varName tv1)
+        -- Try not to update SigTvs; and try to update sys-y type
+        -- variables in preference to ones gotten (say) by
+        -- instantiating a polymorphic function with a user-written
+        -- type sig
 
-    nicer_to_update_tv1 = isSystemName (Var.varName tv1)
-        -- Try to update sys-y type variables in preference to ones
-        -- gotten (say) by instantiating a polymorphic function with
-        -- a user-written type sig
+----------------
+checkTauTvUpdate :: TcTyVar -> TcType -> TcM (Maybe TcType)
+--    (checkTauTvUpdate tv ty)
+-- We are about to update the TauTv tv with ty.
+-- Check (a) that tv doesn't occur in ty (occurs check)
+--       (b) that ty is a monotype
+--	 (c) that kind(ty) is a sub-kind of kind(tv)
+-- 
+-- We have two possible outcomes:
+-- (1) Return the type to update the type variable with, 
+--        [we know the update is ok]
+-- (2) Return Nothing,
+--        [the update might be dodgy]
+--
+-- Note that "Nothing" does not mean "definite error".  For example
+--   type family F a
+--   type instance F Int = Int
+-- consider
+--   a ~ F a
+-- This is perfectly reasonable, if we later get a ~ Int.  For now, though,
+-- we return Nothing, leaving it to the later constraint simplifier to
+-- sort matters out.
+
+checkTauTvUpdate tv ty
+  = do { ty' <- zonkTcType ty
+       ; if not (tv `elemVarSet` tyVarsOfType ty')
+            && typeKind ty' `isSubKind` tyVarKind tv 
+         then return (Just ty')
+         else return Nothing }
 \end{code}
 
+
 \begin{code}
-refineBox :: TcType -> TcM TcType
--- Unbox the outer box of a boxy type (if any)
-refineBox ty@(TyVarTy box_tv)
-  | isMetaTyVar box_tv
-  = do  { cts <- readMetaTyVar box_tv
-        ; case cts of
-                Flexi -> return ty
-                Indirect ty -> return ty }
-refineBox other_ty = return other_ty
-
-refineBoxToTau :: TcType -> TcM TcType
--- Unbox the outer box of a boxy type, filling with a monotype if it is empty
--- Like refineBox except for the "fill with monotype" part.
-refineBoxToTau (TyVarTy box_tv)
-  | isMetaTyVar box_tv
-  , MetaTv BoxTv ref <- tcTyVarDetails box_tv
-  = do  { cts <- readMutVar ref
-        ; case cts of
-                Flexi -> fillBoxWithTau box_tv ref
-                Indirect ty -> return ty }
-refineBoxToTau other_ty = return other_ty
-
-zapToMonotype :: BoxySigmaType -> TcM TcTauType
--- Subtle... we must zap the boxy res_ty
--- to kind * before using it to instantiate a LitInst
--- Calling unBox instead doesn't do the job, because the box
--- often has an openTypeKind, and we don't want to instantiate
--- with that type.
-zapToMonotype res_ty
-  = do  { res_tau <- newFlexiTyVarTy liftedTypeKind
-        ; _ <- boxyUnify res_tau res_ty
-        ; return res_tau }
-
-unBox :: BoxyType -> TcM TcType
--- unBox implements the judgement
---      |- s' ~ box(s)
--- with input s', and result s
---
--- It removes all boxes from the input type, returning a non-boxy type.
--- A filled box in the type can only contain a monotype; unBox fails if not
--- The type can have empty boxes, which unBox fills with a monotype
---
--- Compare this wth checkTauTvUpdate
---
--- For once, it's safe to treat synonyms as opaque!
-
-unBox (TyConApp tc tys) = do { tys' <- mapM unBox tys; return (TyConApp tc tys') }
-unBox (AppTy f a)       = do { f' <- unBox f; a' <- unBox a; return (mkAppTy f' a') }
-unBox (FunTy f a)       = do { f' <- unBox f; a' <- unBox a; return (FunTy f' a') }
-unBox (PredTy p)        = do { p' <- unBoxPred p; return (PredTy p') }
-unBox (ForAllTy tv ty)  = ASSERT( isImmutableTyVar tv )
-                          do { ty' <- unBox ty; return (ForAllTy tv ty') }
-unBox (TyVarTy tv)
-  | isTcTyVar tv                                -- It's a boxy type variable
-  , MetaTv BoxTv ref <- tcTyVarDetails tv       -- NB: non-TcTyVars are possible
-  = do  { cts <- readMutVar ref                 --     under nested quantifiers
-        ; case cts of
-            Flexi -> fillBoxWithTau tv ref
-            Indirect ty -> do { non_boxy_ty <- unBox ty
-                              ; if isTauTy non_boxy_ty
-                                then return non_boxy_ty
-                                else notMonoType non_boxy_ty }
-        }
-  | otherwise   -- Skolems, and meta-tau-variables
-  = return (TyVarTy tv)
+data LookupTyVarResult	-- The result of a lookupTcTyVar call
+  = Unfilled TcTyVarDetails	-- SkolemTv or virgin MetaTv
+  | Filled   TcType
+
+lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult
+lookupTcTyVar tyvar 
+  | MetaTv _ ref <- details
+  = do { meta_details <- readMutVar ref
+       ; case meta_details of
+           Indirect ty -> return (Filled ty)
+           Flexi -> do { is_untch <- isUntouchable tyvar
+                       ; let    -- Note [Unifying untouchables]
+                             ret_details | is_untch = SkolemTv UnkSkol
+                                         | otherwise = details
+       	               ; return (Unfilled ret_details) } }
+  | otherwise
+  = return (Unfilled details)
+  where
+    details = ASSERT2( isTcTyVar tyvar, ppr tyvar )
+              tcTyVarDetails tyvar
 
-unBoxPred :: PredType -> TcM PredType
-unBoxPred (ClassP cls tys) = do { tys' <- mapM unBox tys; return (ClassP cls tys') }
-unBoxPred (IParam ip ty)   = do { ty' <- unBox ty; return (IParam ip ty') }
-unBoxPred (EqPred ty1 ty2) = do { ty1' <- unBox ty1; ty2' <- unBox ty2; return (EqPred ty1' ty2') }
+updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM CoercionI
+updateMeta tv1 ref1 ty2
+  = do { writeMetaTyVarRef tv1 ref1 ty2
+       ; return (IdCo ty2) }
 \end{code}
 
+Note [Unifying untouchables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We treat an untouchable type variable as if it was a skolem.  That
+ensures it won't unify with anything.  It's a slight had, because
+we return a made-up TcTyVarDetails, but I think it works smoothly.
 
 
 %************************************************************************
@@ -1754,31 +959,71 @@ unBoxPred (EqPred ty1 ty2) = do { ty1' <- unBox ty1; ty2' <- unBox ty2; return (
 %************************************************************************
 
 \begin{code}
-unifyMisMatch :: Outer -> TcM a
-unifyMisMatch (Unify is_outer ty1 ty2)
-  | is_outer  = popErrCtxt $ failWithMisMatch ty1 ty2  -- This is the whole point of the 'outer' stuff
-  | otherwise = failWithMisMatch ty1 ty2
+pushOrigin :: TcType -> TcType -> [EqOrigin] -> [EqOrigin]
+pushOrigin ty_act ty_exp origin
+  = UnifyOrigin { uo_actual = ty_act, uo_expected = ty_exp } : origin
 
-popUnifyCtxt :: Outer -> TcM a -> TcM a
-popUnifyCtxt (Unify True  _ _) thing = popErrCtxt thing
-popUnifyCtxt (Unify False _ _) thing = thing
+---------------
+wrapEqCtxt :: [EqOrigin] -> TcM a -> TcM a
+-- Build a suitable error context from the origin and do the thing inside
+-- The "couldn't match" error comes from the innermost item on the stack,
+-- and, if there is more than one item, the "Expected/inferred" part
+-- comes from the outermost item
+wrapEqCtxt []    thing_inside = thing_inside
+wrapEqCtxt [_]   thing_inside = thing_inside
+wrapEqCtxt items thing_inside = addErrCtxtM (unifyCtxt (last items)) thing_inside
 
------------------------
-unifyCtxt :: TcType -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)
-unifyCtxt act_ty exp_ty tidy_env
+---------------
+failWithMisMatch :: [EqOrigin] -> TcM a
+-- Generate the message when two types fail to match,
+-- going to some trouble to make it helpful.
+-- The argument order is: actual type, expected type
+failWithMisMatch [] 
+  = panic "failWithMisMatch"
+failWithMisMatch origin@(item:_)
+  = wrapEqCtxt origin $
+    emitMisMatchErr (uo_actual item) (uo_expected item)
+
+mkExpectedActualMsg :: Type -> Type -> SDoc
+mkExpectedActualMsg act_ty exp_ty
+  = nest 2 (vcat [ text "Expected type" <> colon <+> ppr exp_ty,
+                   text "  Actual type" <> colon <+> ppr act_ty ])
+
+emitMisMatchErr :: TcType -> TcType -> TcM a
+emitMisMatchErr ty_act ty_exp
+  = do	{ ty_act <- zonkTcType ty_act
+        ; ty_exp <- zonkTcType ty_exp
+        ; env0 <- tcInitTidyEnv
+        ; let (env1, pp_exp) = tidyOpenType env0 ty_exp
+              (env2, pp_act) = tidyOpenType env1 ty_act
+        ; failWithTcM (misMatchMsg env2 pp_act pp_exp) }
+
+misMatchMsg :: TidyEnv -> TcType -> TcType -> (TidyEnv, SDoc)
+misMatchMsg env ty_act ty_exp
+  = (env2, sep [sep [ ptext (sLit "Couldn't match expected type") <+> quotes (ppr ty_exp)
+	            , nest 12 $   ptext (sLit "with actual type") <+> quotes (ppr ty_act)]
+               , nest 2 (extra1 $$ extra2) ])
+  where
+    (env1, extra1) = typeExtraInfoMsg env  ty_exp
+    (env2, extra2) = typeExtraInfoMsg env1 ty_act
+
+--------------------
+unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc)
+unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env
   = do  { act_ty' <- zonkTcType act_ty
         ; exp_ty' <- zonkTcType exp_ty
         ; let (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
               (env2, act_ty'') = tidyOpenType env1     act_ty'
         ; return (env2, mkExpectedActualMsg act_ty'' exp_ty'') }
+\end{code}
 
-----------------
-mkExpectedActualMsg :: Type -> Type -> SDoc
-mkExpectedActualMsg act_ty exp_ty
-  = nest 2 (vcat [ text "Expected type" <> colon <+> ppr exp_ty,
-                   text "Inferred type" <> colon <+> ppr act_ty ])
+
+-----------------------------------------
+	UNUSED FOR NOW
+-----------------------------------------
 
 ----------------
+----------------
 -- If an error happens we try to figure out whether the function
 -- function has been given too many or too few arguments, and say so.
 addSubCtxt :: InstOrigin -> TcType -> TcType -> TcM a -> TcM a
@@ -1803,24 +1048,6 @@ addSubCtxt orig actual_res_ty expected_res_ty thing_inside
                              _ -> mkExpectedActualMsg act_ty'' exp_ty''
            ; return (env2, message) }
 
-    wrongArgsCtxt too_many_or_few fun
-      = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
-        <+> ptext (sLit "is applied to") <+> text too_many_or_few
-        <+> ptext (sLit "arguments")
-
-------------------
-unifyForAllCtxt :: [TyVar] -> Type -> Type -> TidyEnv -> TcM (TidyEnv, SDoc)
-unifyForAllCtxt tvs phi1 phi2 env
-  = return (env2, msg)
-  where
-    (env', tvs') = tidyOpenTyVars env tvs       -- NB: not tidyTyVarBndrs
-    (env1, phi1') = tidyOpenType env' phi1
-    (env2, phi2') = tidyOpenType env1 phi2
-    msg = vcat [ptext (sLit "When matching") <+> quotes (ppr (mkForAllTys tvs' phi1')),
-                ptext (sLit "          and") <+> quotes (ppr (mkForAllTys tvs' phi2'))]
-\end{code}
-
-
 
 %************************************************************************
 %*                                                                      *
@@ -1831,9 +1058,27 @@ unifyForAllCtxt tvs phi1 phi2 env
 Unifying kinds is much, much simpler than unifying types.
 
 \begin{code}
+matchExpectedFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind))
+-- Like unifyFunTy, but does not fail; instead just returns Nothing
+
+matchExpectedFunKind (TyVarTy kvar) = do
+    maybe_kind <- readKindVar kvar
+    case maybe_kind of
+      Indirect fun_kind -> matchExpectedFunKind fun_kind
+      Flexi ->
+          do { arg_kind <- newKindVar
+             ; res_kind <- newKindVar
+             ; writeKindVar kvar (mkArrowKind arg_kind res_kind)
+             ; return (Just (arg_kind,res_kind)) }
+
+matchExpectedFunKind (FunTy arg_kind res_kind) = return (Just (arg_kind,res_kind))
+matchExpectedFunKind _                         = return Nothing
+
+-----------------
 unifyKind :: TcKind                 -- Expected
           -> TcKind                 -- Actual
           -> TcM ()
+
 unifyKind (TyConApp kc1 []) (TyConApp kc2 [])
   | isSubKindCon kc2 kc1 = return ()
 
@@ -1845,12 +1090,6 @@ unifyKind (TyVarTy kv1) k2 = uKVar False kv1 k2
 unifyKind k1 (TyVarTy kv2) = uKVar True kv2 k1
 unifyKind k1 k2 = unifyKindMisMatch k1 k2
 
-unifyKinds :: [TcKind] -> [TcKind] -> TcM ()
-unifyKinds []       []       = return ()
-unifyKinds (k1:ks1) (k2:ks2) = do unifyKind k1 k2
-                                  unifyKinds ks1 ks2
-unifyKinds _ _               = panic "unifyKinds: length mis-match"
-
 ----------------
 uKVar :: Bool -> KindVar -> TcKind -> TcM ()
 uKVar swapped kv1 k2
@@ -1915,6 +1154,17 @@ kindSimpleKind orig_swapped orig_kind
 -- T v = MkT v           v must be a type
 -- T v w = MkT (v -> w)  v must not be an umboxed tuple
 
+unifyKindMisMatch :: TcKind -> TcKind -> TcM ()
+unifyKindMisMatch ty1 ty2 = do
+    ty1' <- zonkTcKind ty1
+    ty2' <- zonkTcKind ty2
+    let
+	msg = hang (ptext (sLit "Couldn't match kind"))
+		   2 (sep [quotes (ppr ty1'), 
+			   ptext (sLit "against"), 
+			   quotes (ppr ty2')])
+    failWithTc msg
+
 ----------------
 kindOccurCheckErr :: Var -> Type -> SDoc
 kindOccurCheckErr tyvar ty
@@ -1922,24 +1172,6 @@ kindOccurCheckErr tyvar ty
        2 (sep [ppr tyvar, char '=', ppr ty])
 \end{code}
 
-\begin{code}
-unifyFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind))
--- Like unifyFunTy, but does not fail; instead just returns Nothing
-
-unifyFunKind (TyVarTy kvar) = do
-    maybe_kind <- readKindVar kvar
-    case maybe_kind of
-      Indirect fun_kind -> unifyFunKind fun_kind
-      Flexi ->
-          do { arg_kind <- newKindVar
-             ; res_kind <- newKindVar
-             ; writeKindVar kvar (mkArrowKind arg_kind res_kind)
-             ; return (Just (arg_kind,res_kind)) }
-
-unifyFunKind (FunTy arg_kind res_kind) = return (Just (arg_kind,res_kind))
-unifyFunKind _                         = return Nothing
-\end{code}
-
 %************************************************************************
 %*                                                                      *
 \subsection{Checking signature type variables}
@@ -1972,7 +1204,7 @@ are not mentioned in the environment.  In particular:
 
 Before doing this, the substitution is applied to the signature type variable.
 
-\begin{code}
+-- \begin{code}
 checkSigTyVars :: [TcTyVar] -> TcM ()
 checkSigTyVars sig_tvs = check_sig_tyvars emptyVarSet sig_tvs
 
@@ -1995,9 +1227,10 @@ check_sig_tyvars _ []
 check_sig_tyvars extra_tvs sig_tvs
   = ASSERT( all isTcTyVar sig_tvs && all isSkolemTyVar sig_tvs )
     do  { gbl_tvs <- tcGetGlobalTyVars
-        ; traceTc (text "check_sig_tyvars" <+> (vcat [text "sig_tys" <+> ppr sig_tvs,
-                                      text "gbl_tvs" <+> ppr gbl_tvs,
-                                      text "extra_tvs" <+> ppr extra_tvs]))
+        ; traceTc "check_sig_tyvars" $ vcat 
+               [ text "sig_tys" <+> ppr sig_tvs
+               , text "gbl_tvs" <+> ppr gbl_tvs
+               , text "extra_tvs" <+> ppr extra_tvs]
 
         ; let env_tvs = gbl_tvs `unionVarSet` extra_tvs
         ; when (any (`elemVarSet` env_tvs) sig_tvs)
@@ -2025,7 +1258,8 @@ bleatEscapedTvs globals sig_tvs zonked_tvs
     check (tidy_env, msgs) (sig_tv, zonked_tv)
       | not (zonked_tv `elemVarSet` globals) = return (tidy_env, msgs)
       | otherwise
-      = do { (tidy_env1, globs) <- findGlobals (unitVarSet zonked_tv) tidy_env
+      = do { lcl_env <- getLclTypeEnv
+           ; (tidy_env1, globs) <- findGlobals (unitVarSet zonked_tv) lcl_env tidy_env
            ; return (tidy_env1, escape_msg sig_tv zonked_tv globs : msgs) }
 
 -----------------------
@@ -2044,7 +1278,7 @@ escape_msg sig_tv zonked_tv globs
     is_bound_to
         | sig_tv == zonked_tv = empty
         | otherwise = ptext (sLit "is unified with") <+> quotes (ppr zonked_tv) <+> ptext (sLit "which")
-\end{code}
+-- \end{code}
 
 These two context are used with checkSigTyVars
 
diff --git a/compiler/typecheck/TcUnify.lhs-boot b/compiler/typecheck/TcUnify.lhs-boot
index 4d385b1..244f0cb 100644
--- a/compiler/typecheck/TcUnify.lhs-boot
+++ b/compiler/typecheck/TcUnify.lhs-boot
@@ -1,6 +1,6 @@
 \begin{code}
 module TcUnify where
-import TcType	( TcTauType, BoxySigmaType, BoxyType )
+import TcType	( TcTauType )
 import TcRnTypes( TcM )
 import Coercion (CoercionI)
 
@@ -8,6 +8,4 @@ import Coercion (CoercionI)
 --		TcUnify and TcSimplify
 
 unifyType :: TcTauType -> TcTauType -> TcM CoercionI
-boxyUnify :: BoxyType -> BoxyType -> TcM CoercionI
-zapToMonotype :: BoxySigmaType -> TcM TcTauType
 \end{code}
diff --git a/compiler/types/Class.lhs b/compiler/types/Class.lhs
index 566f183..1e16bc4 100644
--- a/compiler/types/Class.lhs
+++ b/compiler/types/Class.lhs
@@ -13,12 +13,14 @@ module Class (
 
 	FunDep,	pprFundeps, pprFunDep,
 
-	mkClass, classTyVars, classArity,
-	classKey, className, classATs, classSelIds, classTyCon, classMethods, classOpItems,
-	classBigSig, classExtraBigSig, classTvsFds, classSCTheta
+	mkClass, classTyVars, classArity, classSCNEqs,
+	classKey, className, classATs, classTyCon, classMethods,
+	classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,
+        classAllSelIds, classSCSelId
     ) where
 
 #include "Typeable.h"
+#include "HsVersions.h"
 
 import {-# SOURCE #-} TyCon	( TyCon )
 import {-# SOURCE #-} TypeRep	( PredType )
@@ -51,13 +53,19 @@ data Class
 	classTyVars  :: [TyVar],	-- The class type variables
 	classFunDeps :: [FunDep TyVar],	-- The functional dependencies
 
-	classSCTheta :: [PredType],	-- Immediate superclasses, and the
-	classSCSels  :: [Id],		-- corresponding selector functions
-					-- to extract them from a dictionary
-					-- of this class
-
+	-- Superclasses: eg: (F a ~ b, F b ~ G a, Eq a, Show b)
+        -- We need value-level selectors for the dictionary 
+	-- superclasses, but not for the equality superclasses
+	classSCTheta :: [PredType],	-- Immediate superclasses, 
+		     			---   *with equalities first*
+        classSCNEqs  :: Int,		-- How many equalities
+	classSCSels  :: [Id],		-- Selector functions to extract the
+		     			--   *dictionary* superclasses from a 
+					--   dictionary of this class
+	-- Associated types
         classATs     :: [TyCon],	-- Associated type families
 
+        -- Class operations
 	classOpStuff :: [ClassOpItem],	-- Ordered by tag
 
 	classTyCon :: TyCon		-- The data type constructor for
@@ -92,23 +100,24 @@ The @mkClass@ function fills in the indirect superclasses.
 \begin{code}
 mkClass :: Name -> [TyVar]
 	-> [([TyVar], [TyVar])]
-	-> [PredType] -> [Id]
+	-> [PredType] -> Int -> [Id]
 	-> [TyCon]
 	-> [ClassOpItem]
 	-> TyCon
 	-> Class
 
-mkClass name tyvars fds super_classes superdict_sels ats 
+mkClass name tyvars fds super_classes n_eqs superdict_sels ats 
 	op_stuff tycon
-  = Class {	classKey = getUnique name, 
-		className = name,
-		classTyVars = tyvars,
+  = Class {	classKey     = getUnique name, 
+		className    = name,
+		classTyVars  = tyvars,
 		classFunDeps = fds,
 		classSCTheta = super_classes,
-		classSCSels = superdict_sels,
-		classATs = ats,
+                classSCNEqs  = n_eqs,
+		classSCSels  = superdict_sels,
+		classATs     = ats,
 		classOpStuff = op_stuff,
-		classTyCon = tycon }
+		classTyCon   = tycon }
 \end{code}
 
 %************************************************************************
@@ -124,10 +133,21 @@ classArity :: Class -> Arity
 classArity clas = length (classTyVars clas)
 	-- Could memoise this
 
-classSelIds :: Class -> [Id]
-classSelIds c@(Class {classSCSels = sc_sels})
+classAllSelIds :: Class -> [Id]
+-- Both superclass-dictionary and method selectors
+classAllSelIds c@(Class {classSCSels = sc_sels})
   = sc_sels ++ classMethods c
 
+classSCSelId :: Class -> Int -> Id
+-- Get the n'th superclass selector Id
+-- where n is 0-indexed, and counts 
+--    *all* superclasses including equalities
+classSCSelId (Class { classSCNEqs = n_eqs, classSCSels = sc_sels }) n
+  = ASSERT( sc_sel_index >= 0 && sc_sel_index < length sc_sels )
+    sc_sels !! sc_sel_index
+  where
+    sc_sel_index = n - n_eqs	-- 0-index into classSCSels
+
 classMethods :: Class -> [Id]
 classMethods (Class {classOpStuff = op_stuff})
   = [op_sel | (op_sel, _) <- op_stuff]
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 794613b..dcd10fc 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -18,7 +18,8 @@ module Coercion (
         typeKind,
 
         -- ** Deconstructing Kinds 
-        kindFunResult, splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
+        kindFunResult, kindAppResult, synTyConResKind,
+        splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe,
 
         -- ** Predicates on Kinds
         isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
@@ -43,6 +44,8 @@ module Coercion (
         mkForAllCoercion, mkInstsCoercion, mkUnsafeCoercion,
         mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion,
         mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion, 
+                       
+        mkCoVarCoercion, 
 
 
         unsafeCoercionTyCon, symCoercionTyCon,
@@ -64,7 +67,7 @@ module Coercion (
 	mkSymCoI, mkTransCoI, 
 	mkTyConAppCoI, mkAppTyCoI, mkFunTyCoI,
 	mkForAllTyCoI,
-	fromCoI, fromACo,
+	fromCoI, 
 	mkClassPPredCoI, mkIParamPredCoI, mkEqPredCoI
 
        ) where 
@@ -96,6 +99,10 @@ import FastString
 kindFunResult :: Kind -> Kind
 kindFunResult k = funResultTy k
 
+kindAppResult :: Kind -> [arg] -> Kind
+kindAppResult k []     = k
+kindAppResult k (_:as) = kindAppResult (kindFunResult k) as
+
 -- | Essentially 'splitFunTys' on kinds
 splitKindFunTys :: Kind -> ([Kind],Kind)
 splitKindFunTys k = splitFunTys k
@@ -107,6 +114,13 @@ splitKindFunTy_maybe = splitFunTy_maybe
 splitKindFunTysN :: Int -> Kind -> ([Kind],Kind)
 splitKindFunTysN k = splitFunTysN k
 
+-- | Find the result 'Kind' of a type synonym, 
+-- after applying it to its 'arity' number of type variables
+-- Actually this function works fine on data types too, 
+-- but they'd always return '*', so we never need to ask
+synTyConResKind :: TyCon -> Kind
+synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon)
+
 -- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
 isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool
 isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon,
@@ -235,7 +249,6 @@ decomposeCo n co
     go n co cos = go (n-1) (mkLeftCoercion co)
 			   (mkRightCoercion co : cos)
 
-------------------------------
 
 -------------------------------------------------------
 -- and some coercion kind stuff
@@ -311,6 +324,9 @@ mkCoercion :: TyCon -> [Type] -> Coercion
 mkCoercion coCon args = ASSERT( tyConArity coCon == length args ) 
                         TyConApp coCon args
 
+mkCoVarCoercion :: CoVar -> Coercion 
+mkCoVarCoercion cv = mkTyVarTy cv 
+
 -- | Apply a 'Coercion' to another 'Coercion', which is presumably a
 -- 'Coercion' constructor of some kind
 mkAppCoercion :: Coercion -> Coercion -> Coercion
@@ -332,7 +348,7 @@ mkFunCoercion co1 co2 = mkFunTy co1 co2
 -- | Make a 'Coercion' which binds a variable within an inner 'Coercion'
 mkForAllCoercion :: Var -> Coercion -> Coercion
 -- note that a TyVar should be used here, not a CoVar (nor a TcTyVar)
-mkForAllCoercion tv  co  = ASSERT ( isTyVar tv ) mkForAllTy tv co
+mkForAllCoercion tv  co  = ASSERT ( isTyCoVar tv ) mkForAllTy tv co
 
 
 -------------------------------
@@ -532,8 +548,8 @@ instNewTyCon_maybe tc tys
   = ASSERT( tys `lengthIs` tyConArity tc )
     Just (substTyWith tvs tys ty, 
 	  case mb_co_tc of
-	   Nothing    -> IdCo
-	   Just co_tc -> ACo (mkTyConApp co_tc tys))
+	     Nothing    -> IdCo (mkTyConApp tc    tys)
+	     Just co_tc -> ACo  (mkTyConApp co_tc tys))
   | otherwise
   = Nothing
 
@@ -553,7 +569,7 @@ splitNewTypeRepCo_maybe (TyConApp tc tys)
   | Just (ty', coi) <- instNewTyCon_maybe tc tys
   = case coi of
 	ACo co -> Just (ty', co)
-	IdCo   -> panic "splitNewTypeRepCo_maybe"
+	IdCo _ -> panic "splitNewTypeRepCo_maybe"
 			-- This case handled by coreView
 splitNewTypeRepCo_maybe _
   = Nothing
@@ -584,91 +600,82 @@ coreEqCoercion2 = coreEqType2
 -- 1. A proper 'Coercion'
 --
 -- 2. The identity coercion
-data CoercionI = IdCo | ACo Coercion
+data CoercionI = IdCo Type | ACo Coercion
+
+liftCoI :: (Type -> Type) -> CoercionI -> CoercionI
+liftCoI f (IdCo ty) = IdCo (f ty)
+liftCoI f (ACo ty)  = ACo (f ty)
+
+liftCoI2 :: (Type -> Type -> Type) -> CoercionI -> CoercionI -> CoercionI
+liftCoI2 f (IdCo ty1) (IdCo ty2) = IdCo (f ty1 ty2)
+liftCoI2 f coi1       coi2       = ACo (f (fromCoI coi1) (fromCoI coi2))
+
+liftCoIs :: ([Type] -> Type) -> [CoercionI] -> CoercionI
+liftCoIs f cois = go_id [] cois
+  where
+    go_id rev_tys []               = IdCo (f (reverse rev_tys))
+    go_id rev_tys (IdCo ty : cois) = go_id  (ty:rev_tys) cois
+    go_id rev_tys (ACo  co : cois) = go_aco (co:rev_tys) cois
+
+    go_aco rev_tys []               = ACo (f (reverse rev_tys))
+    go_aco rev_tys (IdCo ty : cois) = go_aco (ty:rev_tys) cois
+    go_aco rev_tys (ACo  co : cois) = go_aco (co:rev_tys) cois
 
 instance Outputable CoercionI where
-  ppr IdCo     = ptext (sLit "IdCo")
+  ppr (IdCo _) = ptext (sLit "IdCo")
   ppr (ACo co) = ppr co
 
 isIdentityCoI :: CoercionI -> Bool
-isIdentityCoI IdCo = True
-isIdentityCoI _    = False
-
--- | Tests whether all the given 'CoercionI's represent the identity coercion
-allIdCoIs :: [CoercionI] -> Bool
-allIdCoIs = all isIdentityCoI
-
--- | For each 'CoercionI' in the input list, return either the 'Coercion' it
--- contains or the corresponding 'Type' from the other list
-zipCoArgs :: [CoercionI] -> [Type] -> [Coercion]
-zipCoArgs cois tys = zipWith fromCoI cois tys
+isIdentityCoI (IdCo _) = True
+isIdentityCoI (ACo _)  = False
 
 -- | Return either the 'Coercion' contained within the 'CoercionI' or the given
 -- 'Type' if the 'CoercionI' is the identity 'Coercion'
-fromCoI :: CoercionI -> Type -> Type
-fromCoI IdCo ty     = ty	-- Identity coercion represented 
-fromCoI (ACo co) _  = co	-- 	by the type itself
+fromCoI :: CoercionI -> Type
+fromCoI (IdCo ty) = ty	-- Identity coercion represented 
+fromCoI (ACo co)  = co	-- 	by the type itself
 
 -- | Smart constructor for @sym@ on 'CoercionI', see also 'mkSymCoercion'
 mkSymCoI :: CoercionI -> CoercionI
-mkSymCoI IdCo = IdCo
-mkSymCoI (ACo co) = ACo $ mkCoercion symCoercionTyCon [co] 
+mkSymCoI (IdCo ty) = IdCo ty
+mkSymCoI (ACo co)  = ACo $ mkCoercion symCoercionTyCon [co] 
 				-- the smart constructor
 				-- is too smart with tyvars
 
 -- | Smart constructor for @trans@ on 'CoercionI', see also 'mkTransCoercion'
 mkTransCoI :: CoercionI -> CoercionI -> CoercionI
-mkTransCoI IdCo aco = aco
-mkTransCoI aco IdCo = aco
+mkTransCoI (IdCo _) aco = aco
+mkTransCoI aco (IdCo _) = aco
 mkTransCoI (ACo co1) (ACo co2) = ACo $ mkTransCoercion co1 co2
 
 -- | Smart constructor for type constructor application on 'CoercionI', see also 'mkAppCoercion'
-mkTyConAppCoI :: TyCon -> [Type] -> [CoercionI] -> CoercionI
-mkTyConAppCoI tyCon tys cois
-  | allIdCoIs cois = IdCo
-  | otherwise	   = ACo (TyConApp tyCon (zipCoArgs cois tys))
+mkTyConAppCoI :: TyCon -> [CoercionI] -> CoercionI
+mkTyConAppCoI tyCon cois = liftCoIs (mkTyConApp tyCon) cois
 
 -- | Smart constructor for honest-to-god 'Coercion' application on 'CoercionI', see also 'mkAppCoercion'
-mkAppTyCoI :: Type -> CoercionI -> Type -> CoercionI -> CoercionI
-mkAppTyCoI _   IdCo _   IdCo = IdCo
-mkAppTyCoI ty1 coi1 ty2 coi2 =
-	ACo $ AppTy (fromCoI coi1 ty1) (fromCoI coi2 ty2)
-
+mkAppTyCoI :: CoercionI -> CoercionI -> CoercionI
+mkAppTyCoI = liftCoI2 mkAppTy
 
-mkFunTyCoI :: Type -> CoercionI -> Type -> CoercionI -> CoercionI
-mkFunTyCoI _   IdCo _   IdCo = IdCo
-mkFunTyCoI ty1 coi1 ty2 coi2 =
-	ACo $ mkFunTy (fromCoI coi1 ty1) (fromCoI coi2 ty2)
+mkFunTyCoI :: CoercionI -> CoercionI -> CoercionI
+mkFunTyCoI = liftCoI2 mkFunTy
 
 -- | Smart constructor for quantified 'Coercion's on 'CoercionI', see also 'mkForAllCoercion'
 mkForAllTyCoI :: TyVar -> CoercionI -> CoercionI
-mkForAllTyCoI _ IdCo = IdCo
-mkForAllTyCoI tv (ACo co) = ACo $ ForAllTy tv co
-
--- | Extract a 'Coercion' from a 'CoercionI' if it represents one. If it is the identity coercion,
--- panic
-fromACo :: CoercionI -> Coercion
-fromACo (ACo co)  = co
-fromACo (IdCo {}) = panic "fromACo"
+mkForAllTyCoI tv = liftCoI (ForAllTy tv)
 
 -- | Smart constructor for class 'Coercion's on 'CoercionI'. Satisfies:
 --
 -- > mkClassPPredCoI cls tys cois :: PredTy (cls tys) ~ PredTy (cls (tys `cast` cois))
-mkClassPPredCoI :: Class -> [Type] -> [CoercionI] -> CoercionI
-mkClassPPredCoI cls tys cois 
-  | allIdCoIs cois = IdCo
-  | otherwise      = ACo $ PredTy $ ClassP cls (zipCoArgs cois tys)
+mkClassPPredCoI :: Class -> [CoercionI] -> CoercionI
+mkClassPPredCoI cls = liftCoIs (PredTy . ClassP cls)
 
 -- | Smart constructor for implicit parameter 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI'
 mkIParamPredCoI :: (IPName Name) -> CoercionI -> CoercionI 
-mkIParamPredCoI _   IdCo     = IdCo
-mkIParamPredCoI ipn (ACo co) = ACo $ PredTy $ IParam ipn co
+mkIParamPredCoI ipn = liftCoI (PredTy . IParam ipn)
 
 -- | Smart constructor for type equality 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI'
-mkEqPredCoI :: Type -> CoercionI -> Type -> CoercionI -> CoercionI
-mkEqPredCoI _    IdCo     _   IdCo      = IdCo
-mkEqPredCoI ty1  IdCo     _   (ACo co2) = ACo $ PredTy $ EqPred ty1 co2
-mkEqPredCoI _   (ACo co1) ty2 coi2      = ACo $ PredTy $ EqPred co1 (fromCoI coi2 ty2)
+mkEqPredCoI :: CoercionI -> CoercionI -> CoercionI
+mkEqPredCoI = liftCoI2 (\t1 t2 -> PredTy (EqPred t1 t2))
 \end{code}
 
 %************************************************************************
@@ -681,7 +688,7 @@ mkEqPredCoI _   (ACo co1) ty2 coi2      = ACo $ PredTy $ EqPred co1 (fromCoI coi
 typeKind :: Type -> Kind
 typeKind ty@(TyConApp tc tys) 
   | isCoercionTyCon tc = typeKind (fst (coercionKind ty))
-  | otherwise          = foldr (\_ k -> kindFunResult k) (tyConKind tc) tys
+  | otherwise          = kindAppResult (tyConKind tc) tys
 	-- During coercion optimisation we *do* match a type
 	-- against a coercion (see OptCoercion.matchesAxiomLhs)
 	-- So the use of typeKind in Unify.match_kind must work on coercions too
diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index 89fd193..4cf33fc 100644
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -307,7 +307,7 @@ lookup_fam_inst_env 	      -- The worker, local to this module
     -> TyCon -> [Type]		-- What we are looking for
     -> [FamInstMatch] 	        -- Successful matches
 lookup_fam_inst_env match_fun one_sided (pkg_ie, home_ie) fam tys
-  | not (isOpenTyCon fam) 
+  | not (isFamilyTyCon fam) 
   = []
   | otherwise
   = ASSERT( n_tys >= arity )	-- Family type applications must be saturated
@@ -416,7 +416,7 @@ topNormaliseType env ty
 		   | otherwise		 = rec_nts
 
     go rec_nts (TyConApp tc tys)		-- Expand open tycons
-	| isOpenTyCon tc
+	| isFamilyTyCon tc
 	, (ACo co, ty) <- normaliseTcApp env tc tys
 	= 	-- The ACo says "something happened"
 		-- Note that normaliseType fully normalises, but it has do to so
@@ -437,7 +437,7 @@ normaliseTcApp env tc tys
   = let	-- First normalise the arg types so that they'll match 
 	-- when we lookup in in the instance envt
 	(cois, ntys) = mapAndUnzip (normaliseType env) tys
-	tycon_coi    = mkTyConAppCoI tc ntys cois
+	tycon_coi    = mkTyConAppCoI tc cois
     in 	-- Now try the top-level redex
     case lookupFamInstEnv env tc ntys of
 		-- A matching family instance exists
@@ -468,16 +468,16 @@ normaliseType env (TyConApp tc tys)
 normaliseType env (AppTy ty1 ty2)
   = let (coi1,nty1) = normaliseType env ty1
         (coi2,nty2) = normaliseType env ty2
-    in  (mkAppTyCoI nty1 coi1 nty2 coi2, AppTy nty1 nty2)
+    in  (mkAppTyCoI coi1 coi2, AppTy nty1 nty2)
 normaliseType env (FunTy ty1 ty2)
   = let (coi1,nty1) = normaliseType env ty1
         (coi2,nty2) = normaliseType env ty2
-    in  (mkFunTyCoI nty1 coi1 nty2 coi2, FunTy nty1 nty2)
+    in  (mkFunTyCoI coi1 coi2, FunTy nty1 nty2)
 normaliseType env (ForAllTy tyvar ty1)
   = let (coi,nty1) = normaliseType env ty1
-    in  (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1)
+    in  (mkForAllTyCoI tyvar coi, ForAllTy tyvar nty1)
 normaliseType _   ty@(TyVarTy _)
-  = (IdCo,ty)
+  = (IdCo ty,ty)
 normaliseType env (PredTy predty)
   = normalisePred env predty
 
@@ -485,12 +485,12 @@ normaliseType env (PredTy predty)
 normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type)
 normalisePred env (ClassP cls tys)
   =	let (cois,tys') = mapAndUnzip (normaliseType env) tys
-	in  (mkClassPPredCoI cls tys' cois, PredTy $ ClassP cls tys')
+	in  (mkClassPPredCoI cls cois, PredTy $ ClassP cls tys')
 normalisePred env (IParam ipn ty)
   = 	let (coi,ty') = normaliseType env ty
 	in  (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty')
 normalisePred env (EqPred ty1 ty2)
   = 	let (coi1,ty1') = normaliseType env ty1
             (coi2,ty2') = normaliseType env ty2
-	in  (mkEqPredCoI ty1' coi1 ty2' coi2, PredTy $ EqPred ty1' ty2')
+	in  (mkEqPredCoI coi1 coi2, PredTy $ EqPred ty1' ty2')
 \end{code}
diff --git a/compiler/types/FunDeps.lhs b/compiler/types/FunDeps.lhs
index 02b0a2a..0bea32f 100644
--- a/compiler/types/FunDeps.lhs
+++ b/compiler/types/FunDeps.lhs
@@ -9,8 +9,8 @@ It's better to read it as: "if we know these, then we're going to know these"
 
 \begin{code}
 module FunDeps (
- 	Equation, pprEquation,
-	oclose, improveOne,
+ 	Equation, pprEquation, 
+	oclose, improveFromInstEnv, improveFromAnother,
 	checkInstCoverage, checkFunDeps,
 	pprFundeps
     ) where
@@ -200,6 +200,21 @@ NOTA BENE:
 \begin{code}
 type Pred_Loc = (PredType, SDoc)	-- SDoc says where the Pred comes from
 
+improveFromInstEnv :: (Class -> [Instance]) 
+                     -> Pred_Loc 
+                     -> [(Equation,Pred_Loc,Pred_Loc)]
+-- Improvement from top-level instances 
+improveFromInstEnv _inst_env pred 
+  = improveOne _inst_env pred []        -- TODO: Refactor to directly use instance_eqnd? 
+
+improveFromAnother :: Pred_Loc 
+                   -> Pred_Loc
+                   -> [(Equation,Pred_Loc,Pred_Loc)] 
+-- Improvement from another local (given or wanted) constraint
+improveFromAnother pred1 pred2 
+  = improveOne (\_ -> []) pred1 [pred2] -- TODO: Refactor to directly use pairwise_eqns?
+
+
 improveOne :: (Class -> [Instance])		-- Gives instances for given class
 	   -> Pred_Loc				-- Do improvement triggered by this
 	   -> [Pred_Loc]			-- Current constraints 
diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index 49b49b8..09b9b53 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -45,7 +45,6 @@ import Data.Maybe	( isJust, isNothing )
 %************************************************************************
 
 \begin{code}
-type DFunId = Id
 data Instance 
   = Instance { is_cls  :: Name		-- Class name
 	
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index 12f3935..b552c24 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -11,10 +11,9 @@ module TyCon(
 	TyCon, FieldLabel, 
 
 	AlgTyConRhs(..), visibleDataCons, 
-        TyConParent(..), 
+        TyConParent(..), isNoParent,
 	SynTyConRhs(..),
         CoTyConDesc(..),
-	AssocFamilyPermutation,
 
         -- ** Constructing TyCons
 	mkAlgTyCon,
@@ -36,14 +35,15 @@ module TyCon(
         isFunTyCon, 
         isPrimTyCon,
         isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, 
-        isSynTyCon, isClosedSynTyCon, isOpenSynTyCon,
+        isSynTyCon, isClosedSynTyCon, 
         isSuperKindTyCon, isDecomposableTyCon,
         isCoercionTyCon, isCoercionTyCon_maybe,
         isForeignTyCon, isAnyTyCon, tyConHasKind,
 
 	isInjectiveTyCon,
 	isDataTyCon, isProductTyCon, isEnumerationTyCon, 
-	isNewTyCon, isAbstractTyCon, isOpenTyCon,
+	isNewTyCon, isAbstractTyCon, 
+        isFamilyTyCon, isSynFamilyTyCon, isDataFamilyTyCon,
         isUnLiftedTyCon,
 	isGadtSyntaxTyCon,
 	isTyConAssoc,
@@ -60,20 +60,19 @@ module TyCon(
 	tyConFamilySize,
 	tyConStupidTheta,
 	tyConArity,
+        tyConParent,
 	tyConClass_maybe,
-	tyConFamInst_maybe, tyConFamilyCoercion_maybe,
-	synTyConDefn, synTyConRhs, synTyConType, synTyConResKind,
+	tyConFamInst_maybe, tyConFamilyCoercion_maybe,tyConFamInstSig_maybe,
+	synTyConDefn, synTyConRhs, synTyConType, 
 	tyConExtName,		-- External name for foreign types
 	algTyConRhs,
         newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, 
-        assocTyConArgPoss_maybe,
         tupleTyConBoxity,
 
         -- ** Manipulating TyCons
 	tcExpandTyCon_maybe, coreExpandTyCon_maybe,
 	makeTyConAbstract,
 	newTyConCo_maybe,
-	setTyConArgPoss, 
 
         -- * Primitive representations of Types
 	PrimRep(..),
@@ -97,7 +96,6 @@ import FastString
 import Constants
 import Util
 import qualified Data.Data as Data
-import Data.List( elemIndex )
 \end{code}
 
 -----------------------------------------------
@@ -113,8 +111,10 @@ Note [Type synonym families]
 	type instance F Int = Bool
 	..etc...
 
-* From the user's point of view (F Int) and Bool are simply equivalent
-  types.
+* Reply "yes" to isSynFamilyTyCon, and isFamilyTyCon
+
+* From the user's point of view (F Int) and Bool are simply 
+  equivalent types.
 
 * A Haskell 98 type synonym is a degenerate form of a type synonym
   family.
@@ -122,6 +122,23 @@ Note [Type synonym families]
 * Type functions can't appear in the LHS of a type function:
 	type instance F (F Int) = ...	-- BAD!
 
+* Translation of type family decl:
+	type family F a :: *
+  translates to
+    a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon
+
+* Translation of type instance decl:
+	type instance F [a] = Maybe a
+  translates to
+    A SynTyCon 'R:FList a', whose 
+       SynTyConRhs is (SynonymTyCon (Maybe a))
+       TyConParent is (FamInstTyCon F [a] co)
+         where co :: F [a] ~ R:FList a
+    Notice that we introduce a gratuitous vanilla type synonym
+       type R:FList a = Maybe a
+    solely so that type and data families can be treated more
+    uniformly, via a single FamInstTyCon descriptor        
+
 * In the future we might want to support
     * closed type families (esp when we have proper kinds)
     * injective type families (allow decomposition)
@@ -137,6 +154,8 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs
 
   Here T is the "family TyCon".
 
+* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon
+
 * The user does not see any "equivalent types" as he did with type
   synonym families.  He just sees constructors with types
 	T1 :: T Int
@@ -150,7 +169,7 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs
 
   The R:TInt is the "representation TyCons".
   It has an AlgTyConParent of
-	FamilyTyCon T [Int] ax_ti
+	FamInstTyCon T [Int] ax_ti
 
 * The data contructor T2 has a wrapper (which is what the 
   source-level "T2" invokes):
@@ -181,7 +200,7 @@ See also Note [Wrappers for data instance tycons] in MkId.lhs
 
   The representation TyCon R:TList, has an AlgTyConParent of
 
-	FamilyTyCon T [(a,b)] ax_pr
+	FamInstTyCon T [(a,b)] ax_pr
 
 * Notice that T is NOT translated to a FC type function; it just
   becomes a "data type" with no constructors, which can be coerced inot
@@ -403,13 +422,11 @@ data AlgTyConRhs
     --
     -- > data T a :: *
     --
-    -- Or an assoicated data type declaration, within a class declaration:
+    -- Or an associated data type declaration, within a class declaration:
     --
     -- > class C a b where
     -- >   data T b :: *
-  | OpenTyCon {
-      otArgPoss :: AssocFamilyPermutation
-    }
+  | DataFamilyTyCon
 
     -- | Information about those 'TyCon's derived from a @data@
     -- declaration. This includes data types with no constructors at
@@ -459,24 +476,12 @@ data AlgTyConRhs
 			       -- again check Trac #1072.
     }
 
-type AssocFamilyPermutation
-  = Maybe [Int]  -- Nothing for *top-level* type families
-                 -- For *associated* type families, gives the position
-	         -- of that 'TyVar' in the class argument list (0-indexed)
-		 -- e.g.  class C a b c where { type F c a :: *->* }
-                 --       Then we get Just [2,0]
-	 -- For *synonyms*, the length of the list is identical to
-	 -- 		    the TyCon's arity
-	 -- For *data types*, the length may be smaller than the
-	 -- 	TyCon's arity; e.g. class C a where { data D a :: *->* }
-	 -- 		       here D gets arity 2
-
 -- | Extract those 'DataCon's that we are able to learn about.  Note
 -- that visibility in this sense does not correspond to visibility in
 -- the context of any particular user program!
 visibleDataCons :: AlgTyConRhs -> [DataCon]
 visibleDataCons AbstractTyCon      	      = []
-visibleDataCons OpenTyCon {}		      = []
+visibleDataCons DataFamilyTyCon {}		      = []
 visibleDataCons (DataTyCon{ data_cons = cs }) = cs
 visibleDataCons (NewTyCon{ data_con = c })    = [c]
 
@@ -493,6 +498,10 @@ data TyConParent
   | ClassTyCon      	
 	Class		-- INVARIANT: the classTyCon of this Class is the current tycon
 
+  -- | An *associated* type of a class.  
+  | AssocFamilyTyCon   
+        Class			-- The class in whose declaration the family is declared
+
   -- | Type constructors representing an instance of a type family. Parameters:
   --
   --  1) The type family in question
@@ -503,30 +512,39 @@ data TyConParent
   --
   --  3) A 'CoTyCon' identifying the representation
   --  type with the type instance family
-  | FamilyTyCon	  -- See Note [Data type families]
-	TyCon
-	[Type]
-	TyCon  -- c.f. Note [Newtype coercions]
-
+  | FamInstTyCon	  -- See Note [Data type families]
+    			  -- and Note [Type synonym families]
+	TyCon   -- The family TyCon
+	[Type]	-- Argument types (mentions the tyConTyVars of this TyCon)
+	TyCon   -- The coercion constructor
+
+	-- E.g.  data intance T [a] = ...
+	-- gives a representation tycon:
+	--	data R:TList a = ...
+	-- 	axiom co a :: T [a] ~ R:TList a
+	-- with R:TList's algTcParent = FamInstTyCon T [a] co
 
 -- | Checks the invariants of a 'TyConParent' given the appropriate type class name, if any
 okParent :: Name -> TyConParent -> Bool
-okParent _       NoParentTyCon                   = True
-okParent tc_name (ClassTyCon cls)                = tyConName (classTyCon cls) == tc_name
-okParent _       (FamilyTyCon fam_tc tys _co_tc) = tyConArity fam_tc == length tys
+okParent _       NoParentTyCon                    = True
+okParent tc_name (AssocFamilyTyCon cls)           = tc_name `elem` map tyConName (classATs cls)
+okParent tc_name (ClassTyCon cls)                 = tc_name == tyConName (classTyCon cls)
+okParent _       (FamInstTyCon fam_tc tys _co_tc) = tyConArity fam_tc == length tys
+
+isNoParent :: TyConParent -> Bool
+isNoParent NoParentTyCon = True
+isNoParent _             = False
 
 --------------------
 
 -- | Information pertaining to the expansion of a type synonym (@type@)
 data SynTyConRhs
-  = OpenSynTyCon      -- e.g. type family F x y :: * -> *
-       Kind	      -- Kind of the "rhs"; ie *excluding type indices*
-       		      --     In the example, the kind is (*->*)
-       AssocFamilyPermutation
+  = SynonymTyCon      -- ^ An ordinary type synony
+       Type	      -- ^ The rhs, which mentions head type variables. It acts as a
+		      -- template for the expansion when the 'TyCon' is applied to some
+		      -- types.
 
-  | SynonymTyCon Type   -- ^ The synonym mentions head type variables. It acts as a
-			-- template for the expansion when the 'TyCon' is applied to some
-			-- types.
+   | SynFamilyTyCon   -- A type synonym family  e.g. type family F x y :: * -> *
 
 --------------------
 data CoTyConDesc
@@ -883,7 +901,7 @@ isDataTyCon :: TyCon -> Bool
 --     get an info table.  The family declaration 'TyCon' does not
 isDataTyCon (AlgTyCon {algTcRhs = rhs})
   = case rhs of
-        OpenTyCon {}  -> False
+        DataFamilyTyCon {}  -> False
 	DataTyCon {}  -> True
 	NewTyCon {}   -> False
 	AbstractTyCon -> False	 -- We don't know, so return False
@@ -932,14 +950,6 @@ isSynTyCon _		 = False
 -- right hand side to which a synonym family application can expand.
 --
 
--- | Is this a synonym 'TyCon' that can have no further instances appear?
-isClosedSynTyCon :: TyCon -> Bool
-isClosedSynTyCon tycon = isSynTyCon tycon && not (isOpenTyCon tycon)
-
--- | Is this a synonym 'TyCon' that can have may have further instances appear?
-isOpenSynTyCon :: TyCon -> Bool
-isOpenSynTyCon tycon = isSynTyCon tycon && isOpenTyCon tycon
-
 isDecomposableTyCon :: TyCon -> Bool
 -- True iff we can decompose (T a b c) into ((T a b) c)
 -- Specifically NOT true of synonyms (open and otherwise) and coercions
@@ -959,10 +969,24 @@ isEnumerationTyCon (TupleTyCon {tyConArity = arity}) = arity == 0
 isEnumerationTyCon _                                                   = False
 
 -- | Is this a 'TyCon', synonym or otherwise, that may have further instances appear?
-isOpenTyCon :: TyCon -> Bool
-isOpenTyCon (SynTyCon {synTcRhs = OpenSynTyCon {}}) = True
-isOpenTyCon (AlgTyCon {algTcRhs = OpenTyCon {}})    = True
-isOpenTyCon _					    = False
+isFamilyTyCon :: TyCon -> Bool
+isFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon {}})  = True
+isFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True
+isFamilyTyCon _	= False
+
+-- | Is this a synonym 'TyCon' that can have may have further instances appear?
+isSynFamilyTyCon :: TyCon -> Bool
+isSynFamilyTyCon (SynTyCon {synTcRhs = SynFamilyTyCon {}}) = True
+isSynFamilyTyCon _ = False
+
+-- | Is this a synonym 'TyCon' that can have may have further instances appear?
+isDataFamilyTyCon :: TyCon -> Bool
+isDataFamilyTyCon (AlgTyCon {algTcRhs = DataFamilyTyCon {}}) = True
+isDataFamilyTyCon _ = False
+
+-- | Is this a synonym 'TyCon' that can have no further instances appear?
+isClosedSynTyCon :: TyCon -> Bool
+isClosedSynTyCon tycon = isSynTyCon tycon && not (isFamilyTyCon tycon)
 
 -- | Injective 'TyCon's can be decomposed, so that
 --     T ty1 ~ T ty2  =>  ty1 ~ ty2
@@ -975,36 +999,12 @@ isInjectiveTyCon tc = not (isSynTyCon tc)
 	-- type synonym, because you should probably have expanded it first
 	-- But regardless, it's not injective!
 
--- | Extract the mapping from 'TyVar' indexes to indexes in the corresponding family
--- argument lists form an open 'TyCon' of any sort, if the given 'TyCon' is indeed
--- such a beast and that information is available
-assocTyConArgPoss_maybe :: TyCon -> Maybe [Int]
-assocTyConArgPoss_maybe (AlgTyCon { 
-			   algTcRhs = OpenTyCon {otArgPoss = poss}})  = poss
-assocTyConArgPoss_maybe (SynTyCon { synTcRhs = OpenSynTyCon _ poss }) = poss
-assocTyConArgPoss_maybe _ = Nothing
-
 -- | Are we able to extract informationa 'TyVar' to class argument list
 -- mappping from a given 'TyCon'?
 isTyConAssoc :: TyCon -> Bool
-isTyConAssoc = isJust . assocTyConArgPoss_maybe
-
--- | Set the AssocFamilyPermutation structure in an 
--- associated data or type synonym.  The [TyVar] are the
--- class type variables.  Remember, the tyvars of an associated
--- data/type are a subset of the class tyvars; except that an
--- associated data type can have extra type variables at the
--- end (see Note [Avoid name clashes for associated data types] in TcHsType)
-setTyConArgPoss :: [TyVar] -> TyCon -> TyCon
-setTyConArgPoss clas_tvs tc
-  = case tc of
-      AlgTyCon { algTcRhs = rhs }               -> tc { algTcRhs = rhs {otArgPoss = Just ps} }
-      SynTyCon { synTcRhs = OpenSynTyCon ki _ } -> tc { synTcRhs = OpenSynTyCon ki (Just ps) }
-      _                                         -> pprPanic "setTyConArgPoss" (ppr tc)
-  where
-    ps = catMaybes [tv `elemIndex` clas_tvs | tv <- tyConTyVars tc]
-       -- We will get Nothings for the "extra" type variables in an
-       -- associated data type
+isTyConAssoc tc = case tyConParent tc of
+                     AssocFamilyTyCon {} -> True
+                     _                   -> False
 
 -- The unit tycon didn't used to be classed as a tuple tycon
 -- but I thought that was silly so I've undone it
@@ -1182,9 +1182,9 @@ tyConDataCons_maybe _                                                      = Not
 tyConFamilySize  :: TyCon -> Int
 tyConFamilySize (AlgTyCon   {algTcRhs = DataTyCon {data_cons = cons}}) = 
   length cons
-tyConFamilySize (AlgTyCon   {algTcRhs = NewTyCon {}})                  = 1
-tyConFamilySize (AlgTyCon   {algTcRhs = OpenTyCon {}})                 = 0
-tyConFamilySize (TupleTyCon {})	 		                       = 1
+tyConFamilySize (AlgTyCon   {algTcRhs = NewTyCon {}})        = 1
+tyConFamilySize (AlgTyCon   {algTcRhs = DataFamilyTyCon {}}) = 0
+tyConFamilySize (TupleTyCon {})	 		             = 1
 tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other)
 
 -- | Extract an 'AlgTyConRhs' with information about data constructors from an algebraic or tuple
@@ -1252,11 +1252,6 @@ synTyConType :: TyCon -> Type
 synTyConType tc = case synTcRhs tc of
 		    SynonymTyCon t -> t
 		    _		   -> pprPanic "synTyConType" (ppr tc)
-
--- | Find the 'Kind' of an open type synonym. Panics if the 'TyCon' is not an open type synonym
-synTyConResKind :: TyCon -> Kind
-synTyConResKind (SynTyCon {synTcRhs = OpenSynTyCon kind _}) = kind
-synTyConResKind tycon  = pprPanic "synTyConResKind" (ppr tycon)
 \end{code}
 
 \begin{code}
@@ -1283,33 +1278,41 @@ tyConClass_maybe :: TyCon -> Maybe Class
 tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas
 tyConClass_maybe _                                          = Nothing
 
+----------------------------------------------------------------------------
+tyConParent :: TyCon -> TyConParent
+tyConParent (AlgTyCon {algTcParent = parent}) = parent
+tyConParent (SynTyCon {synTcParent = parent}) = parent
+tyConParent _                                 = NoParentTyCon
+
 -- | Is this 'TyCon' that for a family instance, be that for a synonym or an
 -- algebraic family instance?
 isFamInstTyCon :: TyCon -> Bool
-isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True
-isFamInstTyCon (SynTyCon {synTcParent = FamilyTyCon _ _ _ }) = True
-isFamInstTyCon _                                             = False
+isFamInstTyCon tc = case tyConParent tc of
+                      FamInstTyCon {} -> True
+                      _               -> False
+
+tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], TyCon)
+tyConFamInstSig_maybe tc
+  = case tyConParent tc of
+      FamInstTyCon f ts co_tc -> Just (f, ts, co_tc)
+      _                       -> Nothing
 
 -- | If this 'TyCon' is that of a family instance, return the family in question
 -- and the instance types. Otherwise, return @Nothing@
 tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
-tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) = 
-  Just (fam, instTys)
-tyConFamInst_maybe (SynTyCon {synTcParent = FamilyTyCon fam instTys _}) = 
-  Just (fam, instTys)
-tyConFamInst_maybe _                                                    = 
-  Nothing
+tyConFamInst_maybe tc
+  = case tyConParent tc of
+      FamInstTyCon f ts _ -> Just (f, ts)
+      _                   -> Nothing
 
 -- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents 
 -- a coercion identifying the representation type with the type instance family.
 -- Otherwise, return @Nothing@
 tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon
-tyConFamilyCoercion_maybe (AlgTyCon {algTcParent = FamilyTyCon _ _ coe}) = 
-  Just coe
-tyConFamilyCoercion_maybe (SynTyCon {synTcParent = FamilyTyCon _ _ coe}) = 
-  Just coe
-tyConFamilyCoercion_maybe _                                              =
-  Nothing
+tyConFamilyCoercion_maybe tc
+  = case tyConParent tc of
+      FamInstTyCon _ _ co -> Just co
+      _                   -> Nothing
 \end{code}
 
 
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 4cea101..09cbdb0 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -46,7 +46,7 @@ module Type (
         tyFamInsts, predFamInsts,
 
         -- (Source types)
-        mkPredTy, mkPredTys, mkFamilyTyConApp, isEqPred,
+        mkPredTy, mkPredTys, mkFamilyTyConApp, isEqPred, coVarPred,
 
 	-- ** Common type constructors
         funTyCon,
@@ -76,14 +76,6 @@ module Type (
 	tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
 	expandTypeSynonyms,
 
-	-- * Tidying type related things up for printing
-	tidyType,      tidyTypes,
-	tidyOpenType,  tidyOpenTypes,
-	tidyTyVarBndr, tidyFreeTyVars,
-	tidyOpenTyVar, tidyOpenTyVars,
-	tidyTopType,   tidyPred,
-	tidyKind,
-
 	-- * Type comparison
 	coreEqType, coreEqType2,
         tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, 
@@ -138,7 +130,6 @@ import Var
 import VarEnv
 import VarSet
 
-import Name
 import Class
 import TyCon
 
@@ -148,7 +139,6 @@ import Util
 import Outputable
 import FastString
 
-import Data.List
 import Data.Maybe	( isJust )
 
 infixr 3 `mkFunTy`	-- Associates to the right
@@ -872,7 +862,7 @@ tyFamInsts ty
   | Just exp_ty <- tcView ty    = tyFamInsts exp_ty
 tyFamInsts (TyVarTy _)          = []
 tyFamInsts (TyConApp tc tys) 
-  | isOpenSynTyCon tc           = [(tc, tys)]
+  | isSynFamilyTyCon tc           = [(tc, tys)]
   | otherwise                   = concat (map tyFamInsts tys)
 tyFamInsts (FunTy ty1 ty2)      = tyFamInsts ty1 ++ tyFamInsts ty2
 tyFamInsts (AppTy ty1 ty2)      = tyFamInsts ty1 ++ tyFamInsts ty2
@@ -890,100 +880,6 @@ predFamInsts (EqPred ty1 ty2)  = tyFamInsts ty1 ++ tyFamInsts ty2
 
 %************************************************************************
 %*									*
-\subsection{TidyType}
-%*									*
-%************************************************************************
-
-\begin{code}
--- | This tidies up a type for printing in an error message, or in
--- an interface file.
--- 
--- It doesn't change the uniques at all, just the print names.
-tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
-tidyTyVarBndr env@(tidy_env, subst) tyvar
-  = case tidyOccName tidy_env (getOccName name) of
-      (tidy', occ') -> ((tidy', subst'), tyvar'')
-	where
-	  subst' = extendVarEnv subst tyvar tyvar''
-	  tyvar' = setTyVarName tyvar name'
-	  name'  = tidyNameOcc name occ'
-		-- Don't forget to tidy the kind for coercions!
-	  tyvar'' | isCoVar tyvar = setTyVarKind tyvar' kind'
-		  | otherwise	  = tyvar'
-	  kind'  = tidyType env (tyVarKind tyvar)
-  where
-    name = tyVarName tyvar
-
-tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
--- ^ Add the free 'TyVar's to the env in tidy form,
--- so that we can tidy the type they are free in
-tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars))
-
-tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
-tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars
-
-tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
--- ^ Treat a new 'TyVar' as a binder, and give it a fresh tidy name
--- using the environment if one has not already been allocated. See
--- also 'tidyTyVarBndr'
-tidyOpenTyVar env@(_, subst) tyvar
-  = case lookupVarEnv subst tyvar of
-	Just tyvar' -> (env, tyvar')		-- Already substituted
-	Nothing	    -> tidyTyVarBndr env tyvar	-- Treat it as a binder
-
-tidyType :: TidyEnv -> Type -> Type
-tidyType env@(_, subst) ty
-  = go ty
-  where
-    go (TyVarTy tv)	    = case lookupVarEnv subst tv of
-				Nothing  -> TyVarTy tv
-				Just tv' -> TyVarTy tv'
-    go (TyConApp tycon tys) = let args = map go tys
-			      in args `seqList` TyConApp tycon args
-    go (PredTy sty)	    = PredTy (tidyPred env sty)
-    go (AppTy fun arg)	    = (AppTy $! (go fun)) $! (go arg)
-    go (FunTy fun arg)	    = (FunTy $! (go fun)) $! (go arg)
-    go (ForAllTy tv ty)	    = ForAllTy tvp $! (tidyType envp ty)
-			      where
-			        (envp, tvp) = tidyTyVarBndr env tv
-
-tidyTypes :: TidyEnv -> [Type] -> [Type]
-tidyTypes env tys = map (tidyType env) tys
-
-tidyPred :: TidyEnv -> PredType -> PredType
-tidyPred env (IParam n ty)     = IParam n (tidyType env ty)
-tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
-tidyPred env (EqPred ty1 ty2)  = EqPred (tidyType env ty1) (tidyType env ty2)
-\end{code}
-
-
-\begin{code}
--- | Grabs the free type variables, tidies them
--- and then uses 'tidyType' to work over the type itself
-tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
-tidyOpenType env ty
-  = (env', tidyType env' ty)
-  where
-    env' = tidyFreeTyVars env (tyVarsOfType ty)
-
-tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
-tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
-
--- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)
-tidyTopType :: Type -> Type
-tidyTopType ty = tidyType emptyTidyEnv ty
-\end{code}
-
-\begin{code}
-
-tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
-tidyKind env k = tidyOpenType env k
-
-\end{code}
-
-
-%************************************************************************
-%*									*
 \subsection{Liftedness}
 %*									*
 %************************************************************************
@@ -1025,7 +921,7 @@ isClosedAlgType :: Type -> Bool
 isClosedAlgType ty
   = case splitTyConApp_maybe ty of
       Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
-			    isAlgTyCon tc && not (isOpenTyCon tc)
+			    isAlgTyCon tc && not (isFamilyTyCon tc)
       _other	         -> False
 \end{code}
 
diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 8322e9d..fafbaab 100644
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -455,8 +455,8 @@ pprTheta theta  = parens (sep (punctuate comma (map pprPred theta)))
 pprThetaArrow :: ThetaType -> SDoc
 pprThetaArrow []     = empty
 pprThetaArrow [pred] 
-  | noParenPred pred = pprPred pred <+> ptext (sLit "=>")
-pprThetaArrow preds  = parens (sep (punctuate comma (map pprPred preds))) <+> ptext (sLit "=>")
+  | noParenPred pred = pprPred pred <+> darrow
+pprThetaArrow preds  = parens (sep (punctuate comma (map pprPred preds))) <+> darrow
 
 noParenPred :: PredType -> Bool
 -- A predicate that can appear without parens before a "=>"
diff --git a/compiler/utils/Bag.lhs b/compiler/utils/Bag.lhs
index b2be2c3..fa18219 100644
--- a/compiler/utils/Bag.lhs
+++ b/compiler/utils/Bag.lhs
@@ -12,10 +12,13 @@ module Bag (
         emptyBag, unitBag, unionBags, unionManyBags,
         mapBag,
         elemBag, lengthBag,
-        filterBag, partitionBag, concatBag, foldBag, foldrBag, foldlBag,
+        filterBag, partitionBag, partitionBagWith,
+        concatBag, foldBag, foldrBag, foldlBag,
         isEmptyBag, isSingletonBag, consBag, snocBag, anyBag,
         listToBag, bagToList,
-        mapBagM, mapAndUnzipBagM
+        foldlBagM, mapBagM, mapBagM_, 
+        flatMapBagM, flatMapBagPairM,
+        mapAndUnzipBagM
     ) where
 
 #include "Typeable.h"
@@ -23,6 +26,7 @@ module Bag (
 import Outputable
 import Util
 
+import MonadUtils
 import Data.Data
 import Data.List ( partition )
 
@@ -115,6 +119,21 @@ partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails)
   where (sats, fails) = partition pred vs
 
 
+partitionBagWith :: (a -> Either b c) -> Bag a 
+                    -> (Bag b {- Left  -},
+                        Bag c {- Right -})
+partitionBagWith _    EmptyBag = (EmptyBag, EmptyBag)
+partitionBagWith pred (UnitBag val)
+    = case pred val of
+         Left a  -> (UnitBag a, EmptyBag) 
+         Right b -> (EmptyBag, UnitBag b)
+partitionBagWith pred (TwoBags b1 b2)
+    = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)
+  where (sat1, fail1) = partitionBagWith pred b1
+        (sat2, fail2) = partitionBagWith pred b2
+partitionBagWith pred (ListBag vs) = (listToBag sats, listToBag fails)
+  where (sats, fails) = partitionWith pred vs
+
 foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative
         -> (a -> r)      -- Replace UnitBag with this
         -> r             -- Replace EmptyBag with this
@@ -152,6 +171,11 @@ foldlBag k z (UnitBag x)     = k z x
 foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2
 foldlBag k z (ListBag xs)    = foldl k z xs
 
+foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b
+foldlBagM _ z EmptyBag        = return z
+foldlBagM k z (UnitBag x)     = k z x
+foldlBagM k z (TwoBags b1 b2) = do { z' <- foldlBagM k z b1; foldlBagM k z' b2 }
+foldlBagM k z (ListBag xs)    = foldlM k z xs
 
 mapBag :: (a -> b) -> Bag a -> Bag b
 mapBag _ EmptyBag        = EmptyBag
@@ -169,6 +193,33 @@ mapBagM f (TwoBags b1 b2) = do r1 <- mapBagM f b1
 mapBagM f (ListBag    xs) = do rs <- mapM f xs
                                return (ListBag rs)
 
+mapBagM_ :: Monad m => (a -> m b) -> Bag a -> m ()
+mapBagM_ _ EmptyBag        = return ()
+mapBagM_ f (UnitBag x)     = f x >> return ()
+mapBagM_ f (TwoBags b1 b2) = mapBagM_ f b1 >> mapBagM_ f b2
+mapBagM_ f (ListBag    xs) = mapM_ f xs
+
+flatMapBagM :: Monad m => (a -> m (Bag b)) -> Bag a -> m (Bag b)
+flatMapBagM _ EmptyBag        = return EmptyBag
+flatMapBagM f (UnitBag x)     = f x
+flatMapBagM f (TwoBags b1 b2) = do r1 <- flatMapBagM f b1
+                                   r2 <- flatMapBagM f b2
+                                   return (r1 `unionBags` r2)
+flatMapBagM f (ListBag    xs) = foldrM k EmptyBag xs
+  where
+    k x b2 = do { b1 <- f x; return (b1 `unionBags` b2) }
+
+flatMapBagPairM :: Monad m => (a -> m (Bag b, Bag c)) -> Bag a -> m (Bag b, Bag c)
+flatMapBagPairM _ EmptyBag        = return (EmptyBag, EmptyBag)
+flatMapBagPairM f (UnitBag x)     = f x
+flatMapBagPairM f (TwoBags b1 b2) = do (r1,s1) <- flatMapBagPairM f b1
+                                       (r2,s2) <- flatMapBagPairM f b2
+                                       return (r1 `unionBags` r2, s1 `unionBags` s2)
+flatMapBagPairM f (ListBag    xs) = foldrM k (EmptyBag, EmptyBag) xs
+  where
+    k x (r2,s2) = do { (r1,s1) <- f x
+                     ; return (r1 `unionBags` r2, s1 `unionBags` s2) }
+
 mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c)
 mapAndUnzipBagM _ EmptyBag        = return (EmptyBag, EmptyBag)
 mapAndUnzipBagM f (UnitBag x)     = do (r,s) <- f x
diff --git a/compiler/utils/Digraph.lhs b/compiler/utils/Digraph.lhs
index a2bb215..2ed3933 100644
--- a/compiler/utils/Digraph.lhs
+++ b/compiler/utils/Digraph.lhs
@@ -76,7 +76,7 @@ Note [Nodes, keys, vertices]
 
 \begin{code}
 data Graph node = Graph { 
-    gr_int_graph :: IntGraph,
+    gr_int_graph      :: IntGraph,
     gr_vertex_to_node :: Vertex -> node,
     gr_node_to_vertex :: node -> Maybe Vertex
   }
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index c6ba81c..7a643d7 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -23,7 +23,7 @@ module Outputable (
 	text, ftext, ptext,
 	int, integer, float, double, rational,
 	parens, cparen, brackets, braces, quotes, doubleQuotes, angleBrackets,
-	semi, comma, colon, dcolon, space, equals, dot, arrow,
+	semi, comma, colon, dcolon, space, equals, dot, arrow, darrow,
 	lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
 	blankLine,
 	(<>), (<+>), hcat, hsep, 
@@ -404,11 +404,12 @@ quotes d sty = case show pp_d of
 	       pp_d = d sty
 
 semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
-lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
+darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
 
 blankLine _sty = Pretty.ptext (sLit "")
 dcolon _sty    = Pretty.ptext (sLit "::")
 arrow  _sty    = Pretty.ptext (sLit "->")
+darrow _sty    = Pretty.ptext (sLit "=>")
 semi _sty      = Pretty.semi
 comma _sty     = Pretty.comma
 colon _sty     = Pretty.colon
diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
new file mode 100644
index 0000000..65a3489
--- /dev/null
+++ b/compiler/vectorise/VectMonad.hs
@@ -0,0 +1,651 @@
+{-# LANGUAGE NamedFieldPuns #-}
+
+-- | The Vectorisation monad.
+module VectMonad (
+  VM,
+
+  noV, traceNoV, ensureV, traceEnsureV, tryV, maybeV, traceMaybeV, orElseV,
+  onlyIfV, fixV, localV, closedV,
+  initV, cantVectorise, maybeCantVectorise, maybeCantVectoriseM,
+  liftDs,
+  cloneName, cloneId, cloneVar,
+  newExportedVar, newLocalVar, newLocalVars, newDummyVar, newTyVar,
+  
+  Builtins(..), sumTyCon, prodTyCon, prodDataCon,
+  selTy, selReplicate, selPick, selTags, selElements,
+  combinePDVar, scalarZip, closureCtrFun,
+  builtin, builtins,
+
+  setFamInstEnv,
+  readGEnv, setGEnv, updGEnv,
+
+  readLEnv, setLEnv, updLEnv,
+
+  getBindName, inBind,
+
+  lookupVar, defGlobalVar, globalScalars,
+  lookupTyCon, defTyCon,
+  lookupDataCon, defDataCon,
+  lookupTyConPA, defTyConPA, defTyConPAs,
+  lookupTyConPR,
+  lookupBoxedTyCon,
+  lookupPrimMethod, lookupPrimPArray,
+  lookupTyVarPA, defLocalTyVar, defLocalTyVarWithPA, localTyVars,
+
+  lookupInst, lookupFamInst
+) where
+
+#include "HsVersions.h"
+
+import VectBuiltIn
+import Vectorise.Env
+
+import HscTypes hiding  ( MonadThings(..) )
+import Module           ( PackageId )
+import CoreSyn
+import Class
+import TyCon
+import DataCon
+import Type
+import Var
+import VarSet
+import VarEnv
+import Id
+import Name
+import NameEnv
+
+import DsMonad
+
+import InstEnv
+import FamInstEnv
+
+import Outputable
+import FastString
+import SrcLoc        ( noSrcSpan )
+
+import Control.Monad
+
+-- | Indicates what scope something (a variable) is in.
+data Scope a b = Global a | Local b
+
+
+-- | The global environment.
+data GlobalEnv = GlobalEnv {
+                  -- | Mapping from global variables to their vectorised versions.
+                  -- 
+                  global_vars :: VarEnv Var
+
+                  -- | Purely scalar variables. Code which mentions only these
+                  --   variables doesn't have to be lifted.
+                , global_scalars :: VarSet
+
+                  -- | Exported variables which have a vectorised version
+                  --
+                , global_exported_vars :: VarEnv (Var, Var)
+
+                  -- | Mapping from TyCons to their vectorised versions.
+                  --   TyCons which do not have to be vectorised are mapped to
+                  --   themselves.
+                  --
+                , global_tycons :: NameEnv TyCon
+
+                  -- | Mapping from DataCons to their vectorised versions
+                  --
+                , global_datacons :: NameEnv DataCon
+
+                  -- | Mapping from TyCons to their PA dfuns
+                  --
+                , global_pa_funs :: NameEnv Var
+
+                  -- | Mapping from TyCons to their PR dfuns
+                , global_pr_funs :: NameEnv Var
+
+                  -- | Mapping from unboxed TyCons to their boxed versions
+                , global_boxed_tycons :: NameEnv TyCon
+
+                -- | External package inst-env & home-package inst-env for class
+                --   instances
+                --
+                , global_inst_env :: (InstEnv, InstEnv)
+
+                -- | External package inst-env & home-package inst-env for family
+                --   instances
+                --
+                , global_fam_inst_env :: FamInstEnvs
+
+                -- | Hoisted bindings
+                , global_bindings :: [(Var, CoreExpr)]
+                }
+
+-- | The local environment.
+data LocalEnv = LocalEnv {
+                 -- Mapping from local variables to their vectorised and
+                 -- lifted versions
+                 --
+                 local_vars :: VarEnv (Var, Var)
+
+                 -- In-scope type variables
+                 --
+               , local_tyvars :: [TyVar]
+
+                 -- Mapping from tyvars to their PA dictionaries
+               , local_tyvar_pa :: VarEnv CoreExpr
+
+                 -- Local binding name
+               , local_bind_name :: FastString
+               }
+
+
+-- | Create an initial global environment
+initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
+initGlobalEnv info instEnvs famInstEnvs
+  = GlobalEnv {
+      global_vars          = mapVarEnv snd $ vectInfoVar info
+    , global_scalars   = emptyVarSet
+    , global_exported_vars = emptyVarEnv
+    , global_tycons        = mapNameEnv snd $ vectInfoTyCon info
+    , global_datacons      = mapNameEnv snd $ vectInfoDataCon info
+    , global_pa_funs       = mapNameEnv snd $ vectInfoPADFun info
+    , global_pr_funs       = emptyNameEnv
+    , global_boxed_tycons  = emptyNameEnv
+    , global_inst_env      = instEnvs
+    , global_fam_inst_env  = famInstEnvs
+    , global_bindings      = []
+    }
+
+
+-- Operators on Global Environments -------------------------------------------
+extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv
+extendImportedVarsEnv ps genv
+  = genv { global_vars = extendVarEnvList (global_vars genv) ps }
+
+extendScalars :: [Var] -> GlobalEnv -> GlobalEnv
+extendScalars vs genv
+  = genv { global_scalars = extendVarSetList (global_scalars genv) vs }
+
+setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv
+setFamInstEnv l_fam_inst genv
+  = genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) }
+  where
+    (g_fam_inst, _) = global_fam_inst_env genv
+
+extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
+extendTyConsEnv ps genv
+  = genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
+
+extendDataConsEnv :: [(Name, DataCon)] -> GlobalEnv -> GlobalEnv
+extendDataConsEnv ps genv
+  = genv { global_datacons = extendNameEnvList (global_datacons genv) ps }
+
+extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
+extendPAFunsEnv ps genv
+  = genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps }
+
+setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
+setPRFunsEnv ps genv
+  = genv { global_pr_funs = mkNameEnv ps }
+
+setBoxedTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
+setBoxedTyConsEnv ps genv
+  = genv { global_boxed_tycons = mkNameEnv ps }
+
+
+-- | Create an empty local environment.
+emptyLocalEnv :: LocalEnv
+emptyLocalEnv = LocalEnv {
+                   local_vars     = emptyVarEnv
+                 , local_tyvars   = []
+                 , local_tyvar_pa = emptyVarEnv
+                 , local_bind_name  = fsLit "fn"
+                 }
+
+-- FIXME
+updVectInfo :: GlobalEnv -> TypeEnv -> VectInfo -> VectInfo
+updVectInfo env tyenv info
+  = info {
+      vectInfoVar     = global_exported_vars env
+    , vectInfoTyCon   = mk_env typeEnvTyCons global_tycons
+    , vectInfoDataCon = mk_env typeEnvDataCons global_datacons
+    , vectInfoPADFun  = mk_env typeEnvTyCons global_pa_funs
+    }
+  where
+    mk_env :: NamedThing from =>
+              (TypeEnv -> [from])
+           -> (GlobalEnv -> NameEnv to)
+           -> NameEnv (from,to)
+    mk_env from_tyenv from_env = mkNameEnv [(name, (from,to))
+                                   | from <- from_tyenv tyenv
+                                   , let name = getName from
+                                   , Just to <- [lookupNameEnv (from_env env) name]]
+
+-- The Vectorisation Monad ----------------------------------------------------
+
+-- Vectorisation can either succeed with new envionment and a value,
+-- or return with failure.
+--
+data VResult a = Yes GlobalEnv LocalEnv a | No
+
+newtype VM a = VM { runVM :: Builtins -> GlobalEnv -> LocalEnv -> DsM (VResult a) }
+
+instance Monad VM where
+  return x   = VM $ \_  genv lenv -> return (Yes genv lenv x)
+  VM p >>= f = VM $ \bi genv lenv -> do
+                                      r <- p bi genv lenv
+                                      case r of
+                                        Yes genv' lenv' x -> runVM (f x) bi genv' lenv'
+                                        No                -> return No
+
+
+-- | Throw an error saying we can't vectorise something
+cantVectorise :: String -> SDoc -> a
+cantVectorise s d = pgmError
+                  . showSDocDump
+                  $ vcat [text "*** Vectorisation error ***",
+                          nest 4 $ sep [text s, nest 4 d]]
+
+maybeCantVectorise :: String -> SDoc -> Maybe a -> a
+maybeCantVectorise s d Nothing  = cantVectorise s d
+maybeCantVectorise _ _ (Just x) = x
+
+maybeCantVectoriseM :: Monad m => String -> SDoc -> m (Maybe a) -> m a
+maybeCantVectoriseM s d p
+  = do
+      r <- p
+      case r of
+        Just x  -> return x
+        Nothing -> cantVectorise s d
+
+
+-- Control --------------------------------------------------------------------
+-- | Return some result saying we've failed.
+noV :: VM a
+noV = VM $ \_ _ _ -> return No
+
+traceNoV :: String -> SDoc -> VM a
+traceNoV s d = pprTrace s d noV
+
+
+-- | If True then carry on, otherwise fail.
+ensureV :: Bool -> VM ()
+ensureV False = noV
+ensureV True  = return ()
+
+
+-- | If True then return the first argument, otherwise fail.
+onlyIfV :: Bool -> VM a -> VM a
+onlyIfV b p = ensureV b >> p
+
+traceEnsureV :: String -> SDoc -> Bool -> VM ()
+traceEnsureV s d False = traceNoV s d
+traceEnsureV _ _ True  = return ()
+
+
+-- | Try some vectorisation computaton.
+--	If it succeeds then return Just the result,
+--	otherwise return Nothing.
+tryV :: VM a -> VM (Maybe a)
+tryV (VM p) = VM $ \bi genv lenv ->
+  do
+    r <- p bi genv lenv
+    case r of
+      Yes genv' lenv' x -> return (Yes genv' lenv' (Just x))
+      No                -> return (Yes genv  lenv  Nothing)
+
+
+maybeV :: VM (Maybe a) -> VM a
+maybeV p = maybe noV return =<< p
+
+traceMaybeV :: String -> SDoc -> VM (Maybe a) -> VM a
+traceMaybeV s d p = maybe (traceNoV s d) return =<< p
+
+orElseV :: VM a -> VM a -> VM a
+orElseV p q = maybe q return =<< tryV p
+
+fixV :: (a -> VM a) -> VM a
+fixV f = VM (\bi genv lenv -> fixDs $ \r -> runVM (f (unYes r)) bi genv lenv )
+  where
+    -- NOTE: It is essential that we are lazy in r above so do not replace
+    --       calls to this function by an explicit case.
+    unYes (Yes _ _ x) = x
+    unYes No          = panic "VectMonad.fixV: no result"
+
+
+-- Local Environments ---------------------------------------------------------
+-- | Perform a computation in its own local environment.
+--	This does not alter the environment of the current state.
+localV :: VM a -> VM a
+localV p = do
+             env <- readLEnv id
+             x <- p
+             setLEnv env
+             return x
+
+-- | Perform a computation in an empty local environment.
+closedV :: VM a -> VM a
+closedV p = do
+              env <- readLEnv id
+              setLEnv (emptyLocalEnv { local_bind_name = local_bind_name env })
+              x <- p
+              setLEnv env
+              return x
+
+-- Lifting --------------------------------------------------------------------
+-- | Lift a desugaring computation into the vectorisation monad.
+liftDs :: DsM a -> VM a
+liftDs p = VM $ \_ genv lenv -> do { x <- p; return (Yes genv lenv x) }
+
+
+
+-- Builtins -------------------------------------------------------------------
+-- Operations on Builtins
+liftBuiltinDs :: (Builtins -> DsM a) -> VM a
+liftBuiltinDs p = VM $ \bi genv lenv -> do { x <- p bi; return (Yes genv lenv x)}
+
+
+-- | Project something from the set of builtins.
+builtin :: (Builtins -> a) -> VM a
+builtin f = VM $ \bi genv lenv -> return (Yes genv lenv (f bi))
+
+builtins :: (a -> Builtins -> b) -> VM (a -> b)
+builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
+
+
+-- Environments ---------------------------------------------------------------
+-- | Project something from the global environment.
+readGEnv :: (GlobalEnv -> a) -> VM a
+readGEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f genv))
+
+setGEnv :: GlobalEnv -> VM ()
+setGEnv genv = VM $ \_ _ lenv -> return (Yes genv lenv ())
+
+updGEnv :: (GlobalEnv -> GlobalEnv) -> VM ()
+updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ())
+
+
+-- | Project something from the local environment.
+readLEnv :: (LocalEnv -> a) -> VM a
+readLEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f lenv))
+
+-- | Set the local environment.
+setLEnv :: LocalEnv -> VM ()
+setLEnv lenv = VM $ \_ genv _ -> return (Yes genv lenv ())
+
+-- | Update the enviroment using a provided function.
+updLEnv :: (LocalEnv -> LocalEnv) -> VM ()
+updLEnv f = VM $ \_ genv lenv -> return (Yes genv (f lenv) ())
+
+
+-- InstEnv --------------------------------------------------------------------
+getInstEnv :: VM (InstEnv, InstEnv)
+getInstEnv = readGEnv global_inst_env
+
+getFamInstEnv :: VM FamInstEnvs
+getFamInstEnv = readGEnv global_fam_inst_env
+
+
+-- Names ----------------------------------------------------------------------
+-- | Get the name of the local binding currently being vectorised.
+getBindName :: VM FastString
+getBindName = readLEnv local_bind_name
+
+inBind :: Id -> VM a -> VM a
+inBind id p
+  = do updLEnv $ \env -> env { local_bind_name = occNameFS (getOccName id) }
+       p
+
+cloneName :: (OccName -> OccName) -> Name -> VM Name
+cloneName mk_occ name = liftM make (liftDs newUnique)
+  where
+    occ_name = mk_occ (nameOccName name)
+
+    make u | isExternalName name = mkExternalName u (nameModule name)
+                                                    occ_name
+                                                    (nameSrcSpan name)
+           | otherwise           = mkSystemName u occ_name
+
+cloneId :: (OccName -> OccName) -> Id -> Type -> VM Id
+cloneId mk_occ id ty
+  = do
+      name <- cloneName mk_occ (getName id)
+      let id' | isExportedId id = Id.mkExportedLocalId name ty
+              | otherwise       = Id.mkLocalId         name ty
+      return id'
+
+-- Make a fresh instance of this var, with a new unique.
+cloneVar :: Var -> VM Var
+cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
+
+newExportedVar :: OccName -> Type -> VM Var
+newExportedVar occ_name ty 
+  = do
+      mod <- liftDs getModuleDs
+      u   <- liftDs newUnique
+
+      let name = mkExternalName u mod occ_name noSrcSpan
+      
+      return $ Id.mkExportedLocalId name ty
+
+newLocalVar :: FastString -> Type -> VM Var
+newLocalVar fs ty
+  = do
+      u <- liftDs newUnique
+      return $ mkSysLocal fs u ty
+
+newLocalVars :: FastString -> [Type] -> VM [Var]
+newLocalVars fs = mapM (newLocalVar fs)
+
+newDummyVar :: Type -> VM Var
+newDummyVar = newLocalVar (fsLit "vv")
+
+newTyVar :: FastString -> Kind -> VM Var
+newTyVar fs k
+  = do
+      u <- liftDs newUnique
+      return $ mkTyVar (mkSysTvName u fs) k
+
+
+-- | Add a mapping between a global var and its vectorised version to the state.
+defGlobalVar :: Var -> Var -> VM ()
+defGlobalVar v v' = updGEnv $ \env ->
+  env { global_vars = extendVarEnv (global_vars env) v v'
+      , global_exported_vars = upd (global_exported_vars env)
+      }
+  where
+    upd env | isExportedId v = extendVarEnv env v (v, v')
+            | otherwise      = env
+
+-- Var ------------------------------------------------------------------------
+-- | Lookup the vectorised and\/or lifted versions of this variable.
+--	If it's in the global environment we get the vectorised version.
+--      If it's in the local environment we get both the vectorised and lifted version.
+--	
+lookupVar :: Var -> VM (Scope Var (Var, Var))
+lookupVar v
+ = do r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
+      case r of
+        Just e  -> return (Local e)
+        Nothing -> liftM Global
+                . maybeCantVectoriseVarM v
+                . readGEnv $ \env -> lookupVarEnv (global_vars env) v
+
+maybeCantVectoriseVarM :: Monad m => Var -> m (Maybe Var) -> m Var
+maybeCantVectoriseVarM v p
+ = do r <- p
+      case r of
+        Just x  -> return x
+        Nothing -> dumpVar v
+
+dumpVar :: Var -> a
+dumpVar var
+	| Just _		<- isClassOpId_maybe var
+	= cantVectorise "ClassOpId not vectorised:" (ppr var)
+
+	| otherwise
+	= cantVectorise "Variable not vectorised:" (ppr var)
+
+-------------------------------------------------------------------------------
+globalScalars :: VM VarSet
+globalScalars = readGEnv global_scalars
+
+lookupTyCon :: TyCon -> VM (Maybe TyCon)
+lookupTyCon tc
+  | isUnLiftedTyCon tc || isTupleTyCon tc = return (Just tc)
+
+  | otherwise = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
+
+defTyCon :: TyCon -> TyCon -> VM ()
+defTyCon tc tc' = updGEnv $ \env ->
+  env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
+
+lookupDataCon :: DataCon -> VM (Maybe DataCon)
+lookupDataCon dc
+  | isTupleTyCon (dataConTyCon dc) = return (Just dc)
+  | otherwise = readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
+
+defDataCon :: DataCon -> DataCon -> VM ()
+defDataCon dc dc' = updGEnv $ \env ->
+  env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
+
+lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
+lookupPrimPArray = liftBuiltinDs . primPArray
+
+lookupPrimMethod :: TyCon -> String -> VM (Maybe Var)
+lookupPrimMethod tycon = liftBuiltinDs . primMethod tycon
+
+lookupTyConPA :: TyCon -> VM (Maybe Var)
+lookupTyConPA tc = readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
+
+defTyConPA :: TyCon -> Var -> VM ()
+defTyConPA tc pa = updGEnv $ \env ->
+  env { global_pa_funs = extendNameEnv (global_pa_funs env) (tyConName tc) pa }
+
+defTyConPAs :: [(TyCon, Var)] -> VM ()
+defTyConPAs ps = updGEnv $ \env ->
+  env { global_pa_funs = extendNameEnvList (global_pa_funs env)
+                                           [(tyConName tc, pa) | (tc, pa) <- ps] }
+
+lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
+lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
+
+lookupTyConPR :: TyCon -> VM (Maybe Var)
+lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
+
+lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon)
+lookupBoxedTyCon tc = readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env)
+                                                       (tyConName tc)
+
+defLocalTyVar :: TyVar -> VM ()
+defLocalTyVar tv = updLEnv $ \env ->
+  env { local_tyvars   = tv : local_tyvars env
+      , local_tyvar_pa = local_tyvar_pa env `delVarEnv` tv
+      }
+
+defLocalTyVarWithPA :: TyVar -> CoreExpr -> VM ()
+defLocalTyVarWithPA tv pa = updLEnv $ \env ->
+  env { local_tyvars   = tv : local_tyvars env
+      , local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa
+      }
+
+localTyVars :: VM [TyVar]
+localTyVars = readLEnv (reverse . local_tyvars)
+
+-- Look up the dfun of a class instance.
+--
+-- The match must be unique - ie, match exactly one instance - but the 
+-- type arguments used for matching may be more specific than those of 
+-- the class instance declaration.  The found class instances must not have
+-- any type variables in the instance context that do not appear in the
+-- instances head (i.e., no flexi vars); for details for what this means,
+-- see the docs at InstEnv.lookupInstEnv.
+--
+lookupInst :: Class -> [Type] -> VM (DFunId, [Type])
+lookupInst cls tys
+  = do { instEnv <- getInstEnv
+       ; case lookupInstEnv instEnv cls tys of
+	   ([(inst, inst_tys)], _) 
+             | noFlexiVar -> return (instanceDFunId inst, inst_tys')
+             | otherwise  -> pprPanic "VectMonad.lookupInst: flexi var: " 
+                                      (ppr $ mkTyConApp (classTyCon cls) tys)
+             where
+               inst_tys'  = [ty | Right ty <- inst_tys]
+               noFlexiVar = all isRight inst_tys
+	   _other         ->
+             pprPanic "VectMonad.lookupInst: not found " (ppr cls <+> ppr tys)
+       }
+  where
+    isRight (Left  _) = False
+    isRight (Right _) = True
+
+-- Look up the representation tycon of a family instance.
+--
+-- The match must be unique - ie, match exactly one instance - but the 
+-- type arguments used for matching may be more specific than those of 
+-- the family instance declaration.
+--
+-- Return the instance tycon and its type instance.  For example, if we have
+--
+--  lookupFamInst 'T' '[Int]' yields (':R42T', 'Int')
+--
+-- then we have a coercion (ie, type instance of family instance coercion)
+--
+--  :Co:R42T Int :: T [Int] ~ :R42T Int
+--
+-- which implies that :R42T was declared as 'data instance T [a]'.
+--
+lookupFamInst :: TyCon -> [Type] -> VM (TyCon, [Type])
+lookupFamInst tycon tys
+  = ASSERT( isFamilyTyCon tycon )
+    do { instEnv <- getFamInstEnv
+       ; case lookupFamInstEnv instEnv tycon tys of
+	   [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
+	   _other                -> 
+             pprPanic "VectMonad.lookupFamInst: not found: " 
+                      (ppr $ mkTyConApp tycon tys)
+       }
+
+
+-- | Run a vectorisation computation.
+initV :: PackageId -> HscEnv -> ModGuts -> VectInfo -> VM a -> IO (Maybe (VectInfo, a))
+initV pkg hsc_env guts info p
+  = do
+         -- XXX: ignores error messages and warnings, check that this is
+         -- indeed ok (the use of "Just r" suggests so)
+      (_,Just r) <- initDs hsc_env (mg_module guts)
+                               (mg_rdr_env guts)
+                               (mg_types guts)
+                               go
+      return r
+  where
+
+    go =
+      do
+        builtins       <- initBuiltins pkg
+        builtin_vars   <- initBuiltinVars builtins
+        builtin_tycons <- initBuiltinTyCons builtins
+        let builtin_datacons = initBuiltinDataCons builtins
+        builtin_boxed  <- initBuiltinBoxedTyCons builtins
+        builtin_scalars <- initBuiltinScalars builtins
+
+        eps <- liftIO $ hscEPS hsc_env
+        let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
+            instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
+
+        builtin_prs    <- initBuiltinPRs builtins instEnvs
+        builtin_pas    <- initBuiltinPAs builtins instEnvs
+
+        let genv = extendImportedVarsEnv builtin_vars
+                 . extendScalars builtin_scalars
+                 . extendTyConsEnv builtin_tycons
+                 . extendDataConsEnv builtin_datacons
+                 . extendPAFunsEnv builtin_pas
+                 . setPRFunsEnv    builtin_prs
+                 . setBoxedTyConsEnv builtin_boxed
+                 $ initGlobalEnv info instEnvs famInstEnvs
+
+        r <- runVM p builtins genv emptyLocalEnv
+        case r of
+          Yes genv _ x -> return $ Just (new_info genv, x)
+          No           -> return Nothing
+
+    new_info genv = updVectInfo genv (mg_types guts) info
+
diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
index 7bfdc23..2fc94d8 100644
--- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs
+++ b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
@@ -70,7 +70,7 @@ lookupInst cls tys
 --
 lookupFamInst :: TyCon -> [Type] -> VM (TyCon, [Type])
 lookupFamInst tycon tys
-  = ASSERT( isOpenTyCon tycon )
+  = ASSERT( isFamilyTyCon tycon )
     do { instEnv <- getFamInstEnv
        ; case lookupFamInstEnv instEnv tycon tys of
 	   [(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 851fb79..18de832 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -1,4 +1,6 @@
-{-# OPTIONS -fno-warn-missing-signatures #-}
+{-# OPTIONS_GHC -XNoMonoLocalBinds -fno-warn-missing-signatures #-}
+-- Roman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
 
 module Vectorise.Type.Env ( 
 	vectTypeEnv,
diff --git a/compiler/vectorise/Vectorise/Type/PData.hs b/compiler/vectorise/Vectorise/Type/PData.hs
index 34c9bec..332344b 100644
--- a/compiler/vectorise/Vectorise/Type/PData.hs
+++ b/compiler/vectorise/Vectorise/Type/PData.hs
@@ -33,6 +33,7 @@ buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc ->
                            rec_flag    -- FIXME: is this ok?
                            False       -- FIXME: no generics
                            False       -- not GADT syntax
+                           NoParentTyCon
                            (Just $ mk_fam_inst pdata vect_tc)
   where
     orig_name = tyConName orig_tc
diff --git a/compiler/vectorise/Vectorise/Type/PRepr.hs b/compiler/vectorise/Vectorise/Type/PRepr.hs
index 81edaab..1556626 100644
--- a/compiler/vectorise/Vectorise/Type/PRepr.hs
+++ b/compiler/vectorise/Vectorise/Type/PRepr.hs
@@ -41,6 +41,7 @@ buildPReprTyCon orig_tc vect_tc repr
                              tyvars
                              (SynonymTyCon rhs_ty)
 			     (typeKind rhs_ty)
+                             NoParentTyCon
                              (Just $ mk_fam_inst prepr_tc vect_tc)
   where
     tyvars = tyConTyVars vect_tc
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 34ce559..0fa8482 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -84,6 +84,7 @@ vectTyConDecl tycon
                             rec_flag            -- FIXME: is this ok?
                             False               -- FIXME: no generics
                             False               -- not GADT syntax
+                            NoParentTyCon
                             Nothing             -- not a family instance
 
     -- some other crazy thing that we don't handle.
diff --git a/compiler/vectorise/Vectorise/Utils.hs b/compiler/vectorise/Vectorise/Utils.hs
index 31bb508..3dd5425 100644
--- a/compiler/vectorise/Vectorise/Utils.hs
+++ b/compiler/vectorise/Vectorise/Utils.hs
@@ -49,7 +49,7 @@ collectAnnTypeArgs expr = go expr []
 collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
 collectAnnTypeBinders expr = go [] expr
   where
-    go bs (_, AnnLam b e) | isTyVar b = go (b:bs) e
+    go bs (_, AnnLam b e) | isTyCoVar b = go (b:bs) e
     go bs e                           = (reverse bs, e)
 
 collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
diff --git a/new_tc_notes b/new_tc_notes
new file mode 100644
index 0000000..bf75f9b
--- /dev/null
+++ b/new_tc_notes
@@ -0,0 +1,181 @@
+
+Notes on the new type constraint solver
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* 1/9/10: Consider
+    {alpha} [b] (c~b) => (alpha ~ b)
+  Then to maximise the chance of floating the equality out of
+  the implication we'd like to orient the given as (b~c) 
+  rather than (c~b).
+     See test gadt-escape1, gadt13, gadt7
+  These tests pass because of approximateImplications
+
+* Equality superclasses are not getting the right instance decl
+    indexed-types/should_compile/T2238:
+
+* Partial applications of data type families
+    indexed-types/should_compile/DerivingNewType
+  
+Functional dependencies
+~~~~~~~~~~~~~~~~~~~~~~~
+* indexed-types/Gentle
+
+RelaxedPolyRec by default
+~~~~~~~~~~~~~~~~~~~~~~~~~
+* tcfail071
+* tcfail144
+* tcfail149, 150
+
+
+---------------------
+* 18/8/10: Fixed treatment of new work list from superclasses of wanteds. 
+           TODO TODO: Revisit the desugarer to deal with equalities that 
+           may mention recursive dictionaries. 
+
+* 12/8/10: Fixed proper kind checking for equalities and type family equalities.
+  NOTE: Type synonyms stay unexpanded in canonical constraints. Is this correct?
+
+* 24/7/10: canonicalisation orients meta variables
+           kind checking?
+  see trySpontaneous: need to take care with orientation 
+
+* See newWantedSCWorkList: no adding superclass equalities
+  for wanteds.  Seems ad hoc.
+
+* Happy genericTemplate notHappyAtAll needs a signature
+
+* time package needs signatures; I have put -XNoMonoLocalBinds in 
+     validate-settings.mk for now
+
+Improve error message
+~~~~~~~~~~~~~~~~~~~~~
+   FD1(normal)          <- DV: Failure to produce FD equality from *given* and top-level
+
+   FD2(normal)          <- DV: Failure to produce FC equality from two *givens*
+
+Unexpected failures:
+~~~~~~~~~~~~~~~~~~~~~
+   PolyRec(normal,hpc,optasm)     <- DV: Actually works, but we have a warning 
+                                     for -XRelaxedPolyRec deprecated flag
+   T1470(normal,optc,hpc,optasm)   
+   T2494(normal)
+   T2494-2(normal,optc,hpc,optasm)
+   T3108(normal,hpc,optasm)       <- DV: Actually works, but we have a warning for 
+                                     deprecated flags
+   T3391(normal,optc,hpc,optasm)  
+   tc003(hpc)
+   tc081(normal,optc,hpc,optasm)  <- DV: Let does not get generalized for 
+                                         *single* variable binding
+   tc089(normal,optc,hpc,optasm)       
+   tc095(normal,optc,hpc,optasm)
+   tc111(normal,optc,hpc,optasm)
+   tc113(normal,optc,hpc,optasm)  Generalize top-level var binding
+   tc127(normal,optc,hpc,optasm)  <- DV: Missing module Maybe in haskell98 package ... 
+   tc132(normal,optc,hpc,optasm)  Generalize top-level var binding
+   tc150(normal,optc,hpc,optasm)  Pattern signatures 
+   tc159(normal,optc,hpc,optasm)  <- ILL FORMED EVIDENCE (related to newtype ... deriving) 
+   tc162(normal)
+   tc168(normal,optc,hpc,optasm)  <- DV: Actually works, don't know why its reported
+   tc170(normal)
+   tc175(normal,optc,hpc,optasm)
+   tc189(normal,optc,hpc,optasm)  <- higher-rank ? 
+   tc192(normal,optc,hpc,optasm)  <- loop in desugarer
+   tc194(normal,optc,hpc,optasm)  <- polymorphic pattern signatures / higher-rank?
+   tc211(normal,optc,hpc,optasm)  <- polymorphic pattern signatures / higher-rank?
+   tc216(normal,optc,hpc,optasm)  <- ctx stack depth exceeded ... 
+   tc217(normal,optc,hpc,optasm)  
+   tc222(normal,optc,hpc,optasm)
+   tc231(normal,optc,hpc,optasm)
+   tc237(normal,optc,hpc,optasm)
+   tc243(normal,optc,hpc,optasm)      <- DV: Actually works, Definition but no signature warning 
+   tc244(normal,optc,hpc,optasm)
+
+
+ 
+
+ToDo
+~~~~
+* zonking Coercions should use a function of a different name
+
+Basic setup
+~~~~~~~~~~~
+   New modules     TcSimplify (old name, but all new code)
+		   TcInteract
+                   TcCanonical (defines the TcS monad too)
+                   Constraints (both Wanted and Canonical)
+
+Existing modules   Coercion (defines operations over Coercions)
+	 	   Kind
+	 	   Type
+		   TypeRep (the representation of types, kinds, coercions)
+
+   Dead modules	   TcTyFuns
+		   TcSimplify-old.lhs (the old TcSimplify, 
+			in repo just for reference)
+
+
+Significant differences wrt the prototype
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+* "Givens"  are simply evidence variables (EvVar)
+  "Wanteds" are WantedConstraints
+  See the Implication type in TcSolverTypes.lhs
+
+  There is no sum type combining given and wanted constraints
+
+* Wanted constraints are of three flavours (see data WantedConstraint)
+	- evidenence variables: we can abstract over these
+	- implications: we can't abstract over these
+        - literal and method constraints; we can't abstract over these
+		either, and they aren't implemented yet
+
+* We use a mutable group of bindings attached to each Inplication as the
+  place to accumulate evidence for dictionaries and implicit parameters
+  (It's also vital for equality superclasses.)  Each Impliciation has a
+  TcEvBinds, defined in hsSyn/HsBinds.  The reference cell to accumulate
+  bindings into is carried by the TcS solver monad; we need to fill in 
+  evidence in the solver.
+
+* An evidence variable is
+	- a dictionary
+	- an implicit paramter
+	- a coercion variable
+  See newEvVar in Inst.lhs
+
+* The main Tc monad carries a set of untouchables
+  The unifier ensures that they are not unified
+  See Note [Unifying untouchables]
+
+* tcCheckExpr does deep-skol on expected type, and
+  then calls tcExpr with (Check ty), where ty is deeply-skolemised
+
+
+-------------------
+Things to check later
+-------------------
+* Monomorphism restriction puts type variables in the top level env
+  When generalising, we can't generalise over these ones (alas)
+  Consider: 
+    - Reject programs that fall under the monomorphism restriction
+        (top-level monomorphic is rare)
+    - Some hack to accept H98 programs
+
+* No orientation of tv~ty constraints; we don't need it
+
+Note [OpenSynTyCon app]
+~~~~~~~~~~~~~~~~~~~~~~~
+Given
+
+  type family T a :: * -> *
+
+the two types (T () a) and (T () Int) must unify, even if there are
+no type instances for T at all.  Should we just turn them into an
+equality (T () a ~ T () Int)?  I don't think so.  We currently try to
+eagerly unify everything we can before generating equalities; otherwise,
+we could turn the unification of [Int] with [a] into an equality, too.
+
+------------------------
+We need to both 'unBox' and zonk deferred types.  We need to unBox as
+functions, such as TcExpr.tcMonoExpr promise to fill boxes in the expected
+type.  We need to zonk as the types go into the kind of the coercion variable
+`cotv' and those are not zonked in Inst.zonkInst.  (Maybe it would be better
+to zonk in zonInst instead.  Would that be sufficient?)
+
-- 
1.7.10.4